diff -ruN ghc-6.12.1/aclocal.m4 ghc-6.13-20091231/aclocal.m4 --- ghc-6.12.1/aclocal.m4 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13-20091231/aclocal.m4 1969-12-31 16:00:00.000000000 -0800 @@ -1,1238 +0,0 @@ -# Extra autoconf macros for the Glasgow fptools -# -# To be a good autoconf citizen, names of local macros have prefixed with FP_ to -# ensure we don't clash with any pre-supplied autoconf ones. - - -# FPTOOLS_FLOAT_WORD_ORDER_BIGENDIAN -# ---------------------------------- -# Little endian Arm on Linux with some ABIs has big endian word order -# in doubles. Define FLOAT_WORDS_BIGENDIAN if this is the case. -AC_DEFUN([FPTOOLS_FLOAT_WORD_ORDER_BIGENDIAN], - [AC_CACHE_CHECK([whether float word order is big endian], [fptools_cv_float_word_order_bigendian], - [AC_COMPILE_IFELSE( - [AC_LANG_PROGRAM( - [#include ], - [#if defined(__FLOAT_WORD_ORDER) && __FLOAT_WORD_ORDER == BIG_ENDIAN - return 0; - #else - not float word order big endian - #endif] - )], - [fptools_cv_float_word_order_bigendian=yes], - [fptools_cv_float_word_order_bigendian=no]) - ]) - case $fptools_cv_float_word_order_bigendian in - yes) - AC_DEFINE([FLOAT_WORDS_BIGENDIAN], 1, - [Define to 1 if your processor stores words of floats with - the most significant byte first]) ;; - esac -]) - - -# FP_EVAL_STDERR(COMMAND) -# ----------------------- -# Eval COMMAND, save its stderr (without lines resulting from shell tracing) -# into the file conftest.err and the exit status in the variable fp_status. -AC_DEFUN([FP_EVAL_STDERR], -[{ (eval $1) 2>conftest.er1 - fp_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - (exit $fp_status); }[]dnl -])# FP_EVAL_STDERR - - -# FP_ARG_WITH_PATH_GNU_PROG -# -------------------- -# XXX -# -# $1 = the command to look for -# $2 = the variable to set -# -AC_DEFUN([FP_ARG_WITH_PATH_GNU_PROG], -[ -AC_ARG_WITH($2, -[AC_HELP_STRING([--with-$2=ARG], - [Use ARG as the path to $2 [default=autodetect]])], -[ - if test "$HostOS" = "mingw32" - then - AC_MSG_WARN([Request to use $withval will be ignored]) - else - $1=$withval - fi -], -[ - if test "$HostOS" != "mingw32" - then - AC_PATH_PROG([$1], [$2]) - if test -z "$$1" - then - AC_MSG_ERROR([cannot find $2 in your PATH, no idea how to link]) - fi - fi -] -) -]) # FP_ARG_WITH_PATH_GNU_PROG - - -# FP_PROG_CONTEXT_DIFF -# -------------------- -# Figure out how to do context diffs. Sets the output variable ContextDiffCmd. -# -# Note: NeXTStep thinks diff'ing a file against itself is "trouble". -# -# Used by ghc, glafp-utils/ltx, and glafp-utils/runstdtest. -AC_DEFUN([FP_PROG_CONTEXT_DIFF], -[AC_CACHE_CHECK([for a working context diff], [fp_cv_context_diff], -[echo foo > conftest1 -echo foo > conftest2 -fp_cv_context_diff=no -for fp_var in '-U 1' '-u1' '-C 1' '-c1' -do - if diff $fp_var conftest1 conftest2 > /dev/null 2>&1; then - fp_cv_context_diff="diff $fp_var" - break - fi -done]) -if test x"$fp_cv_context_diff" = xno; then - AC_MSG_ERROR([cannot figure out how to do context diffs]) -fi -AC_SUBST(ContextDiffCmd, [$fp_cv_context_diff]) -])# FP_PROG_CONTEXT_DIFF - - -# FP_COMPUTE_INT(EXPRESSION, VARIABLE, INCLUDES, IF-FAILS) -# -------------------------------------------------------- -# Assign VARIABLE the value of the compile-time EXPRESSION using INCLUDES for -# compilation. Execute IF-FAILS when unable to determine the value. Works for -# cross-compilation, too. -# -# Implementation note: We are lazy and use an internal autoconf macro, but it -# is supported in autoconf versions 2.50 up to the actual 2.57, so there is -# little risk. -AC_DEFUN([FP_COMPUTE_INT], -[_AC_COMPUTE_INT([$1], [$2], [$3], [$4])[]dnl -])# FP_COMPUTE_INT - - -# FP_CHECK_ALIGNMENT(TYPE, [IGNORED], [INCLUDES = DEFAULT-INCLUDES]) -# ------------------------------------------------------------------ -# A variation of AC_CHECK_SIZEOF for computing the alignment restrictions of a -# given type. Defines ALIGNMENT_TYPE. -AC_DEFUN([FP_CHECK_ALIGNMENT], -[AS_LITERAL_IF([$1], [], - [AC_FATAL([$0: requires literal arguments])])[]dnl -AC_CHECK_TYPE([$1], [], [], [$3])[]dnl -m4_pushdef([fp_Cache], [AS_TR_SH([fp_cv_alignment_$1])])[]dnl -AC_CACHE_CHECK([alignment of $1], [fp_Cache], -[if test "$AS_TR_SH([ac_cv_type_$1])" = yes; then - FP_COMPUTE_INT([(long) (&((struct { char c; $1 ty; } *)0)->ty)], - [fp_Cache], - [AC_INCLUDES_DEFAULT([$3])], - [AC_MSG_ERROR([cannot compute alignment ($1) -See `config.log' for more details.], [77])]) -else - fp_Cache=0 -fi])[]dnl -AC_DEFINE_UNQUOTED(AS_TR_CPP(alignment_$1), $fp_Cache, [The alignment of a `$1'.])[]dnl -m4_popdef([fp_Cache])[]dnl -])# FP_CHECK_ALIGNMENT - - -# FP_LEADING_UNDERSCORE -# --------------------- -# Test for determining whether symbol names have a leading underscore. We assume -# that they _haven't_ if anything goes wrong. Sets the output variable -# LeadingUnderscore to YES or NO and defines LEADING_UNDERSCORE correspondingly. -# -# Some nlist implementations seem to try to be compatible by ignoring a leading -# underscore sometimes (eg. FreeBSD). We therefore have to work around this by -# checking for *no* leading underscore first. Sigh. --SDM -# -# Similarly on OpenBSD, but this test doesn't help. -- dons -AC_DEFUN([FP_LEADING_UNDERSCORE], -[AC_CHECK_LIB([elf], [nlist], [LIBS="-lelf $LIBS"]) -AC_CACHE_CHECK([leading underscore in symbol names], [fptools_cv_leading_underscore], [ -# Hack!: nlist() under Digital UNIX insist on there being an _, -# but symbol table listings shows none. What is going on here?!? -# -# Another hack: cygwin doesn't come with nlist.h , so we hardwire -# the underscoredness of that "platform" -case $HostPlatform in -*openbsd*) # x86 openbsd is ELF from 3.4 >, meaning no leading uscore - case $build in - i386-*2\.@<:@0-9@:>@ | i386-*3\.@<:@0-3@:>@ ) fptools_cv_leading_underscore=yes ;; - *) fptools_cv_leading_underscore=no ;; - esac ;; -alpha-dec-osf*) fptools_cv_leading_underscore=no;; -*cygwin32) fptools_cv_leading_underscore=yes;; -*mingw32) fptools_cv_leading_underscore=yes;; - - # HACK: Apple doesn't seem to provide nlist in the 64-bit-libraries -x86_64-apple-darwin*) fptools_cv_leading_underscore=yes;; - -*) AC_RUN_IFELSE([AC_LANG_SOURCE([[#ifdef HAVE_NLIST_H -#include -struct nlist xYzzY1[] = {{"xYzzY1", 0},{0}}; -struct nlist xYzzY2[] = {{"_xYzzY2", 0},{0}}; -#endif - -int main(argc, argv) -int argc; -char **argv; -{ -#ifdef HAVE_NLIST_H - if(nlist(argv[0], xYzzY1) == 0 && xYzzY1[0].n_value != 0) - exit(1); - if(nlist(argv[0], xYzzY2) == 0 && xYzzY2[0].n_value != 0) - exit(0); -#endif - exit(1); -}]])],[fptools_cv_leading_underscore=yes],[fptools_cv_leading_underscore=no],[fptools_cv_leading_underscore=no]) -;; -esac]); -AC_SUBST([LeadingUnderscore], [`echo $fptools_cv_leading_underscore | sed 'y/yesno/YESNO/'`]) -if test x"$fptools_cv_leading_underscore" = xyes; then - AC_DEFINE([LEADING_UNDERSCORE], [1], [Define to 1 if C symbols have a leading underscore added by the compiler.]) -fi])# FP_LEADING_UNDERSCORE - - -# FP_COMPARE_VERSIONS(VERSION1, TEST, VERSION2, [ACTION-IF-TRUE], [ACTION-IF-FALSE]) -# ---------------------------------------------------------------------------------- -# Compare dotted version numbers VERSION1 and VERSION2 lexicographically according -# to TEST (one of -eq, -ne, -lt, -le, -gt, or -ge). -AC_DEFUN([FP_COMPARE_VERSIONS], -[fp_version1=$1; fp_version2=$3 -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 -AS_IF([test "$fp_num1" $2 "$fp_num2"], [$4], [$5])[]dnl -])# FP_COMPARE_VERSIONS - - -dnl -dnl Check for GreenCard and version. -dnl -AC_DEFUN([FPTOOLS_GREENCARD], -[ -AC_PATH_PROG(GreenCardCmd,greencard) -AC_CACHE_CHECK([for version of greencard], fptools_cv_greencard_version, -changequote(, )dnl -[if test x"$GreenCardCmd" != x; then - fptools_cv_greencard_version="`$GreenCardCmd --version | - grep 'version' | sed -e 's/greencard. version \([^ ]*\).*/\1/g'`" -else - fptools_cv_greencard_version="" -fi -changequote([, ])dnl -]) -FP_COMPARE_VERSIONS([$fptools_cv_greencard_version],[-lt],[$1], - [AC_MSG_ERROR([greencard version $1 or later is required (found '$fptools_cv_greencard_version')])])[]dnl -GreenCardVersion=$fptools_cv_greencard_version -AC_SUBST(GreenCardVersion) -]) - -dnl -dnl Check for Happy and version. If we're building GHC, then we need -dnl at least Happy version 1.14. If there's no installed Happy, we look -dnl for a happy source tree and point the build system at that instead. -dnl -AC_DEFUN([FPTOOLS_HAPPY], -[AC_PATH_PROG(HappyCmd,happy,) -# Happy is passed to Cabal, so we need a native path -if test "x$HostPlatform" = "xi386-unknown-mingw32" && \ - test "${OSTYPE}" != "msys" && \ - test "${HappyCmd}" != "" -then - # Canonicalise to :/path/to/gcc - HappyCmd=`cygpath -m ${HappyCmd}` - AC_MSG_NOTICE([normalized happy command to $HappyCmd]) -fi - -AC_CACHE_CHECK([for version of happy], fptools_cv_happy_version, -changequote(, )dnl -[if test x"$HappyCmd" != x; then - fptools_cv_happy_version=`"$HappyCmd" -v | - grep 'Happy Version' | sed -e 's/Happy Version \([^ ]*\).*/\1/g'` ; -else - fptools_cv_happy_version=""; -fi; -changequote([, ])dnl -]) -if test ! -f compiler/parser/Parser.hs || test ! -f compiler/cmm/CmmParse.hs || test ! -f compiler/parser/ParserCore.hs -then - FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.16], - [AC_MSG_ERROR([Happy version 1.16 or later is required to compile GHC.])])[] -fi -HappyVersion=$fptools_cv_happy_version; -AC_SUBST(HappyVersion) -]) - -dnl -dnl Check for Alex and version. If we're building GHC, then we need -dnl at least Alex version 2.0.1. -dnl -AC_DEFUN([FPTOOLS_ALEX], -[ -AC_PATH_PROG(AlexCmd,alex,) -# Alex is passed to Cabal, so we need a native path -if test "x$HostPlatform" = "xi386-unknown-mingw32" && \ - test "${OSTYPE}" != "msys" && \ - test "${AlexCmd}" != "" -then - # Canonicalise to :/path/to/gcc - AlexCmd=`cygpath -m ${AlexCmd}` -fi - -AC_CACHE_CHECK([for version of alex], fptools_cv_alex_version, -changequote(, )dnl -[if test x"$AlexCmd" != x; then - fptools_cv_alex_version=`"$AlexCmd" -v | - grep 'Alex [Vv]ersion' | sed -e 's/Alex [Vv]ersion \([0-9\.]*\).*/\1/g'` ; -else - fptools_cv_alex_version=""; -fi; -changequote([, ])dnl -]) -if test ! -f compiler/cmm/CmmLex.hs || test ! -f compiler/parser/Lexer.hs -then - FP_COMPARE_VERSIONS([$fptools_cv_alex_version],[-lt],[2.1.0], - [AC_MSG_ERROR([Alex version 2.1.0 or later is required to compile GHC.])])[] -fi -AlexVersion=$fptools_cv_alex_version; -AC_SUBST(AlexVersion) -]) - - -# FP_PROG_LD_X -# ------------ -# Sets the output variable LdXFlag to -x if ld supports this flag, otherwise the -# variable's value is empty. -AC_DEFUN([FP_PROG_LD_X], -[ -AC_CACHE_CHECK([whether ld understands -x], [fp_cv_ld_x], -[echo 'foo() {}' > conftest.c -${CC-cc} -c conftest.c -if ${LdCmd} -r -x -o conftest2.o conftest.o > /dev/null 2>&1; then - fp_cv_ld_x=yes -else - fp_cv_ld_x=no -fi -rm -rf conftest*]) -if test "$fp_cv_ld_x" = yes; then - LdXFlag=-x -else - LdXFlag= -fi -AC_SUBST([LdXFlag]) -])# FP_PROG_LD_X - - -# FP_PROG_LD_IS_GNU -# ----------------- -# Sets the output variable LdIsGNULd to YES or NO, depending on whether it is -# GNU ld or not. -AC_DEFUN([FP_PROG_LD_IS_GNU], -[ -AC_CACHE_CHECK([whether ld is GNU ld], [fp_cv_gnu_ld], -[if ${LdCmd} --version 2> /dev/null | grep "GNU" > /dev/null 2>&1; then - fp_cv_gnu_ld=yes -else - fp_cv_gnu_ld=no -fi]) -AC_SUBST([LdIsGNULd], [`echo $fp_cv_gnu_ld | sed 'y/yesno/YESNO/'`]) -])# FP_PROG_LD_IS_GNU - - -# FP_PROG_AR -# ---------- -# Sets fp_prog_ar_raw to the full path of ar and fp_prog_ar to a non-Cygwin -# version of it. Exits if no ar can be found -AC_DEFUN([FP_PROG_AR], -[AC_PATH_PROG([fp_prog_ar_raw], [ar]) -if test -z "$fp_prog_ar_raw"; then - AC_MSG_ERROR([cannot find ar in your PATH, no idea how to make a library]) -fi -fp_prog_ar=$fp_prog_ar_raw -case $HostPlatform in - *mingw32) if test x${OSTYPE} != xmsys; then - fp_prog_ar="`cygpath -w ${fp_prog_ar_raw} | sed -e 's@\\\\@/@g'`" - AC_MSG_NOTICE([normalized ar command to $fp_prog_ar]) - fi - ;; -esac -])# FP_PROG_AR - - -# FP_PROG_AR_IS_GNU -# ----------------- -# Sets fp_prog_ar_is_gnu to yes or no, depending on whether it is GNU ar or not. -AC_DEFUN([FP_PROG_AR_IS_GNU], -[AC_REQUIRE([FP_PROG_AR]) -AC_CACHE_CHECK([whether $fp_prog_ar_raw is GNU ar], [fp_cv_prog_ar_is_gnu], -[if $fp_prog_ar_raw --version 2> /dev/null | grep "GNU" > /dev/null 2>&1; then - fp_cv_prog_ar_is_gnu=yes -else - fp_cv_prog_ar_is_gnu=no -fi]) -fp_prog_ar_is_gnu=$fp_cv_prog_ar_is_gnu -])# FP_PROG_AR_IS_GNU - - -# FP_PROG_AR_ARGS -# --------------- -# Sets fp_prog_ar_args to the arguments for ar and the output variable ArCmd -# to a non-Cygwin invocation of ar including these arguments. -AC_DEFUN([FP_PROG_AR_ARGS], -[AC_REQUIRE([FP_PROG_AR_IS_GNU]) -AC_CACHE_CHECK([for ar arguments], [fp_cv_prog_ar_args], -[ -# GNU ar needs special treatment: it appears to have problems with -# object files with the same name if you use the 's' modifier, but -# simple 'ar q' works fine, and doesn't need a separate ranlib. -if test $fp_prog_ar_is_gnu = yes; then - fp_cv_prog_ar_args="q" -else - touch conftest.dummy - for fp_var in clqsZ clqs cqs clq cq ; do - rm -f conftest.a - if "$fp_prog_ar_raw" $fp_var conftest.a conftest.dummy > /dev/null 2> /dev/null; then - fp_cv_prog_ar_args=$fp_var - break - fi - done - rm -f conftest* - if test -z "$fp_cv_prog_ar_args"; then - AC_MSG_ERROR([cannot figure out how to use your $fp_prog_ar_raw]) - fi -fi]) -fp_prog_ar_args=$fp_cv_prog_ar_args -AC_SUBST([ArCmd], ["$fp_prog_ar"]) -AC_SUBST([ArArgs], ["$fp_prog_ar_args"]) - -])# FP_PROG_AR_ARGS - - -# FP_PROG_AR_NEEDS_RANLIB -# ----------------------- -# Sets the output variable RANLIB to "ranlib" if it is needed and found, -# to ":" otherwise. -AC_DEFUN([FP_PROG_AR_NEEDS_RANLIB], -[AC_REQUIRE([FP_PROG_AR_IS_GNU]) -AC_REQUIRE([FP_PROG_AR_ARGS]) -AC_REQUIRE([AC_PROG_CC]) -AC_CACHE_CHECK([whether ranlib is needed], [fp_cv_prog_ar_needs_ranlib], -[if test $fp_prog_ar_is_gnu = yes; then - fp_cv_prog_ar_needs_ranlib=no -elif echo $TargetPlatform | grep "^.*-apple-darwin$" > /dev/null 2> /dev/null; then - # It's quite tedious to check for Apple's crazy timestamps in .a files, - # so we hardcode it. - fp_cv_prog_ar_needs_ranlib=yes -elif echo $fp_prog_ar_args | grep "s" > /dev/null 2> /dev/null; then - fp_cv_prog_ar_needs_ranlib=no -else - fp_cv_prog_ar_needs_ranlib=yes -fi]) -if test $fp_cv_prog_ar_needs_ranlib = yes; then - AC_PROG_RANLIB -else - RANLIB=":" - 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 -AC_DEFUN([FPTOOLS_SHEBANG_PERL], -[AC_CACHE_CHECK([if your perl works in shell scripts], fptools_cv_shebang_perl, -[echo "#!$PerlCmd"' -exit $1; -' > conftest -chmod u+x conftest -(SHELL=/bin/sh; export SHELL; ./conftest 69 > /dev/null) -if test $? -ne 69; then - fptools_cv_shebang_perl=yes -else - fptools_cv_shebang_perl=no -fi -rm -f conftest -])]) - - -# FP_HAVE_GCC -# ----------- -# 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], -[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 - AC_MSG_ERROR([gcc is required]) -fi -GccLT34= -AC_CACHE_CHECK([version of gcc], [fp_cv_gcc_version], -[if test "$fp_have_gcc" = "YES"; then - fp_cv_gcc_version="`$CC -v 2>&1 | grep 'version ' | sed -e 's/.*version [[^0-9]]*\([[0-9.]]*\).*/\1/g'`" - FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [3.0], - [AC_MSG_ERROR([Need at least gcc version 3.0 (3.4+ recommended)])]) - # See #2770: gcc 2.95 doesn't work any more, apparently. There probably - # isn't a very good reason for that, but for now just make configure - # fail. - FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [3.4], GccLT34=YES) - else - fp_cv_gcc_version="not-installed" - fi -]) -AC_SUBST([HaveGcc], [$fp_have_gcc]) -AC_SUBST([GccVersion], [$fp_cv_gcc_version]) -AC_SUBST(GccLT34) -])# FP_HAVE_GCC - -dnl Small feature test for perl version. Assumes PerlCmd -dnl contains path to perl binary. -dnl -dnl (Perl versions prior to v5.6 does not contain the string "v5"; -dnl instead they display version strings such as "version 5.005".) -dnl -AC_DEFUN([FPTOOLS_CHECK_PERL_VERSION], -[$PerlCmd -v >conftest.out 2>&1 - if grep "v5" conftest.out >/dev/null 2>&1; then - : - else - AC_MSG_ERROR([your version of perl probably won't work, try upgrading it.]) - fi -rm -fr conftest* -]) - - -# FP_CHECK_PROG(VARIABLE, PROG-TO-CHECK-FOR, -# [VALUE-IF-NOT-FOUND], [PATH], [REJECT]) -# ----------------------------------------------------- -# HACK: A small wrapper around AC_CHECK_PROG, setting VARIABLE to the full path -# of PROG-TO-CHECK-FOR when found. -AC_DEFUN([FP_CHECK_PROG], -[AC_CHECK_PROG([$1], [$2], [$as_dir/$ac_word$ac_exec_ext], [$3], [$4], [$5])][]dnl -)# FP_CHECK_PROC - - -# FP_PROG_FIND -# ------------ -# Find a non-WinDoze version of the "find" utility. -AC_DEFUN([FP_PROG_FIND], -[AC_PATH_PROGS([fp_prog_find], [gfind find], find) -echo foo > conftest.txt -$fp_prog_find conftest.txt -print > conftest.out 2>&1 -if grep '^conftest.txt$' conftest.out > /dev/null 2>&1 ; then - # OK, looks like a real "find". - case $HostPlatform in - *mingw32) - if test x${OSTYPE} != xmsys - then - fp_prog_find="`cygpath --mixed ${fp_prog_find}`" - AC_MSG_NOTICE([normalized find command to $fp_prog_find]) - fi ;; - *) ;; - esac - FindCmd="$fp_prog_find" -else - # Found a poor WinDoze version of "find", ignore it. - AC_MSG_WARN([$fp_prog_find looks like a non-*nix find, ignoring it]) - FP_CHECK_PROG([FindCmd], [find], [], [], [$fp_prog_find]) -fi -rm -f conftest.txt conftest.out -AC_SUBST([FindCmd])[]dnl -])# FP_PROG_FIND - - -# FP_PROG_SORT -# ------------ -# Find a Unix-like sort -AC_DEFUN([FP_PROG_SORT], -[AC_PATH_PROG([fp_prog_sort], [sort]) -echo conwip > conftest.txt -$fp_prog_sort -f conftest.txt > conftest.out 2>&1 -if grep 'conwip' conftest.out > /dev/null 2>&1 ; then - # The goods - SortCmd="$fp_prog_sort" -else - # Summink else..pick next one. - AC_MSG_WARN([$fp_prog_sort looks like a non-*nix sort, ignoring it]) - FP_CHECK_PROG([SortCmd], [sort], [], [], [$fp_prog_sort]) -fi -rm -f conftest.txt conftest.out -AC_SUBST([SortCmd])[]dnl -])# FP_PROG_SORT - -dnl -dnl FPTOOLS_NOCACHE_CHECK prints a message, then sets the -dnl values of the second argument to the result of running -dnl the commands given by the third. It does not cache its -dnl result, so it is suitable for checks which should be -dnl run every time. -dnl -AC_DEFUN([FPTOOLS_NOCACHE_CHECK], -[AC_MSG_CHECKING([$1]) - $3 - AC_MSG_RESULT([$][$2]) -]) - -dnl -dnl FPTOOLS_GHC_VERSION(version) -dnl FPTOOLS_GHC_VERSION(major, minor [, patchlevel]) -dnl FPTOOLS_GHC_VERSION(version, major, minor, patchlevel) -dnl -dnl Test for version of installed ghc. Uses $GHC. -dnl [original version pinched from c2hs] -dnl -AC_DEFUN([FPTOOLS_GHC_VERSION], -[FPTOOLS_NOCACHE_CHECK([version of ghc], [fptools_version_of_ghc], -["${WithGhc-ghc}" --version > conftestghc 2>&1 - cat conftestghc >&AS_MESSAGE_LOG_FD -#Useless Use Of cat award... - fptools_version_of_ghc=`cat conftestghc | sed -n -e 's/, patchlevel *\([[0-9]]\)/.\1/;s/.* version \([[0-9]][[0-9.]]*\).*/\1/p'` - rm -fr conftest* - if test "[$]fptools_version_of_ghc" = "" - then - fptools_version_of_ghc='unknown' - fi -fptools_version_of_ghc[_major]=`echo [$]fptools_version_of_ghc | sed -e 's/^\([[0-9]]\).*/\1/'` -fptools_version_of_ghc[_minor]=`echo [$]fptools_version_of_ghc | sed -e 's/^[[0-9]]\.\([[0-9]]*\).*/\1/'` -fptools_version_of_ghc[_pl]=`echo [$]fptools_version_of_ghc | sed -n -e 's/^[[0-9]]\.[[0-9]]*\.\([[0-9]]*\)/\1/p'` -# -if test "[$]fptools_version_of_ghc[_pl]" = "" -then - fptools_version_of_ghc[_all]="[$]fptools_version_of_ghc[_major].[$]fptools_version_of_ghc[_minor]" - fptools_version_of_ghc[_pl]="0" -else - fptools_version_of_ghc[_all]="[$]fptools_version_of_ghc[_major].[$]fptools_version_of_ghc[_minor].[$]fptools_version_of_ghc[_pl]" -fi -# -ifelse($#, [1], [dnl -[$1]="[$]fptools_version_of_ghc[_all]" -], $#, [2], [dnl -[$1]="[$]fptools_version_of_ghc[_major]" -[$2]="[$]fptools_version_of_ghc[_minor]" -], $#, [3], [dnl -[$1]="[$]fptools_version_of_ghc[_major]" -[$2]="[$]fptools_version_of_ghc[_minor]" -[$3]="[$]fptools_version_of_ghc[_pl]" -], $#, [4], [dnl -[$1]="[$]fptools_version_of_ghc[_all]" -[$2]="[$]fptools_version_of_ghc[_major]" -[$3]="[$]fptools_version_of_ghc[_minor]" -[$4]="[$]fptools_version_of_ghc[_pl]" -]) -]) -])dnl - - -# FP_CHECK_FUNC(FUNCTION, PROLOGUE, BODY, [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND]) -# --------------------------------------------------------------------------------- -# A variant of AC_CHECK_FUNCS, limited to a single FUNCTION, but with the -# additional flexibility of specifying the PROLOGUE and BODY. -AC_DEFUN([FP_CHECK_FUNC], -[AS_VAR_PUSHDEF([fp_func], [fp_cv_func_$1])dnl -AC_CACHE_CHECK([for $1], fp_func, -[AC_LINK_IFELSE([AC_LANG_PROGRAM([$2], [$3])], - [AS_VAR_SET(fp_func, yes)], - [AS_VAR_SET(fp_func, no)])]) -AS_IF([test AS_VAR_GET(fp_func) = yes], - [AC_DEFINE(AS_TR_CPP(HAVE_$1), [1], - [Define to 1 if you have the `]$1[' function.]) $4], - [$5])dnl -AS_VAR_POPDEF([fp_func])dnl -])# FP_CHECK_FUNC - - -# FP_GEN_DOCBOOK_XML -# ------------------ -# Generates a DocBook XML V4.2 document in conftest.xml. -# -# It took a lot of experimentation to find a document that will cause -# xsltproc to fail with an error code when the relevant -# stylesheets/DTDs are not found. I couldn't make xsltproc fail with -# a single-file document, it seems a multi-file document is needed. -# -- SDM 2009-06-03 -# -AC_DEFUN([FP_GEN_DOCBOOK_XML], -[rm -f conftest.xml conftest-book.xml -cat > conftest.xml << EOF - - -]]> - -&conftest-book; - -EOF -cat >conftest-book.xml << EOF - - A DocBook “Test Document” - - A Chapter Title - This is a paragraph, referencing . - - - Another Chapter Title - This is another paragraph, referencing . - -EOF -]) # FP_GEN_DOCBOOK_XML - - -# FP_PROG_DBLATEX -# ---------------- -# Sets the output variable DblatexCmd to the full path of dblatex, -# which we use for building PDF and PS docs. -# DblatexCmd is empty if dblatex could not be found. -AC_DEFUN([FP_PROG_DBLATEX], -[AC_PATH_PROG([DblatexCmd], [dblatex]) -if test -z "$DblatexCmd"; then - AC_MSG_WARN([cannot find dblatex in your PATH, you will not be able to build the PDF and PS documentation]) -fi -])# FP_PROG_DBLATEX - - -# FP_PROG_XSLTPROC -# ---------------- -# Sets the output variable XsltprocCmd to the full path of the XSLT processor -# xsltproc. XsltprocCmd is empty if xsltproc could not be found. -AC_DEFUN([FP_PROG_XSLTPROC], -[AC_PATH_PROG([XsltprocCmd], [xsltproc]) -if test -z "$XsltprocCmd"; then - AC_MSG_WARN([cannot find xsltproc in your PATH, you will not be able to build the HTML documentation]) -fi -])# FP_PROG_XSLTPROC - - -# FP_DOCBOOK_XSL -# ---------------------------- -# Check that we can process a DocBook XML document to HTML using xsltproc. -AC_DEFUN([FP_DOCBOOK_XSL], -[AC_REQUIRE([FP_PROG_XSLTPROC])dnl -if test -n "$XsltprocCmd"; then - AC_CACHE_CHECK([for DocBook XSL stylesheet], fp_cv_dir_docbook_xsl, - [FP_GEN_DOCBOOK_XML - fp_cv_dir_docbook_xsl=no - if $XsltprocCmd --nonet http://docbook.sourceforge.net/release/xsl/current/html/chunk.xsl conftest.xml > /dev/null 2>&1; then - fp_cv_dir_docbook_xsl=yes - fi - rm -rf conftest*]) -fi -if test x"$fp_cv_dir_docbook_xsl" = xno; then - AC_MSG_WARN([cannot find DocBook XSL stylesheets, you will not be able to build the documentation]) - HAVE_DOCBOOK_XSL=NO -else - HAVE_DOCBOOK_XSL=YES -fi -AC_SUBST([HAVE_DOCBOOK_XSL]) -])# FP_DOCBOOK_XSL - - -# FP_PROG_XMLLINT -# ---------------- -# Sets the output variable XmllintCmd to the full path of the XSLT processor -# xmllint. XmllintCmd is empty if xmllint could not be found. -AC_DEFUN([FP_PROG_XMLLINT], -[AC_PATH_PROG([XmllintCmd], [xmllint]) -if test -z "$XmllintCmd"; then - AC_MSG_WARN([cannot find xmllint in your PATH, you will not be able to validate your documentation]) -fi -])# FP_PROG_XMLLINT - - -# FP_CHECK_DOCBOOK_DTD -# -------------------- -AC_DEFUN([FP_CHECK_DOCBOOK_DTD], -[AC_REQUIRE([FP_PROG_XMLLINT])dnl -if test -n "$XmllintCmd"; then - AC_MSG_CHECKING([for DocBook DTD]) - FP_GEN_DOCBOOK_XML - if $XmllintCmd --nonet --valid --noout conftest.xml ; then - AC_MSG_RESULT([ok]) - else - AC_MSG_RESULT([failed]) - AC_MSG_WARN([cannot find a DTD for DocBook XML V4.2, you will not be able to validate your documentation]) - AC_MSG_WARN([check your XML_CATALOG_FILES environment variable and/or /etc/xml/catalog]) - fi - rm -rf conftest* -fi -])# FP_CHECK_DOCBOOK_DTD - - -# FP_GEN_FO -# ------------------ -# Generates a formatting objects document in conftest.fo. -AC_DEFUN([FP_GEN_FO], -[rm -f conftest.fo -cat > conftest.fo << EOF - - - - - - - - - - - Test! - - - - -EOF -]) # FP_GEN_FO - - -# FP_PROG_FOP -# ----------- -# Set the output variable 'FopCmd' to the first working 'fop' in the current -# 'PATH'. Note that /usr/bin/fop is broken in SuSE 9.1 (unpatched), so try -# /usr/share/fop/fop.sh in that case (or no 'fop'), too. -AC_DEFUN([FP_PROG_FOP], -[AC_PATH_PROGS([FopCmd1], [fop fop.sh]) -if test -n "$FopCmd1"; then - AC_CACHE_CHECK([for $FopCmd1 usability], [fp_cv_fop_usability], - [FP_GEN_FO - if "$FopCmd1" -fo conftest.fo -ps conftest.ps > /dev/null 2>&1; then - fp_cv_fop_usability=yes - else - fp_cv_fop_usability=no - fi - rm -rf conftest*]) - if test x"$fp_cv_fop_usability" = xyes; then - FopCmd=$FopCmd1 - fi -fi -if test -z "$FopCmd"; then - AC_PATH_PROGS([FopCmd2], [fop.sh], , [/usr/share/fop]) - FopCmd=$FopCmd2 -fi -AC_SUBST([FopCmd]) -])# 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 -# WithGhc. If the latter is unset or no matching ghc-pkg can be found, try to -# find a plain ghc-pkg. Sets the output variable GhcPkgCmd. -AC_DEFUN([FP_PROG_GHC_PKG], -[AC_CACHE_CHECK([for ghc-pkg matching $WithGhc], fp_cv_matching_ghc_pkg, -[fp_ghc_pkg_guess=`echo $WithGhc | sed 's,ghc\(@<:@^/\\@:>@*\)$,ghc-pkg\1,'` -if "$fp_ghc_pkg_guess" -l > /dev/null 2>&1; then - fp_cv_matching_ghc_pkg=$fp_ghc_pkg_guess -elif "$fp_ghc_pkg_guess" list > /dev/null 2>&1; then - # from 6.10, ghc-pkg doesn't support the old -l syntax any more - fp_cv_matching_ghc_pkg=$fp_ghc_pkg_guess -else - fp_cv_matching_ghc_pkg=no -fi]) -if test x"$fp_cv_matching_ghc_pkg" = xno; then - AC_PATH_PROG([GhcPkgCmd], [ghc-pkg]) -else - GhcPkgCmd=$fp_cv_matching_ghc_pkg -fi])# FP_PROG_GHC_PKG - - -# FP_GCC_EXTRA_FLAGS -# ------------------ -# 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_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) -]) - - -# FP_SETUP_PROJECT_VERSION -# --------------------- -AC_DEFUN([FP_SETUP_PROJECT_VERSION], -[ -if test "$RELEASE" = "NO"; then - AC_MSG_CHECKING([for GHC version date]) - if test -f VERSION_DATE; then - PACKAGE_VERSION=${PACKAGE_VERSION}.`cat VERSION_DATE` - 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/"` - 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]) - fi - PACKAGE_VERSION=${PACKAGE_VERSION}.$ver_date - AC_MSG_RESULT(inferred $PACKAGE_VERSION) - elif test -d _darcs; then - # TODO: Remove this branch after conversion to Git - changequote(, )dnl - 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 - changequote([, ])dnl - AC_MSG_ERROR([failed to detect version date: check that darcs is in your path]) - fi - PACKAGE_VERSION=${PACKAGE_VERSION}.$ver_date - AC_MSG_RESULT(inferred $PACKAGE_VERSION) - elif test -f VERSION; then - PACKAGE_VERSION=`cat VERSION` - AC_MSG_RESULT(given $PACKAGE_VERSION) - else - AC_MSG_WARN([cannot determine snapshot version: no .git or _darcs directory and no VERSION file]) - fi -fi - -# Some renamings -AC_SUBST([ProjectName], [$PACKAGE_NAME]) -AC_SUBST([ProjectVersion], [$PACKAGE_VERSION]) - -# Split PACKAGE_VERSION into (possibly empty) parts -VERSION_MAJOR=`echo $PACKAGE_VERSION | sed 's/^\(@<:@^.@:>@*\)\(\.\{0,1\}\(.*\)\)$/\1'/` -VERSION_TMP=`echo $PACKAGE_VERSION | sed 's/^\(@<:@^.@:>@*\)\(\.\{0,1\}\(.*\)\)$/\3'/` -VERSION_MINOR=`echo $VERSION_TMP | sed 's/^\(@<:@^.@:>@*\)\(\.\{0,1\}\(.*\)\)$/\1'/` -ProjectPatchLevel=`echo $VERSION_TMP | sed 's/^\(@<:@^.@:>@*\)\(\.\{0,1\}\(.*\)\)$/\3'/` - -# Calculate project version as an integer, using 2 digits for minor version -case $VERSION_MINOR in - ?) ProjectVersionInt=${VERSION_MAJOR}0${VERSION_MINOR} ;; - ??) ProjectVersionInt=${VERSION_MAJOR}${VERSION_MINOR} ;; - *) AC_MSG_ERROR([bad minor version in $PACKAGE_VERSION]) ;; -esac -AC_SUBST([ProjectVersionInt]) - -# The project patchlevel is zero unless stated otherwise -test -z "$ProjectPatchLevel" && ProjectPatchLevel=0 - -# Remove dots from the patch level; this allows us to have versions like 6.4.1.20050508 -ProjectPatchLevel=`echo $ProjectPatchLevel | sed 's/\.//'` - -AC_SUBST([ProjectPatchLevel]) -])# FP_SETUP_PROJECT_VERSION - - -# Check for a working timer_create(). We need a pretty detailed check -# here, because there exist partially-working implementations of -# timer_create() in certain versions of Linux (see bug #1933). -# -AC_DEFUN([FP_CHECK_TIMER_CREATE], - [AC_CACHE_CHECK([for a working timer_create(CLOCK_REALTIME)], - [fptools_cv_timer_create_works], - [AC_TRY_RUN([ -#include -#ifdef HAVE_STDLIB_H -#include -#endif -#ifdef HAVE_TIME_H -#include -#endif -#ifdef HAVE_SIGNAL_H -#include -#endif -#ifdef HAVE_UNISTD_H -#include -#endif - -static volatile int tock = 0; -static void handler(int i) -{ - tock = 1; -} - -static void timeout(int i) -{ - // timer_settime() has been known to hang, so just in case - // we install a 1-second timeout (see #2257) - exit(99); -} - -int main(int argc, char *argv[]) -{ - - struct sigevent ev; - timer_t timer; - struct itimerspec it; - struct sigaction action; - int m,n,count = 0; - - ev.sigev_notify = SIGEV_SIGNAL; - ev.sigev_signo = SIGVTALRM; - - action.sa_handler = handler; - action.sa_flags = 0; - sigemptyset(&action.sa_mask); - if (sigaction(SIGVTALRM, &action, NULL) == -1) { - fprintf(stderr,"SIGVTALRM problem\n"); - exit(3); - } - - action.sa_handler = timeout; - action.sa_flags = 0; - sigemptyset(&action.sa_mask); - if (sigaction(SIGALRM, &action, NULL) == -1) { - fprintf(stderr,"SIGALRM problem\n"); - exit(3); - } - alarm(1); - - if (timer_create(CLOCK_PROCESS_CPUTIME_ID, &ev, &timer) != 0) { - fprintf(stderr,"No CLOCK_PROCESS_CPUTIME_ID timer\n"); - exit(1); - } - - it.it_value.tv_sec = 0; - it.it_value.tv_nsec = 1; - it.it_interval = it.it_value; - if (timer_settime(timer, 0, &it, NULL) != 0) { - fprintf(stderr,"settime problem\n"); - exit(4); - } - - tock = 0; - - for(n = 3; n < 20000; n++){ - for(m = 2; m <= n/2; m++){ - if (!(n%m)) count++; - if (tock) goto out; - } - } -out: - - if (!tock) { - fprintf(stderr,"no CLOCK_PROCESS_CPUTIME_ID signal\n"); - exit(5); - } - - timer_delete(timer); - - if (timer_create(CLOCK_REALTIME, &ev, &timer) != 0) { - fprintf(stderr,"No CLOCK_REALTIME timer\n"); - exit(2); - } - - it.it_value.tv_sec = 0; - it.it_value.tv_nsec = 1000000; - it.it_interval = it.it_value; - if (timer_settime(timer, 0, &it, NULL) != 0) { - fprintf(stderr,"settime problem\n"); - exit(4); - } - - tock = 0; - - usleep(3000); - - if (!tock) { - fprintf(stderr,"no CLOCK_REALTIME signal\n"); - exit(5); - } - - timer_delete(timer); - - exit(0); -} - ], - [fptools_cv_timer_create_works=yes], - [fptools_cv_timer_create_works=no]) - ]) -case $fptools_cv_timer_create_works in - yes) AC_DEFINE([USE_TIMER_CREATE], 1, - [Define to 1 if we can use timer_create(CLOCK_PROCESS_CPUTIME_ID,...)]);; -esac -]) - -# FP_ARG_GMP -# ------------- -AC_DEFUN([FP_ARG_GMP], -[ -AC_ARG_WITH([gmp-includes], - [AC_HELP_STRING([--with-gmp-includes], - [directory containing gmp.h])], - [gmp_includes=$withval], - [gmp_includes=NONE]) - -AC_ARG_WITH([gmp-libraries], - [AC_HELP_STRING([--with-gmp-libraries], - [directory containing gmp library])], - [gmp_libraries=$withval], - [gmp_libraries=NONE]) -])# FP_ARG_GMP - -AC_DEFUN([CHECK_GMP], -[AC_REQUIRE([AC_PROG_CPP]) -AC_REQUIRE([AC_PROG_CC]) -]) - -# FP_CHECK_MACOSX_DEPLOYMENT_TARGET -# --------------------------------- -AC_DEFUN([FP_CHECK_MACOSX_DEPLOYMENT_TARGET], -[ -if test "x$TargetOS_CPP-$TargetVendor_CPP" = "xdarwin-apple"; then - AC_MSG_CHECKING([Mac OS X deployment target]) - case $FP_MACOSX_DEPLOYMENT_TARGET in - none) ;; - 10.4) MACOSX_DEPLOYMENT_VERSION=10.4 - MACOSX_DEPLOYMENT_SDK=/Developer/SDKs/MacOSX10.4u.sdk - ;; - 10.4u) MACOSX_DEPLOYMENT_VERSION=10.4 - MACOSX_DEPLOYMENT_SDK=/Developer/SDKs/MacOSX10.4u.sdk - ;; - *) MACOSX_DEPLOYMENT_VERSION=$FP_MACOSX_DEPLOYMENT_TARGET - MACOSX_DEPLOYMENT_SDK=/Developer/SDKs/MacOSX${FP_MACOSX_DEPLOYMENT_TARGET}.sdk - ;; - esac - if test "x$FP_MACOSX_DEPLOYMENT_TARGET" = "xnone"; then - AC_MSG_RESULT(none) - else - if test ! -d $MACOSX_DEPLOYMENT_SDK; then - AC_MSG_ERROR([Unknown deployment target $FP_MACOSX_DEPLOYMENT_TARGET]) - fi - AC_MSG_RESULT([${MACOSX_DEPLOYMENT_VERSION} (${MACOSX_DEPLOYMENT_SDK})]) - fi -fi -]) - -# -------------------------------------------------------------- -# Calculate absolute path to build tree -# -------------------------------------------------------------- - -AC_DEFUN([FP_FIND_ROOT],[ -AC_MSG_CHECKING(for path to top of build tree) - -dnl This would be -dnl make -C utils/ghc-pwd clean && make -C utils/ghc-pwd -dnl except we don't want to have to know what make is called. Sigh. -if test ! -f utils/ghc-pwd/ghc-pwd && test ! -f utils/ghc-pwd/ghc-pwd.exe; then - cd utils/ghc-pwd - rm -f *.o - rm -f *.hi - rm -f ghc-pwd - rm -f ghc-pwd.exe - "$WithGhc" -v0 --make ghc-pwd -o ghc-pwd - cd ../.. -fi - -hardtop=`utils/ghc-pwd/ghc-pwd` - -if ! test -d "$hardtop"; then - AC_MSG_ERROR([cannot determine current directory]) -fi - -dnl Remove common automounter nonsense -dnl -hardtop=`echo $hardtop | sed 's|^/tmp_mnt.*\(/local/.*\)$|\1|' | sed 's|^/tmp_mnt/|/|'` - -AC_SUBST(hardtop) - -AC_MSG_RESULT(${hardtop}) - -# We don't support building in directories with spaces. -case "$hardtop" in - *' '*) AC_MSG_ERROR([ - The build system does not support building in a directory containing - space characters. Suggestion: move the build tree somewhere else.]) - ;; -esac -]) - -# LocalWords: fi diff -ruN ghc-6.12.1/ANNOUNCE ghc-6.13-20091231/ANNOUNCE --- ghc-6.12.1/ANNOUNCE 2009-12-10 10:11:33.000000000 -0800 +++ ghc-6.13-20091231/ANNOUNCE 1969-12-31 16:00:00.000000000 -0800 @@ -1,164 +0,0 @@ - - ============================================================== - The (Interactive) Glasgow Haskell Compiler -- version 6.12.1 - ============================================================== - -The GHC Team is pleased to announce a new major release of GHC. There -have been a number of significant changes since the last major release, -including: - -* Considerably improved support for parallel execution. GHC 6.10 would - execute parallel Haskell programs, but performance was often not very - good. Simon Marlow has done lots of performance tuning in 6.12, - removing many of the accidental (and largely invisible) gotchas that - made parallel programs run slowly. - -* As part of this parallel-performance tuning, Satnam Singh and Simon - Marlow have developed ThreadScope, a GUI that lets you see what is - going on inside your parallel program. It's a huge step forward from - "It takes 4 seconds with 1 processor, and 3 seconds with 8 processors; - now what?". ThreadScope will be released separately from GHC, but at - more or less the same time as GHC 6.12. - -* Dynamic linking is now supported on Linux, and support for other - platforms will follow. Thanks for this most recently go to the - Industrial Haskell Group who pushed it into a fully-working state; - dynamic linking is the culmination of the work of several people over - recent years. One effect of dynamic linking is that binaries shrink - dramatically, because the run-time system and libraries are shared. - Perhaps more importantly, it is possible to make dynamic plugins from - Haskell code that can be used from other applications. - -* The I/O libraries are now Unicode-aware, so your Haskell programs - should now handle text files containing non-ascii characters, without - special effort. - -* The package system has been made more robust, by associating each - installed package with a unique identifier based on its exposed ABI. - Now, cases where the user re-installs a package without recompiling - packages that depend on it will be detected, and the packages with - broken dependencies will be disabled. Previously, this would lead to - obscure compilation errors, or worse, segfaulting programs. - - This change involved a lot of internal restructuring, but it paves the - way for future improvements to the way packages are handled. For - instance, in the future we expect to track profiled packages - independently of non-profiled ones, and we hope to make it possible to - upgrade a package in an ABI-compatible way, without recompiling the - packages that depend on it. This latter facility will be especially - important as we move towards using more shared libraries. - -* There are a variety of small language changes, including - * Some improvements to data types: record punning, declaring - constructors with class constraints, GADT syntax for type families - etc. - * You can omit the "$" in a top-level Template Haskell splice, which - makes the TH call look more like an ordinary top-level declaration - with a new keyword. - * We're are deprecating mdo for recursive do-notation, in favour of - the more expressive rec statement. - * We've concluded that the implementation of impredicative polymorphism - is unsustainably complicated, so we are re-trenching. It'll be - deprecated in 6.12 (but will still work), and will be either removed - or replaced with something simpler in 6.14. - - -The full release notes are here: - - http://haskell.org/ghc/docs/6.12.1/html/users_guide/release-6-12-1.html - -How to get it -~~~~~~~~~~~~~ - -The easy way is to go to the web page, which should be self-explanatory: - - http://www.haskell.org/ghc/ - -We supply binary builds in the native package format for many -platforms, and the source distribution is available from the same -place. - -Packages will appear as they are built - if the package for your -system isn't available yet, please try again later. - - -Background -~~~~~~~~~~ - -Haskell is a standard lazy functional programming language; the -current language version is Haskell 98, agreed in December 1998 and -revised December 2002. - -GHC is a state-of-the-art programming suite for Haskell. Included is -an optimising compiler generating good code for a variety of -platforms, together with an interactive system for convenient, quick -development. The distribution includes space and time profiling -facilities, a large collection of libraries, and support for various -language extensions, including concurrency, exceptions, and foreign -language interfaces (C, whatever). GHC is distributed under a -BSD-style open source license. - -A wide variety of Haskell related resources (tutorials, libraries, -specifications, documentation, compilers, interpreters, references, -contact information, links to research groups) are available from the -Haskell home page (see below). - - -On-line GHC-related resources -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Relevant URLs on the World-Wide Web: - -GHC home page http://www.haskell.org/ghc/ -GHC developers' home page http://hackage.haskell.org/trac/ghc/ -Haskell home page http://www.haskell.org/ - - -Supported Platforms -~~~~~~~~~~~~~~~~~~~ - -The list of platforms we support, and the people responsible for them, -is here: - - http://hackage.haskell.org/trac/ghc/wiki/Contributors - -Ports to other platforms are possible with varying degrees of -difficulty. The Building Guide describes how to go about porting to a -new platform: - - http://hackage.haskell.org/trac/ghc/wiki/Building - - -Developers -~~~~~~~~~~ - -We welcome new contributors. Instructions on accessing our source -code repository, and getting started with hacking on GHC, are -available from the GHC's developer's site run by Trac: - - http://hackage.haskell.org/trac/ghc/ - - -Mailing lists -~~~~~~~~~~~~~ - -We run mailing lists for GHC users and bug reports; to subscribe, use -the web interfaces at - - http://www.haskell.org/mailman/listinfo/glasgow-haskell-users - http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs - -There are several other haskell and ghc-related mailing lists on -www.haskell.org; for the full list, see - - http://www.haskell.org/mailman/listinfo/ - -Some GHC developers hang out on #haskell on IRC, too: - - http://www.haskell.org/haskellwiki/IRC_channel - -Please report bugs using our bug tracking system. Instructions on -reporting bugs can be found here: - - http://www.haskell.org/ghc/reportabug - diff -ruN ghc-6.12.1/bindisttest/expected_output ghc-6.13-20091231/bindisttest/expected_output --- ghc-6.12.1/bindisttest/expected_output 2009-12-10 10:11:31.000000000 -0800 +++ ghc-6.13-20091231/bindisttest/expected_output 1969-12-31 16:00:00.000000000 -0800 @@ -1 +0,0 @@ -Hello world! \ No newline at end of file diff -ruN ghc-6.12.1/bindisttest/HelloWorld.lhs ghc-6.13-20091231/bindisttest/HelloWorld.lhs --- ghc-6.12.1/bindisttest/HelloWorld.lhs 2009-12-10 10:11:31.000000000 -0800 +++ ghc-6.13-20091231/bindisttest/HelloWorld.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,8 +0,0 @@ - -\begin{code} -module Main (main) where - -main :: IO () -main = putStr "Hello world!" -\end{code} - diff -ruN ghc-6.12.1/bindisttest/Makefile ghc-6.13-20091231/bindisttest/Makefile --- ghc-6.12.1/bindisttest/Makefile 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/bindisttest/Makefile 1969-12-31 16:00:00.000000000 -0800 @@ -1,57 +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 -# -# ----------------------------------------------------------------------------- - -.PHONY: default_target - -default_target: all - -# Ideally we'd just include something to give us variables -# for paths and arguments to tools etc, and those set in mk/build.mk. -TOP=.. -include $(TOP)/mk/config.mk - -ifeq "$(TEST_PREP)" "YES" -BIN_DIST_TEST_TAR_BZ2 = ../$(BIN_DIST_PREP_TAR_BZ2) -else -BIN_DIST_TEST_TAR_BZ2 = ../$(BIN_DIST_TAR_BZ2) -endif - -all: - $(RM) -rf $(BIN_DIST_INST_SUBDIR) - $(RM) -rf a/b/c/* - $(RM) HelloWorld HelloWorld.o HelloWorld.hi output -# We use the a/b/c subdirectory as configure looks for install-sh in -# . .. ../.. and we don't want it to find the build system's install-sh. -# --force-local makes tar not think that c:/foo refers to a remote file - cd a/b/c/ && $(TAR) --force-local -jxf ../../../$(BIN_DIST_TEST_TAR_BZ2) -ifeq "$(Windows)" "YES" - mv a/b/c/$(BIN_DIST_NAME) $(BIN_DIST_INST_DIR) -else - cd a/b/c/$(BIN_DIST_NAME) && ./configure --prefix=$(BIN_DIST_INST_DIR) - cd a/b/c/$(BIN_DIST_NAME) && make install -endif - $(BIN_DIST_INST_DIR)/bin/runghc HelloWorld > output - $(CONTEXT_DIFF) output expected_output - $(BIN_DIST_INST_DIR)/bin/ghc --make HelloWorld - ./HelloWorld > output - $(CONTEXT_DIFF) output expected_output - $(BIN_DIST_INST_DIR)/bin/ghc-pkg check - -clean distclean: - $(RM) -rf $(BIN_DIST_INST_SUBDIR) - $(RM) -rf a/b/c/* - $(RM) HelloWorld HelloWorld.o HelloWorld.hi output - -# Ignore a load of other standard targets -install install-docs doc: - @: - diff -ruN ghc-6.12.1/boot ghc-6.13-20091231/boot --- ghc-6.12.1/boot 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/boot 1969-12-31 16:00:00.000000000 -0800 @@ -1,39 +0,0 @@ -#! /bin/sh -set -e - -# Create libraries/*/{ghc.mk,GNUmakefile} -sh boot-pkgs - -# Check that we have all boot packages. -for dir in `grep "^[^# ][^ ]* *[^ ][^ ]* *[^ ][^ ]*$" packages | sed "s/ .*//"` -do - # 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 test ! -f $dir/LICENSE - then - echo "Error: $dir/LICENSE doesn't exist." >&2 - echo "Maybe you haven't done './darcs-all get'?" >&2 - exit 1 - fi -done - -# autoreconf everything that needs it. -for dir in . libraries/* -do - if test -f $dir/configure.ac - then - echo "Booting $dir" - ( cd $dir && autoreconf ) - fi -done - -# Alas, darcs doesn't handle file permissions, so fix a few of them. -for f in boot darcs-all push-all validate -do - if test -f $f - then - chmod +x $f - fi -done diff -ruN ghc-6.12.1/boot-pkgs ghc-6.13-20091231/boot-pkgs --- ghc-6.12.1/boot-pkgs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/boot-pkgs 1969-12-31 16:00:00.000000000 -0800 @@ -1,66 +0,0 @@ -#! /bin/sh -set -e - -libraries= - -tarred=`ls -1 libraries/tarballs | sed "s/-[0-9.]*\(-snapshot\)\{0,1\}.tar.gz//"` - -for p in $tarred -do - libraries="$libraries libraries/$p" - if [ -d "libraries/$p/_darcs" ] - then - echo Ignoring libraries/$p as it looks like a darcs checkout - else - tarball=libraries/tarballs/$p-*.tar.gz - stamp="libraries/stamp/$p" - if [ ! -d "libraries/$p" ] || - [ ! -f "$stamp" ] || - [ "libraries/stamp/$p" -ot $tarball ] - then - rm -rf "libraries/$p" - mkdir "libraries/$p" - ( - cd "libraries/$p" - tar -zxf ../../$tarball - mv */* . - ) - touch "$stamp" - fi - fi -done - -for f in libraries/*; do - pkgs=$f/ghc-packages - if test -f $pkgs; then - for p in `cat $pkgs`; do - libraries="$libraries $f/$p" - done - else - libraries="$libraries $f" - fi -done - -for f in $libraries; do - dir=`basename $f` - cabals=`echo $f/*.cabal` - if test -f $cabals; then - echo "Creating $f/ghc.mk" - rm -f $f/ghc.mk - pkg=`echo "$cabals" | sed -e 's#.*/##' -e 's#\.cabal$##'` - if test -f $f/ghc-stage; then - stage=`cat $f/ghc-stage` - else - stage=1 - fi - top=`echo $f | sed 's#[^/][^/]*#..#g'` - echo "${f}_PACKAGE = ${pkg}" >> $f/ghc.mk - echo "${f}_dist-install_GROUP = libraries" >> $f/ghc.mk - echo "\$(eval \$(call build-package,${f},dist-install,${stage}))" >> $f/ghc.mk - rm -f $f/GNUmakefile - echo "Creating $f/GNUmakefile" - echo "dir = ${f}" >> $f/GNUmakefile - echo "TOP = ${top}" >> $f/GNUmakefile - echo "include \$(TOP)/mk/sub-makefile.mk" >> $f/GNUmakefile - fi -done diff -ruN ghc-6.12.1/compiler/basicTypes/BasicTypes.lhs ghc-6.13-20091231/compiler/basicTypes/BasicTypes.lhs --- ghc-6.12.1/compiler/basicTypes/BasicTypes.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/BasicTypes.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,690 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998 -% -\section[BasicTypes]{Miscellanous types} - -This module defines a miscellaneously collection of very simple -types that - -\begin{itemize} -\item have no other obvious home -\item don't depend on any other complicated types -\item are used in more than one "part" of the compiler -\end{itemize} - -\begin{code} -module BasicTypes( - Version, bumpVersion, initialVersion, - - Arity, - - FunctionOrData(..), - - WarningTxt(..), - - Fixity(..), FixityDirection(..), - defaultFixity, maxPrecedence, - negateFixity, funTyFixity, - compareFixity, - - IPName(..), ipNameName, mapIPName, - - RecFlag(..), isRec, isNonRec, boolToRecFlag, - - RuleName, - - TopLevelFlag(..), isTopLevel, isNotTopLevel, - - OverlapFlag(..), - - Boxity(..), isBoxed, - - TupCon(..), tupleParens, - - OccInfo(..), seqOccInfo, isFragileOcc, isOneOcc, - isDeadOcc, isLoopBreaker, isNonRuleLoopBreaker, isNoOcc, - - InsideLam, insideLam, notInsideLam, - OneBranch, oneBranch, notOneBranch, - InterestingCxt, - - EP(..), - - StrictnessMark(..), isMarkedUnboxed, isMarkedStrict, - - CompilerPhase, - Activation(..), isActive, isNeverActive, isAlwaysActive, - RuleMatchInfo(..), isConLike, isFunLike, - InlinePragma(..), defaultInlinePragma, isDefaultInlinePragma, - inlinePragmaActivation, inlinePragmaRuleMatchInfo, - setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, - InlineSpec(..), defaultInlineSpec, alwaysInlineSpec, neverInlineSpec, - - SuccessFlag(..), succeeded, failed, successIf - ) where - -import FastString -import Outputable -\end{code} - -%************************************************************************ -%* * -\subsection[Arity]{Arity} -%* * -%************************************************************************ - -\begin{code} -type Arity = Int -\end{code} - -%************************************************************************ -%* * -\subsection[FunctionOrData]{FunctionOrData} -%* * -%************************************************************************ - -\begin{code} -data FunctionOrData = IsFunction | IsData - deriving (Eq, Ord) - -instance Outputable FunctionOrData where - ppr IsFunction = text "(function)" - ppr IsData = text "(data)" -\end{code} - - -%************************************************************************ -%* * -\subsection[Version]{Module and identifier version numbers} -%* * -%************************************************************************ - -\begin{code} -type Version = Int - -bumpVersion :: Version -> Version -bumpVersion v = v+1 - -initialVersion :: Version -initialVersion = 1 -\end{code} - -%************************************************************************ -%* * - Deprecations -%* * -%************************************************************************ - - -\begin{code} --- reason/explanation from a WARNING or DEPRECATED pragma -data WarningTxt = WarningTxt [FastString] - | DeprecatedTxt [FastString] - deriving Eq - -instance Outputable WarningTxt where - ppr (WarningTxt ws) = doubleQuotes (vcat (map ftext ws)) - ppr (DeprecatedTxt ds) = text "Deprecated:" <+> - doubleQuotes (vcat (map ftext ds)) -\end{code} - -%************************************************************************ -%* * -\subsection{Implicit parameter identity} -%* * -%************************************************************************ - -The @IPName@ type is here because it is used in TypeRep (i.e. very -early in the hierarchy), but also in HsSyn. - -\begin{code} -newtype IPName name = IPName name -- ?x - deriving( Eq, Ord ) -- Ord is used in the IP name cache finite map - -- (used in HscTypes.OrigIParamCache) - -ipNameName :: IPName name -> name -ipNameName (IPName n) = n - -mapIPName :: (a->b) -> IPName a -> IPName b -mapIPName f (IPName n) = IPName (f n) - -instance Outputable name => Outputable (IPName name) where - ppr (IPName n) = char '?' <> ppr n -- Ordinary implicit parameters -\end{code} - -%************************************************************************ -%* * - Rules -%* * -%************************************************************************ - -\begin{code} -type RuleName = FastString -\end{code} - -%************************************************************************ -%* * -\subsection[Fixity]{Fixity info} -%* * -%************************************************************************ - -\begin{code} ------------------------- -data Fixity = Fixity Int FixityDirection - -instance Outputable Fixity where - ppr (Fixity prec dir) = hcat [ppr dir, space, int prec] - -instance Eq Fixity where -- Used to determine if two fixities conflict - (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2 - ------------------------- -data FixityDirection = InfixL | InfixR | InfixN - deriving(Eq) - -instance Outputable FixityDirection where - ppr InfixL = ptext (sLit "infixl") - ppr InfixR = ptext (sLit "infixr") - ppr InfixN = ptext (sLit "infix") - ------------------------- -maxPrecedence :: Int -maxPrecedence = 9 -defaultFixity :: Fixity -defaultFixity = Fixity maxPrecedence InfixL - -negateFixity, funTyFixity :: Fixity --- Wired-in fixities -negateFixity = Fixity 6 InfixL -- Fixity of unary negate -funTyFixity = Fixity 0 InfixR -- Fixity of '->' -\end{code} - -Consider - -\begin{verbatim} - a `op1` b `op2` c -\end{verbatim} -@(compareFixity op1 op2)@ tells which way to arrange appication, or -whether there's an error. - -\begin{code} -compareFixity :: Fixity -> Fixity - -> (Bool, -- Error please - Bool) -- Associate to the right: a op1 (b op2 c) -compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2) - = case prec1 `compare` prec2 of - GT -> left - LT -> right - EQ -> case (dir1, dir2) of - (InfixR, InfixR) -> right - (InfixL, InfixL) -> left - _ -> error_please - where - right = (False, True) - left = (False, False) - error_please = (True, False) -\end{code} - - -%************************************************************************ -%* * -\subsection[Top-level/local]{Top-level/not-top level flag} -%* * -%************************************************************************ - -\begin{code} -data TopLevelFlag - = TopLevel - | NotTopLevel - -isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool - -isNotTopLevel NotTopLevel = True -isNotTopLevel TopLevel = False - -isTopLevel TopLevel = True -isTopLevel NotTopLevel = False - -instance Outputable TopLevelFlag where - ppr TopLevel = ptext (sLit "") - ppr NotTopLevel = ptext (sLit "") -\end{code} - - -%************************************************************************ -%* * - Top-level/not-top level flag -%* * -%************************************************************************ - -\begin{code} -data Boxity - = Boxed - | Unboxed - deriving( Eq ) - -isBoxed :: Boxity -> Bool -isBoxed Boxed = True -isBoxed Unboxed = False -\end{code} - - -%************************************************************************ -%* * - Recursive/Non-Recursive flag -%* * -%************************************************************************ - -\begin{code} -data RecFlag = Recursive - | NonRecursive - deriving( Eq ) - -isRec :: RecFlag -> Bool -isRec Recursive = True -isRec NonRecursive = False - -isNonRec :: RecFlag -> Bool -isNonRec Recursive = False -isNonRec NonRecursive = True - -boolToRecFlag :: Bool -> RecFlag -boolToRecFlag True = Recursive -boolToRecFlag False = NonRecursive - -instance Outputable RecFlag where - ppr Recursive = ptext (sLit "Recursive") - ppr NonRecursive = ptext (sLit "NonRecursive") -\end{code} - -%************************************************************************ -%* * - Instance overlap flag -%* * -%************************************************************************ - -\begin{code} -data OverlapFlag - = NoOverlap -- This instance must not overlap another - - | 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 - deriving( Eq ) - -instance Outputable OverlapFlag where - ppr NoOverlap = empty - ppr OverlapOk = ptext (sLit "[overlap ok]") - ppr Incoherent = ptext (sLit "[incoherent]") - -\end{code} - -%************************************************************************ -%* * - Tuples -%* * -%************************************************************************ - -\begin{code} -data TupCon = TupCon Boxity Arity - -instance Eq TupCon where - (TupCon b1 a1) == (TupCon b2 a2) = b1==b2 && a1==a2 - -tupleParens :: Boxity -> SDoc -> SDoc -tupleParens Boxed p = parens p -tupleParens Unboxed p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") -\end{code} - -%************************************************************************ -%* * -\subsection[Generic]{Generic flag} -%* * -%************************************************************************ - -This is the "Embedding-Projection pair" datatype, it contains -two pieces of code (normally either RenamedExpr's or Id's) -If we have a such a pair (EP from to), the idea is that 'from' and 'to' -represents functions of type - - from :: T -> Tring - to :: Tring -> T - -And we should have - - to (from x) = x - -T and Tring are arbitrary, but typically T is the 'main' type while -Tring is the 'representation' type. (This just helps us remember -whether to use 'from' or 'to'. - -\begin{code} -data EP a = EP { fromEP :: a, -- :: T -> Tring - toEP :: a } -- :: Tring -> T -\end{code} - -Embedding-projection pairs are used in several places: - -First of all, each type constructor has an EP associated with it, the -code in EP converts (datatype T) from T to Tring and back again. - -Secondly, when we are filling in Generic methods (in the typechecker, -tcMethodBinds), we are constructing bimaps by induction on the structure -of the type of the method signature. - - -%************************************************************************ -%* * -\subsection{Occurrence information} -%* * -%************************************************************************ - -This data type is used exclusively by the simplifier, but it appears in a -SubstResult, which is currently defined in VarEnv, which is pretty near -the base of the module hierarchy. So it seemed simpler to put the -defn of OccInfo here, safely at the bottom - -\begin{code} --- | Identifier occurrence information -data OccInfo - = NoOccInfo -- ^ There are many occurrences, or unknown occurences - - | IAmDead -- ^ Marks unused variables. Sometimes useful for - -- lambda and case-bound variables. - - | OneOcc - !InsideLam - !OneBranch - !InterestingCxt -- ^ Occurs exactly once, not inside a rule - - -- | 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] - -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. - -See OccurAnal Note [Weak loop breakers] for (IAmLoopBreaker True). - - -\begin{code} -isNoOcc :: OccInfo -> Bool -isNoOcc NoOccInfo = True -isNoOcc _ = False - -seqOccInfo :: OccInfo -> () -seqOccInfo occ = occ `seq` () - ------------------ -type InterestingCxt = Bool -- True <=> Function: is applied - -- Data value: scrutinised by a case with - -- at least one non-DEFAULT branch - ------------------ -type InsideLam = Bool -- True <=> Occurs inside a non-linear lambda - -- Substituting a redex for this occurrence is - -- dangerous because it might duplicate work. -insideLam, notInsideLam :: InsideLam -insideLam = True -notInsideLam = False - ------------------ -type OneBranch = Bool -- True <=> Occurs in only one case branch - -- so no code-duplication issue to worry about -oneBranch, notOneBranch :: OneBranch -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 - -isDeadOcc :: OccInfo -> Bool -isDeadOcc IAmDead = True -isDeadOcc _ = False - -isOneOcc :: OccInfo -> Bool -isOneOcc (OneOcc _ _ _) = True -isOneOcc _ = False - -isFragileOcc :: OccInfo -> Bool -isFragileOcc (OneOcc _ _ _) = True -isFragileOcc _ = False -\end{code} - -\begin{code} -instance Outputable OccInfo where - -- only used for debugging; never parsed. KSW 1999-07 - ppr NoOccInfo = empty - ppr (IAmALoopBreaker ro) = ptext (sLit "LoopBreaker") <> if ro then char '!' else empty - ppr IAmDead = ptext (sLit "Dead") - ppr (OneOcc inside_lam one_branch int_cxt) - = ptext (sLit "Once") <> pp_lam <> pp_br <> pp_args - where - pp_lam | inside_lam = char 'L' - | otherwise = empty - pp_br | one_branch = empty - | otherwise = char '*' - pp_args | int_cxt = char '!' - | otherwise = empty - -instance Show OccInfo where - showsPrec p occ = showsPrecSDoc p (ppr occ) -\end{code} - -%************************************************************************ -%* * -\subsection{Strictness indication} -%* * -%************************************************************************ - -The strictness annotations on types in data type declarations -e.g. data T = MkT !Int !(Bool,Bool) - -\begin{code} -data StrictnessMark -- Used in interface decls only - = MarkedStrict - | MarkedUnboxed - | NotMarkedStrict - deriving( Eq ) - -isMarkedUnboxed :: StrictnessMark -> Bool -isMarkedUnboxed MarkedUnboxed = True -isMarkedUnboxed _ = False - -isMarkedStrict :: StrictnessMark -> Bool -isMarkedStrict NotMarkedStrict = False -isMarkedStrict _ = True -- All others are strict - -instance Outputable StrictnessMark where - ppr MarkedStrict = ptext (sLit "!") - ppr MarkedUnboxed = ptext (sLit "!!") - ppr NotMarkedStrict = ptext (sLit "_") -\end{code} - - -%************************************************************************ -%* * -\subsection{Success flag} -%* * -%************************************************************************ - -\begin{code} -data SuccessFlag = Succeeded | Failed - -instance Outputable SuccessFlag where - ppr Succeeded = ptext (sLit "Succeeded") - ppr Failed = ptext (sLit "Failed") - -successIf :: Bool -> SuccessFlag -successIf True = Succeeded -successIf False = Failed - -succeeded, failed :: SuccessFlag -> Bool -succeeded Succeeded = True -succeeded Failed = False - -failed Succeeded = False -failed Failed = True -\end{code} - - -%************************************************************************ -%* * -\subsection{Activation} -%* * -%************************************************************************ - -When a rule or inlining is active - -\begin{code} -type CompilerPhase = Int -- Compilation phase - -- Phases decrease towards zero - -- Zero is the last phase - -data Activation = NeverActive - | AlwaysActive - | ActiveBefore CompilerPhase -- Active only *before* this phase - | ActiveAfter CompilerPhase -- Active in this phase and later - deriving( Eq ) -- Eq used in comparing rules in HsDecls - -data RuleMatchInfo = ConLike - | FunLike - deriving( Eq ) - -isConLike :: RuleMatchInfo -> Bool -isConLike ConLike = True -isConLike _ = False - -isFunLike :: RuleMatchInfo -> Bool -isFunLike FunLike = True -isFunLike _ = False - -data InlinePragma - = InlinePragma - Activation -- Says during which phases inlining is allowed - RuleMatchInfo -- Should the function be treated like a constructor? - deriving( Eq ) - -defaultInlinePragma :: InlinePragma -defaultInlinePragma = InlinePragma AlwaysActive FunLike - -isDefaultInlinePragma :: InlinePragma -> Bool -isDefaultInlinePragma (InlinePragma activation match_info) - = isAlwaysActive activation && isFunLike match_info - -inlinePragmaActivation :: InlinePragma -> Activation -inlinePragmaActivation (InlinePragma activation _) = activation - -inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -inlinePragmaRuleMatchInfo (InlinePragma _ info) = info - -setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma -setInlinePragmaActivation (InlinePragma _ info) activation - = InlinePragma activation info - -setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma -setInlinePragmaRuleMatchInfo (InlinePragma activation _) info - = InlinePragma activation info - -data InlineSpec - = Inline - InlinePragma - Bool -- True <=> INLINE - -- False <=> NOINLINE - deriving( Eq ) - -defaultInlineSpec :: InlineSpec -alwaysInlineSpec, neverInlineSpec :: RuleMatchInfo -> InlineSpec - -defaultInlineSpec = Inline defaultInlinePragma False - -- Inlining is OK, but not forced -alwaysInlineSpec match_info - = Inline (InlinePragma AlwaysActive match_info) True - -- INLINE always -neverInlineSpec match_info - = Inline (InlinePragma NeverActive match_info) False - -- NOINLINE - -instance Outputable Activation where - ppr NeverActive = ptext (sLit "NEVER") - ppr AlwaysActive = ptext (sLit "ALWAYS") - ppr (ActiveBefore n) = brackets (char '~' <> int n) - ppr (ActiveAfter n) = brackets (int n) - -instance Outputable RuleMatchInfo where - ppr ConLike = ptext (sLit "CONLIKE") - ppr FunLike = ptext (sLit "FUNLIKE") - -instance Outputable InlinePragma where - ppr (InlinePragma activation FunLike) - = ppr activation - ppr (InlinePragma activation match_info) - = ppr match_info <+> ppr activation - -instance Outputable InlineSpec where - ppr (Inline (InlinePragma act match_info) is_inline) - | is_inline = ptext (sLit "INLINE") - <+> ppr_match_info - <+> case act of - AlwaysActive -> empty - _ -> ppr act - | otherwise = ptext (sLit "NOINLINE") - <+> ppr_match_info - <+> case act of - NeverActive -> empty - _ -> ppr act - where - ppr_match_info = if isFunLike match_info then empty else ppr match_info - -isActive :: CompilerPhase -> Activation -> Bool -isActive _ NeverActive = False -isActive _ AlwaysActive = True -isActive p (ActiveAfter n) = p <= n -isActive p (ActiveBefore n) = p > n - -isNeverActive, isAlwaysActive :: Activation -> Bool -isNeverActive NeverActive = True -isNeverActive _ = False - -isAlwaysActive AlwaysActive = True -isAlwaysActive _ = False -\end{code} - diff -ruN ghc-6.12.1/compiler/basicTypes/DataCon.lhs ghc-6.13-20091231/compiler/basicTypes/DataCon.lhs --- ghc-6.12.1/compiler/basicTypes/DataCon.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/DataCon.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,919 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1998 -% -\section[DataCon]{@DataCon@: Data Constructors} - -\begin{code} -module DataCon ( - -- * Main data types - DataCon, DataConIds(..), - ConTag, - - -- ** Type construction - mkDataCon, fIRST_TAG, - - -- ** Type deconstruction - dataConRepType, dataConSig, dataConFullSig, - dataConName, dataConIdentity, dataConTag, dataConTyCon, - dataConOrigTyCon, dataConUserType, - dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, - dataConEqSpec, eqSpecPreds, dataConEqTheta, dataConDictTheta, - dataConStupidTheta, - dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, - dataConInstOrigArgTys, dataConRepArgTys, - dataConFieldLabels, dataConFieldType, - dataConStrictMarks, dataConExStricts, - dataConSourceArity, dataConRepArity, - dataConIsInfix, - dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds, - dataConRepStrictness, - - -- ** Predicates on DataCons - isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon, - isVanillaDataCon, classDataCon, - - -- * Splitting product types - splitProductType_maybe, splitProductType, deepSplitProductType, - deepSplitProductType_maybe - ) where - -#include "HsVersions.h" - -import Type -import Coercion -import TyCon -import Class -import Name -import Var -import BasicTypes -import Outputable -import Unique -import ListSetOps -import Util -import FastString -import Module - -import Data.Char -import Data.Word -import Data.List ( partition ) -\end{code} - - -Data constructor representation -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following Haskell data type declaration - - data T = T !Int ![Int] - -Using the strictness annotations, GHC will represent this as - - data T = T Int# [Int] - -That is, the Int has been unboxed. Furthermore, the Haskell source construction - - T e1 e2 - -is translated to - - case e1 of { I# x -> - case e2 of { r -> - T x r }} - -That is, the first argument is unboxed, and the second is evaluated. Finally, -pattern matching is translated too: - - case e of { T a b -> ... } - -becomes - - case e of { T a' b -> let a = I# a' in ... } - -To keep ourselves sane, we name the different versions of the data constructor -differently, as follows. - - -Note [Data Constructor Naming] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Each data constructor C has two, and possibly up to four, Names associated with it: - - OccName Name space Name of Notes - --------------------------------------------------------------------------- - The "data con itself" C DataName DataCon In dom( GlobalRdrEnv ) - The "worker data con" C VarName Id The worker - The "wrapper data con" $WC VarName Id The wrapper - The "newtype coercion" :CoT TcClsName TyCon - -EVERY data constructor (incl for newtypes) has the former two (the -data con itself, and its worker. But only some data constructors have a -wrapper (see Note [The need for a wrapper]). - -Each of these three has a distinct Unique. The "data con itself" name -appears in the output of the renamer, and names the Haskell-source -data constructor. The type checker translates it into either the wrapper Id -(if it exists) or worker Id (otherwise). - -The data con has one or two Ids associated with it: - -The "worker Id", is the actual data constructor. -* Every data constructor (newtype or data type) has a worker - -* The worker is very like a primop, in that it has no binding. - -* For a *data* type, the worker *is* the data constructor; - it has no unfolding - -* For a *newtype*, the worker has a compulsory unfolding which - does a cast, e.g. - newtype T = MkT Int - The worker for MkT has unfolding - \\(x:Int). x `cast` sym CoT - Here CoT is the type constructor, witnessing the FC axiom - axiom CoT : T = Int - -The "wrapper Id", \$WC, goes as follows - -* Its type is exactly what it looks like in the source program. - -* It is an ordinary function, and it gets a top-level binding - like any other function. - -* The wrapper Id isn't generated for a data type if there is - nothing for the wrapper to do. That is, if its defn would be - \$wC = C - -Note [The need for a wrapper] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Why might the wrapper have anything to do? Two reasons: - -* Unboxing strict fields (with -funbox-strict-fields) - data T = MkT !(Int,Int) - \$wMkT :: (Int,Int) -> T - \$wMkT (x,y) = MkT x y - Notice that the worker has two fields where the wapper has - just one. That is, the worker has type - MkT :: Int -> Int -> T - -* Equality constraints for GADTs - data T a where { MkT :: a -> T [a] } - - The worker gets a type with explicit equality - constraints, thus: - MkT :: forall a b. (a=[b]) => b -> T a - - The wrapper has the programmer-specified type: - \$wMkT :: a -> T [a] - \$wMkT a x = MkT [a] a [a] x - The third argument is a coerion - [a] :: [a]~[a] - -INVARIANT: the dictionary constructor for a class - never has a wrapper. - - -A note about the stupid context -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Data types can have a context: - - data (Eq a, Ord b) => T a b = T1 a b | T2 a - -and that makes the constructors have a context too -(notice that T2's context is "thinned"): - - T1 :: (Eq a, Ord b) => a -> b -> T a b - T2 :: (Eq a) => a -> T a b - -Furthermore, this context pops up when pattern matching -(though GHC hasn't implemented this, but it is in H98, and -I've fixed GHC so that it now does): - - f (T2 x) = x -gets inferred type - f :: Eq a => T a b -> a - -I say the context is "stupid" because the dictionaries passed -are immediately discarded -- they do nothing and have no benefit. -It's a flaw in the language. - - Up to now [March 2002] I have put this stupid context into the - type of the "wrapper" constructors functions, T1 and T2, but - that turned out to be jolly inconvenient for generics, and - record update, and other functions that build values of type T - (because they don't have suitable dictionaries available). - - So now I've taken the stupid context out. I simply deal with - it separately in the type checker on occurrences of a - constructor, either in an expression or in a pattern. - - [May 2003: actually I think this decision could evasily be - reversed now, and probably should be. Generics could be - disabled for types with a stupid context; record updates now - (H98) needs the context too; etc. It's an unforced change, so - I'm leaving it for now --- but it does seem odd that the - wrapper doesn't include the stupid context.] - -[July 04] With the advent of generalised data types, it's less obvious -what the "stupid context" is. Consider - C :: forall a. Ord a => a -> a -> T (Foo a) -Does the C constructor in Core contain the Ord dictionary? Yes, it must: - - f :: T b -> Ordering - f = /\b. \x:T b. - case x of - C a (d:Ord a) (p:a) (q:a) -> compare d p q - -Note that (Foo a) might not be an instance of Ord. - -%************************************************************************ -%* * -\subsection{Data constructors} -%* * -%************************************************************************ - -\begin{code} --- | A data constructor -data DataCon - = MkData { - dcName :: Name, -- This is the name of the *source data con* - -- (see "Note [Data Constructor Naming]" above) - dcUnique :: Unique, -- Cached from Name - dcTag :: ConTag, -- ^ Tag, used for ordering 'DataCon's - - -- Running example: - -- - -- *** As declared by the user - -- data T a where - -- MkT :: forall x y. (x~y,Ord x) => x -> y -> T (x,y) - - -- *** As represented internally - -- data T a where - -- MkT :: forall a. forall x y. (a~(x,y),x~y,Ord x) => x -> y -> T a - -- - -- The next six fields express the type of the constructor, in pieces - -- e.g. - -- - -- dcUnivTyVars = [a] - -- dcExTyVars = [x,y] - -- dcEqSpec = [a~(x,y)] - -- dcEqTheta = [x~y] - -- dcDictTheta = [Ord x] - -- dcOrigArgTys = [a,List b] - -- dcRepTyCon = T - - dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor - -- Its type is of form - -- forall a1..an . t1 -> ... tm -> T a1..an - -- No existentials, no coercions, nothing. - -- That is: dcExTyVars = dcEqSpec = dcEqTheta = dcDictTheta = [] - -- 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. - -- The declaration format is held in the TyCon (algTcGadtSyntax) - - dcUnivTyVars :: [TyVar], -- Universally-quantified type vars [a,b,c] - -- INVARIANT: length matches arity of the dcRepTyCon - --- result type of (rep) data con is exactly (T a b c) - - dcExTyVars :: [TyVar], -- Existentially-quantified type vars - -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE TYVARS - -- FOR THE PARENT TyCon. With GADTs the data con might not even have - -- the same number of type variables. - -- [This is a change (Oct05): previously, vanilla datacons guaranteed to - -- have the same type variables as their parent TyCon, but that seems ugly.] - - -- INVARIANT: the UnivTyVars and ExTyVars all have distinct OccNames - -- Reason: less confusing, and easier to generate IfaceSyn - - dcEqSpec :: [(TyVar,Type)], -- Equalities derived from the result type, - -- _as written by the programmer_ - -- This field allows us to move conveniently between the two ways - -- of representing a GADT constructor's type: - -- MkT :: forall a b. (a ~ [b]) => b -> T a - -- MkT :: forall b. b -> T [b] - -- Each equality is of the form (a ~ ty), where 'a' is one of - -- the universally quantified type variables - - -- The next two fields give the type context of the data constructor - -- (aside from the GADT constraints, - -- which are given by the dcExpSpec) - -- 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 - - dcStupidTheta :: ThetaType, -- The context of the data type declaration - -- data Eq a => T a = ... - -- or, rather, a "thinned" version thereof - -- "Thinned", because the Report says - -- to eliminate any constraints that don't mention - -- tyvars free in the arg types for this constructor - -- - -- INVARIANT: the free tyvars of dcStupidTheta are a subset of dcUnivTyVars - -- Reason: dcStupidTeta is gotten by thinning the stupid theta from the tycon - -- - -- "Stupid", because the dictionaries aren't used for anything. - -- Indeed, [as of March 02] they are no longer in the type of - -- the wrapper Id, because that makes it harder to use the wrap-id - -- to rebuild values after record selection or in generics. - - dcOrigArgTys :: [Type], -- Original argument types - -- (before unboxing and flattening of strict fields) - dcOrigResTy :: Type, -- Original result type, as seen by the user - -- NB: for a data instance, the original user result type may - -- differ from the DataCon's representation TyCon. Example - -- data instance T [a] where MkT :: a -> T [a] - -- The OrigResTy is T [a], but the dcRepTyCon might be :T123 - - -- Now the strictness annotations and field labels of the constructor - dcStrictMarks :: [StrictnessMark], - -- Strictness annotations as decided by the compiler. - -- Does *not* include the existential dictionaries - -- length = dataConSourceArity dataCon - - dcFields :: [FieldLabel], - -- Field labels for this constructor, in the - -- same order as the dcOrigArgTys; - -- length = 0 (if not a record) or dataConSourceArity. - - -- Constructor representation - dcRepArgTys :: [Type], -- Final, representation argument types, - -- after unboxing and flattening, - -- and *including* existential dictionaries - - dcRepStrictness :: [StrictnessMark], -- One for each *representation* argument - -- See also Note [Data-con worker strictness] in MkId.lhs - - -- Result type of constructor is T t1..tn - dcRepTyCon :: TyCon, -- Result tycon, T - - dcRepType :: Type, -- Type of the constructor - -- forall a x y. (a~(x,y), x~y, Ord x) => - -- x -> y -> T a - -- (this is *not* of the constructor wrapper Id: - -- see Note [Data con representation] below) - -- Notice that the existential type parameters come *second*. - -- Reason: in a case expression we may find: - -- case (e :: T t) of - -- MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ... - -- It's convenient to apply the rep-type of MkT to 't', to get - -- forall x y. (t~(x,y), x~y, Ord x) => x -> y -> T t - -- and use that to check the pattern. Mind you, this is really only - -- used in CoreLint. - - - -- The curried worker function that corresponds to the constructor: - -- It doesn't have an unfolding; the code generator saturates these Ids - -- and allocates a real constructor when it finds one. - -- - -- An entirely separate wrapper function is built in TcTyDecls - dcIds :: DataConIds, - - dcInfix :: Bool -- True <=> declared infix - -- Used for Template Haskell and 'deriving' only - -- The actual fixity is stored elsewhere - } - --- | Contains the Ids of the data constructor functions -data DataConIds - = DCIds (Maybe Id) Id -- Algebraic data types always have a worker, and - -- may or may not have a wrapper, depending on whether - -- the wrapper does anything. Newtypes just have a worker - - -- _Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments - - -- The wrapper takes dcOrigArgTys as its arguments - -- The worker takes dcRepArgTys as its arguments - -- If the worker is absent, dcRepArgTys is the same as dcOrigArgTys - - -- The 'Nothing' case of DCIds is important - -- Not only is this efficient, - -- but it also ensures that the wrapper is replaced - -- by the worker (because it *is* the worker) - -- even when there are no args. E.g. in - -- f (:) x - -- the (:) *is* the worker. - -- This is really important in rule matching, - -- (We could match on the wrappers, - -- but that makes it less likely that rules will match - -- when we bring bits of unfoldings together.) - --- | Type of the tags associated with each constructor possibility -type ConTag = Int - -fIRST_TAG :: ConTag --- ^ Tags are allocated from here for real constructors -fIRST_TAG = 1 -\end{code} - -Note [Data con representation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The dcRepType field contains the type of the representation of a contructor -This may differ from the type of the contructor *Id* (built -by MkId.mkDataConId) for two reasons: - a) the constructor Id may be overloaded, but the dictionary isn't stored - e.g. data Eq a => T a = MkT a a - - b) the constructor may store an unboxed version of a strict field. - -Here's an example illustrating both: - data Ord a => T a = MkT Int! a -Here - T :: Ord a => Int -> a -> T a -but the rep type is - Trep :: Int# -> a -> T a -Actually, the unboxed part isn't implemented yet! - - -%************************************************************************ -%* * -\subsection{Instances} -%* * -%************************************************************************ - -\begin{code} -instance Eq DataCon where - a == b = getUnique a == getUnique b - a /= b = getUnique a /= getUnique b - -instance Ord DataCon where - a <= b = getUnique a <= getUnique b - a < b = getUnique a < getUnique b - a >= b = getUnique a >= getUnique b - a > b = getUnique a > getUnique b - compare a b = getUnique a `compare` getUnique b - -instance Uniquable DataCon where - getUnique = dcUnique - -instance NamedThing DataCon where - getName = dcName - -instance Outputable DataCon where - ppr con = ppr (dataConName con) - -instance Show DataCon where - showsPrec p con = showsPrecSDoc p (ppr con) -\end{code} - - -%************************************************************************ -%* * -\subsection{Construction} -%* * -%************************************************************************ - -\begin{code} --- | Build a new data constructor -mkDataCon :: Name - -> Bool -- ^ Is the constructor declared infix? - -> [StrictnessMark] -- ^ Strictness annotations written in the source file - -> [FieldLabel] -- ^ Field labels for the constructor, if it is a record, - -- otherwise empty - -> [TyVar] -- ^ Universally quantified type variables - -> [TyVar] -- ^ Existentially quantified type variables - -> [(TyVar,Type)] -- ^ GADT equalities - -> ThetaType -- ^ Theta-type occuring before the arguments proper - -> [Type] -- ^ Original argument types - -> Type -- ^ Original result type - -> TyCon -- ^ Representation type constructor - -> ThetaType -- ^ The "stupid theta", context of the data declaration - -- e.g. @data Eq a => T a ...@ - -> DataConIds -- ^ The Ids of the actual builder functions - -> DataCon - -- Can get the tag from the TyCon - -mkDataCon name declared_infix - arg_stricts -- Must match orig_arg_tys 1-1 - fields - univ_tvs ex_tvs - eq_spec theta - orig_arg_tys orig_res_ty rep_tycon - stupid_theta ids --- Warning: mkDataCon is not a good place to check invariants. --- If the programmer writes the wrong result type in the decl, thus: --- data T a where { MkT :: S } --- then it's possible that the univ_tvs may hit an assertion failure --- if you pull on univ_tvs. This case is checked by checkValidDataCon, --- so the error is detected properly... it's just that asaertions here --- are a little dodgy. - - = -- ASSERT( not (any isEqPred theta) ) - -- We don't currently allow any equality predicates on - -- a data constructor (apart from the GADT ones in eq_spec) - con - where - is_vanilla = null ex_tvs && null eq_spec && null theta - con = MkData {dcName = name, dcUnique = nameUnique name, - dcVanilla = is_vanilla, dcInfix = declared_infix, - dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, - dcEqSpec = eq_spec, - dcStupidTheta = stupid_theta, - dcEqTheta = eq_theta, dcDictTheta = dict_theta, - dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, - dcRepTyCon = rep_tycon, - dcRepArgTys = rep_arg_tys, - dcStrictMarks = arg_stricts, - dcRepStrictness = rep_arg_stricts, - dcFields = fields, dcTag = tag, dcRepType = ty, - dcIds = ids } - - -- Strictness marks for source-args - -- *after unboxing choices*, - -- but *including existential dictionaries* - -- - -- 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 - - -- Representation arguments and demands - -- To do: eliminate duplication with MkId - (rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys - - 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) - -eqSpecPreds :: [(TyVar,Type)] -> ThetaType -eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- spec ] - -mk_dict_strict_mark :: PredType -> StrictnessMark -mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict - | otherwise = NotMarkedStrict -\end{code} - -\begin{code} --- | The 'Name' of the 'DataCon', giving it a unique, rooted identification -dataConName :: DataCon -> Name -dataConName = dcName - --- | The tag used for ordering 'DataCon's -dataConTag :: DataCon -> ConTag -dataConTag = dcTag - --- | The type constructor that we are building via this data constructor -dataConTyCon :: DataCon -> TyCon -dataConTyCon = dcRepTyCon - --- | The original type constructor used in the definition of this data --- constructor. In case of a data family instance, that will be the family --- type constructor. -dataConOrigTyCon :: DataCon -> TyCon -dataConOrigTyCon dc - | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc - | otherwise = dcRepTyCon dc - --- | The representation type of the data constructor, i.e. the sort --- type that will represent values of this type at runtime -dataConRepType :: DataCon -> Type -dataConRepType = dcRepType - --- | Should the 'DataCon' be presented infix? -dataConIsInfix :: DataCon -> Bool -dataConIsInfix = dcInfix - --- | The universally-quantified type variables of the constructor -dataConUnivTyVars :: DataCon -> [TyVar] -dataConUnivTyVars = dcUnivTyVars - --- | The existentially-quantified type variables of the constructor -dataConExTyVars :: DataCon -> [TyVar] -dataConExTyVars = dcExTyVars - --- | Both the universal and existentiatial type variables of the constructor -dataConAllTyVars :: DataCon -> [TyVar] -dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs }) - = univ_tvs ++ ex_tvs - --- | Equalities derived from the result type of the data constructor, as written --- by the programmer in any GADT declaration -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 - --- | 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 --- be different from the obvious one written in the source program. Panics --- if there is no such 'Id' for this 'DataCon' -dataConWorkId :: DataCon -> Id -dataConWorkId dc = case dcIds dc of - DCIds _ wrk_id -> wrk_id - --- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual" --- constructor so it has the type visible in the source program: c.f. 'dataConWorkId'. --- Returns Nothing if there is no wrapper, which occurs for an algebraic data constructor --- and also for a newtype (whose constructor is inlined compulsorily) -dataConWrapId_maybe :: DataCon -> Maybe Id -dataConWrapId_maybe dc = case dcIds dc of - DCIds mb_wrap _ -> mb_wrap - --- | Returns an Id which looks like the Haskell-source constructor by using --- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to --- the worker (see 'dataConWorkId') -dataConWrapId :: DataCon -> Id -dataConWrapId dc = case dcIds dc of - DCIds (Just wrap) _ -> wrap - DCIds Nothing wrk -> wrk -- worker=wrapper - --- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently, --- the union of the 'dataConWorkId' and the 'dataConWrapId' -dataConImplicitIds :: DataCon -> [Id] -dataConImplicitIds dc = case dcIds dc of - DCIds (Just wrap) work -> [wrap,work] - DCIds Nothing work -> [work] - --- | The labels for the fields of this particular 'DataCon' -dataConFieldLabels :: DataCon -> [FieldLabel] -dataConFieldLabels = dcFields - --- | Extract the type for any given labelled field of the 'DataCon' -dataConFieldType :: DataCon -> FieldLabel -> Type -dataConFieldType con label - = case lookup label (dcFields con `zip` dcOrigArgTys con) of - Just ty -> ty - Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label) - --- | The strictness markings decided on by the compiler. Does not include those for --- existential dictionaries. The list is in one-to-one correspondence with the arity of the 'DataCon' -dataConStrictMarks :: DataCon -> [StrictnessMark] -dataConStrictMarks = dcStrictMarks - --- | Strictness of /existential/ arguments only -dataConExStricts :: DataCon -> [StrictnessMark] --- Usually empty, so we don't bother to cache this -dataConExStricts dc = map mk_dict_strict_mark $ dcDictTheta dc - --- | Source-level arity of the data constructor -dataConSourceArity :: DataCon -> Arity -dataConSourceArity dc = length (dcOrigArgTys dc) - --- | Gives the number of actual fields in the /representation/ of the --- data constructor. This may be more than appear in the source code; --- the extra ones are the existentially quantified dictionaries -dataConRepArity :: DataCon -> Int -dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys - --- | Return whether there are any argument types for this 'DataCon's original source type -isNullarySrcDataCon :: DataCon -> Bool -isNullarySrcDataCon dc = null (dcOrigArgTys dc) - --- | Return whether there are any argument types for this 'DataCon's runtime representation type -isNullaryRepDataCon :: DataCon -> Bool -isNullaryRepDataCon dc = null (dcRepArgTys dc) - -dataConRepStrictness :: DataCon -> [StrictnessMark] --- ^ Give the demands on the arguments of a --- Core constructor application (Con dc args) -dataConRepStrictness dc = dcRepStrictness dc - --- | The \"signature\" of the 'DataCon' returns, in order: --- --- 1) The result of 'dataConAllTyVars', --- --- 2) All the 'ThetaType's relating to the 'DataCon' (coercion, dictionary, implicit --- parameter - whatever) --- --- 3) The type arguments to the constructor --- --- 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, - dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ eq_theta ++ dict_theta, arg_tys, res_ty) - --- | The \"full signature\" of the 'DataCon' returns, in order: --- --- 1) The result of 'dataConUnivTyVars' --- --- 2) The result of 'dataConExTyVars' --- --- 3) The result of 'dataConEqSpec' --- --- 4) The result of 'dataConDictTheta' --- --- 5) The original argument types to the 'DataCon' (i.e. before --- any change of the representation of the type) --- --- 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, - dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, res_ty) - -dataConOrigResTy :: DataCon -> Type -dataConOrigResTy dc = dcOrigResTy dc - --- | The \"stupid theta\" of the 'DataCon', such as @data Eq a@ in: --- --- > data Eq a => T a = ... -dataConStupidTheta :: DataCon -> ThetaType -dataConStupidTheta dc = dcStupidTheta dc - -dataConUserType :: DataCon -> Type --- ^ The user-declared type of the data constructor --- in the nice-to-read form: --- --- > T :: forall a b. a -> b -> T [a] --- --- rather than: --- --- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c --- --- NB: If the constructor is part of a data instance, the result type --- 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, - dcOrigResTy = res_ty }) - = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $ - mkFunTys (mkPredTys eq_theta) $ - mkFunTys (mkPredTys dict_theta) $ - mkFunTys arg_tys $ - res_ty - --- | Finds the instantiated types of the arguments required to construct a 'DataCon' representation --- NB: these INCLUDE any dictionary args --- but EXCLUDE the data-declaration context, which is discarded --- It's all post-flattening etc; this is a representation type -dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality constraints - -- However, it can have a dcTheta (notably it can be a - -- class dictionary, with superclasses) - -> [Type] -- ^ Instantiated at these types - -> [Type] -dataConInstArgTys dc@(MkData {dcRepArgTys = rep_arg_tys, - dcUnivTyVars = univ_tvs, dcEqSpec = eq_spec, - dcExTyVars = ex_tvs}) inst_tys - = ASSERT2 ( length univ_tvs == length inst_tys - , ptext (sLit "dataConInstArgTys") <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) - ASSERT2 ( null ex_tvs && null eq_spec, ppr dc ) - map (substTyWith univ_tvs inst_tys) rep_arg_tys - --- | Returns just the instantiated /value/ argument types of a 'DataCon', --- (excluding dictionary args) -dataConInstOrigArgTys - :: DataCon -- Works for any DataCon - -> [Type] -- Includes existential tyvar args, but NOT - -- equality constraints or dicts - -> [Type] --- For vanilla datacons, it's all quite straightforward --- But for the call in MatchCon, we really do want just the value args -dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, - dcUnivTyVars = univ_tvs, - dcExTyVars = ex_tvs}) inst_tys - = ASSERT2( length tyvars == length inst_tys - , ptext (sLit "dataConInstOrigArgTys") <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) - map (substTyWith tyvars inst_tys) arg_tys - where - tyvars = univ_tvs ++ ex_tvs -\end{code} - -\begin{code} --- | Returns the argument types of the wrapper, excluding all dictionary arguments --- and without substituting for any type variables -dataConOrigArgTys :: DataCon -> [Type] -dataConOrigArgTys dc = dcOrigArgTys dc - --- | Returns the arg types of the worker, including all dictionaries, after any --- flattening has been done and without substituting for any type variables -dataConRepArgTys :: DataCon -> [Type] -dataConRepArgTys dc = dcRepArgTys dc -\end{code} - -\begin{code} --- | The string @package:module.name@ identifying a constructor, which is attached --- to its info table and used by the GHCi debugger and the heap profiler -dataConIdentity :: DataCon -> [Word8] --- We want this string to be UTF-8, so we get the bytes directly from the FastStrings. -dataConIdentity dc = bytesFS (packageIdFS (modulePackageId mod)) ++ - fromIntegral (ord ':') : bytesFS (moduleNameFS (moduleName mod)) ++ - fromIntegral (ord '.') : bytesFS (occNameFS (nameOccName name)) - where name = dataConName dc - mod = ASSERT( isExternalName name ) nameModule name -\end{code} - -\begin{code} -isTupleCon :: DataCon -> Bool -isTupleCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc - -isUnboxedTupleCon :: DataCon -> Bool -isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc - --- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors -isVanillaDataCon :: DataCon -> Bool -isVanillaDataCon dc = dcVanilla dc -\end{code} - -\begin{code} -classDataCon :: Class -> DataCon -classDataCon clas = case tyConDataCons (classTyCon clas) of - (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr - [] -> panic "classDataCon" -\end{code} - -%************************************************************************ -%* * -\subsection{Splitting products} -%* * -%************************************************************************ - -\begin{code} --- | Extract the type constructor, type argument, data constructor and it's --- /representation/ argument types from a type if it is a product type. --- --- Precisely, we return @Just@ for any type that is all of: --- --- * Concrete (i.e. constructors visible) --- --- * Single-constructor --- --- * Not existentially quantified --- --- Whether the type is a @data@ type or a @newtype@ -splitProductType_maybe - :: Type -- ^ A product type, perhaps - -> Maybe (TyCon, -- The type constructor - [Type], -- Type args of the tycon - DataCon, -- The data constructor - [Type]) -- Its /representation/ arg types - - -- Rejecing existentials is conservative. Maybe some things - -- could be made to work with them, but I'm not going to sweat - -- it through till someone finds it's important. - -splitProductType_maybe ty - = case splitTyConApp_maybe ty of - Just (tycon,ty_args) - | isProductTyCon tycon -- Includes check for non-existential, - -- and for constructors visible - -> Just (tycon, ty_args, data_con, dataConInstArgTys data_con ty_args) - where - data_con = ASSERT( not (null (tyConDataCons tycon)) ) - head (tyConDataCons tycon) - _other -> Nothing - --- | As 'splitProductType_maybe', but panics if the 'Type' is not a product type -splitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type]) -splitProductType str ty - = case splitProductType_maybe ty of - Just stuff -> stuff - Nothing -> pprPanic (str ++ ": not a product") (pprType ty) - - --- | As 'splitProductType_maybe', but in turn instantiates the 'TyCon' returned --- and hence recursively tries to unpack it as far as it able to -deepSplitProductType_maybe :: Type -> Maybe (TyCon, [Type], DataCon, [Type]) -deepSplitProductType_maybe ty - = do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty - ; let {result - | Just (ty', _co) <- instNewTyCon_maybe tycon tycon_args - , not (isRecursiveTyCon tycon) - = deepSplitProductType_maybe ty' -- Ignore the coercion? - | isNewTyCon tycon = Nothing -- cannot unbox through recursive - -- newtypes nor through families - | otherwise = Just res} - ; result - } - --- | As 'deepSplitProductType_maybe', but panics if the 'Type' is not a product type -deepSplitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type]) -deepSplitProductType str ty - = case deepSplitProductType_maybe ty of - Just stuff -> stuff - Nothing -> pprPanic (str ++ ": not a product") (pprType ty) - --- | Compute the representation type strictness and type suitable for a 'DataCon' -computeRep :: [StrictnessMark] -- ^ Original argument strictness - -> [Type] -- ^ Original argument types - -> ([StrictnessMark], -- Representation arg strictness - [Type]) -- And type - -computeRep stricts tys - = unzip $ concat $ zipWithEqual "computeRep" unbox stricts tys - where - unbox NotMarkedStrict ty = [(NotMarkedStrict, ty)] - unbox MarkedStrict ty = [(MarkedStrict, ty)] - unbox MarkedUnboxed ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys - where - (_tycon, _tycon_args, arg_dc, arg_tys) - = deepSplitProductType "unbox_strict_arg_ty" ty -\end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/DataCon.lhs-boot ghc-6.13-20091231/compiler/basicTypes/DataCon.lhs-boot --- ghc-6.12.1/compiler/basicTypes/DataCon.lhs-boot 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/DataCon.lhs-boot 1969-12-31 16:00:00.000000000 -0800 @@ -1,8 +0,0 @@ -\begin{code} -module DataCon where -import Name( Name ) - -data DataCon -dataConName :: DataCon -> Name -isVanillaDataCon :: DataCon -> Bool -\end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/Demand.lhs ghc-6.13-20091231/compiler/basicTypes/Demand.lhs --- ghc-6.12.1/compiler/basicTypes/Demand.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/Demand.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,219 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[Demand]{@Demand@: the amount of demand on a value} - -\begin{code} -#ifndef OLD_STRICTNESS -module Demand () where -#else - -module Demand( - Demand(..), - - wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum, - isStrict, isLazy, isPrim, - - pprDemands, seqDemand, seqDemands, - - StrictnessInfo(..), - mkStrictnessInfo, - noStrictnessInfo, - ppStrictnessInfo, seqStrictnessInfo, - isBottomingStrictness, appIsBottom, - - ) where - -#include "HsVersions.h" - -import Outputable -import Util -\end{code} - - -%************************************************************************ -%* * -\subsection{The @Demand@ data type} -%* * -%************************************************************************ - -\begin{code} -data Demand - = WwLazy -- Argument is lazy as far as we know - MaybeAbsent -- (does not imply worker's existence [etc]). - -- If MaybeAbsent == True, then it is - -- *definitely* lazy. (NB: Absence implies - -- a worker...) - - | WwStrict -- Argument is strict but that's all we know - -- (does not imply worker's existence or any - -- calling-convention magic) - - | WwUnpack -- Argument is strict & a single-constructor type - Bool -- True <=> wrapper unpacks it; False <=> doesn't - [Demand] -- Its constituent parts (whose StrictInfos - -- are in the list) should be passed - -- as arguments to the worker. - - | WwPrim -- Argument is of primitive type, therefore - -- strict; doesn't imply existence of a worker; - -- argument should be passed as is to worker. - - | WwEnum -- Argument is strict & an enumeration type; - -- an Int# representing the tag (start counting - -- at zero) should be passed to the worker. - deriving( Eq ) - -type MaybeAbsent = Bool -- True <=> not even used - --- versions that don't worry about Absence: -wwLazy, wwStrict, wwPrim, wwEnum :: Demand -wwUnpack :: [Demand] -> Demand - -wwLazy = WwLazy False -wwStrict = WwStrict -wwUnpack xs = WwUnpack False xs -wwPrim = WwPrim -wwEnum = WwEnum - -seqDemand :: Demand -> () -seqDemand (WwLazy a) = a `seq` () -seqDemand (WwUnpack b ds) = b `seq` seqDemands ds -seqDemand _ = () - -seqDemands :: [Demand] -> () -seqDemands [] = () -seqDemands (d:ds) = seqDemand d `seq` seqDemands ds -\end{code} - - -%************************************************************************ -%* * -\subsection{Functions over @Demand@} -%* * -%************************************************************************ - -\begin{code} -isLazy :: Demand -> Bool -isLazy (WwLazy _) = True -isLazy _ = False - -isStrict :: Demand -> Bool -isStrict d = not (isLazy d) - -isPrim :: Demand -> Bool -isPrim WwPrim = True -isPrim _ = False -\end{code} - - -%************************************************************************ -%* * -\subsection{Instances} -%* * -%************************************************************************ - - -\begin{code} -pprDemands :: [Demand] -> Bool -> SDoc -pprDemands demands bot = hcat (map pprDemand demands) <> pp_bot - where - pp_bot | bot = ptext (sLit "B") - | otherwise = empty - - -pprDemand :: Demand -> SDoc -pprDemand (WwLazy False) = char 'L' -pprDemand (WwLazy True) = char 'A' -pprDemand WwStrict = char 'S' -pprDemand WwPrim = char 'P' -pprDemand WwEnum = char 'E' -pprDemand (WwUnpack wu args) = char ch <> parens (hcat (map pprDemand args)) - where - ch = if wu then 'U' else 'u' - -instance Outputable Demand where - ppr (WwLazy False) = empty - ppr other_demand = ptext (sLit "__D") <+> pprDemand other_demand - -instance Show Demand where - showsPrec p d = showsPrecSDoc p (ppr d) - --- Reading demands is done in Lex.lhs -\end{code} - - -%************************************************************************ -%* * -\subsection[strictness-IdInfo]{Strictness info about an @Id@} -%* * -%************************************************************************ - -We specify the strictness of a function by giving information about -each of the ``wrapper's'' arguments (see the description about -worker/wrapper-style transformations in the PJ/Launchbury paper on -unboxed types). - -The list of @Demands@ specifies: (a)~the strictness properties of a -function's arguments; and (b)~the type signature of that worker (if it -exists); i.e. its calling convention. - -Note that the existence of a worker function is now denoted by the Id's -workerInfo field. - -\begin{code} -data StrictnessInfo - = NoStrictnessInfo - - | StrictnessInfo [Demand] -- Demands on the arguments. - - Bool -- True <=> the function diverges regardless of its arguments - -- Useful for "error" and other disguised variants thereof. - -- BUT NB: f = \x y. error "urk" - -- will have info SI [SS] True - -- but still (f) and (f 2) are not bot; only (f 3 2) is bot - deriving( Eq ) - - -- NOTA BENE: if the arg demands are, say, [S,L], this means that - -- (f bot) is not necy bot, only (f bot x) is bot - -- We simply cannot express accurately the strictness of a function - -- like f = \x -> case x of (a,b) -> \y -> ... - -- The up-side is that we don't need to restrict the strictness info - -- to the visible arity of the function. - -seqStrictnessInfo :: StrictnessInfo -> () -seqStrictnessInfo (StrictnessInfo ds b) = b `seq` seqDemands ds -seqStrictnessInfo _ = () -\end{code} - -\begin{code} -mkStrictnessInfo :: ([Demand], Bool) -> StrictnessInfo - -mkStrictnessInfo (xs, is_bot) - | all totally_boring xs && not is_bot = NoStrictnessInfo -- Uninteresting - | otherwise = StrictnessInfo xs is_bot - where - totally_boring (WwLazy False) = True - totally_boring _ = False - -noStrictnessInfo :: StrictnessInfo -noStrictnessInfo = NoStrictnessInfo - -isBottomingStrictness :: StrictnessInfo -> Bool -isBottomingStrictness (StrictnessInfo _ bot) = bot -isBottomingStrictness NoStrictnessInfo = False - --- appIsBottom returns true if an application to n args would diverge -appIsBottom :: StrictnessInfo -> Int -> Bool -appIsBottom (StrictnessInfo ds bot) n = bot && (listLengthCmp ds n /=GT) -- not more than 'n' elts in 'ds'. -appIsBottom NoStrictnessInfo _ = False - -ppStrictnessInfo :: StrictnessInfo -> SDoc -ppStrictnessInfo NoStrictnessInfo = empty -ppStrictnessInfo (StrictnessInfo wrapper_args bot) = hsep [pprDemands wrapper_args bot] -\end{code} - -\begin{code} -#endif /* OLD_STRICTNESS */ -\end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/IdInfo.lhs ghc-6.13-20091231/compiler/basicTypes/IdInfo.lhs --- ghc-6.12.1/compiler/basicTypes/IdInfo.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/IdInfo.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,802 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -% -\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@} - -(And a pretty good illustration of quite a few things wrong with -Haskell. [WDP 94/11]) - -\begin{code} -module IdInfo ( - -- * The IdDetails type - IdDetails(..), pprIdDetails, - - -- * The IdInfo type - IdInfo, -- Abstract - vanillaIdInfo, noCafIdInfo, - seqIdInfo, megaSeqIdInfo, - - -- ** Zapping various forms of Info - zapLamInfo, zapDemandInfo, zapFragileInfo, - - -- ** The ArityInfo type - ArityInfo, - unknownArity, - arityInfo, setArityInfo, ppArityInfo, - - -- ** Demand and strictness Info - newStrictnessInfo, setNewStrictnessInfo, - newDemandInfo, setNewDemandInfo, pprNewStrictness, - setAllStrictnessInfo, - -#ifdef OLD_STRICTNESS - -- ** Old strictness Info - StrictnessInfo(..), - mkStrictnessInfo, noStrictnessInfo, - ppStrictnessInfo, isBottomingStrictness, - strictnessInfo, setStrictnessInfo, - - oldStrictnessFromNew, newStrictnessFromOld, - - -- ** Old demand Info - demandInfo, setDemandInfo, - oldDemand, newDemand, - - -- ** Old Constructed Product Result Info - CprInfo(..), - cprInfo, setCprInfo, ppCprInfo, noCprInfo, - cprInfoFromNewStrictness, -#endif - - -- ** The WorkerInfo type - WorkerInfo(..), - workerExists, wrapperArity, workerId, - workerInfo, setWorkerInfo, ppWorkerInfo, - - -- ** Unfolding Info - unfoldingInfo, setUnfoldingInfo, setUnfoldingInfoLazily, - - -- ** The InlinePragInfo type - InlinePragInfo, - inlinePragInfo, setInlinePragInfo, - - -- ** The OccInfo type - OccInfo(..), - isFragileOcc, isDeadOcc, isLoopBreaker, - occInfo, setOccInfo, - - InsideLam, OneBranch, - insideLam, notInsideLam, oneBranch, notOneBranch, - - -- ** The SpecInfo type - SpecInfo(..), - isEmptySpecInfo, specInfoFreeVars, - specInfoRules, seqSpecInfo, setSpecInfoHead, - specInfo, setSpecInfo, - - -- ** The CAFInfo type - CafInfo(..), - ppCafInfo, mayHaveCafRefs, - cafInfo, setCafInfo, - - -- ** The LBVarInfo type - LBVarInfo(..), - noLBVarInfo, hasNoLBVarInfo, - lbvarInfo, setLBVarInfo, - - -- ** Tick-box Info - TickBoxOp(..), TickBoxId, - ) where - -import CoreSyn ( CoreRule, setRuleIdName, seqRules, Unfolding, noUnfolding ) - -import Class -import PrimOp -import Name -import Var -import VarSet -import BasicTypes -import DataCon -import TyCon -import ForeignCall -import NewDemand -import Outputable -import Module -import FastString - -import Data.Maybe - -#ifdef OLD_STRICTNESS -import Demand -import qualified Demand -import Util -import Data.List -#endif - --- infixl so you can say (id `set` a `set` b) -infixl 1 `setSpecInfo`, - `setArityInfo`, - `setInlinePragInfo`, - `setUnfoldingInfo`, - `setWorkerInfo`, - `setLBVarInfo`, - `setOccInfo`, - `setCafInfo`, - `setNewStrictnessInfo`, - `setAllStrictnessInfo`, - `setNewDemandInfo` -#ifdef OLD_STRICTNESS - , `setCprInfo` - , `setDemandInfo` - , `setStrictnessInfo` -#endif -\end{code} - -%************************************************************************ -%* * -\subsection{New strictness info} -%* * -%************************************************************************ - -To be removed later - -\begin{code} --- | Set old and new strictness information together -setAllStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo -setAllStrictnessInfo info Nothing - = info { newStrictnessInfo = Nothing -#ifdef OLD_STRICTNESS - , strictnessInfo = NoStrictnessInfo - , cprInfo = NoCPRInfo -#endif - } - -setAllStrictnessInfo info (Just sig) - = info { newStrictnessInfo = Just sig -#ifdef OLD_STRICTNESS - , strictnessInfo = oldStrictnessFromNew sig - , cprInfo = cprInfoFromNewStrictness sig -#endif - } - -seqNewStrictnessInfo :: Maybe StrictSig -> () -seqNewStrictnessInfo Nothing = () -seqNewStrictnessInfo (Just ty) = seqStrictSig ty - -pprNewStrictness :: Maybe StrictSig -> SDoc -pprNewStrictness Nothing = empty -pprNewStrictness (Just sig) = ftext (fsLit "Str:") <+> ppr sig - -#ifdef OLD_STRICTNESS -oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo -oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info) - where - (dmds, res_info) = splitStrictSig sig - -cprInfoFromNewStrictness :: StrictSig -> CprInfo -cprInfoFromNewStrictness sig = case strictSigResInfo sig of - RetCPR -> ReturnsCPR - other -> NoCPRInfo - -newStrictnessFromOld :: Name -> Arity -> Demand.StrictnessInfo -> CprInfo -> StrictSig -newStrictnessFromOld name arity (Demand.StrictnessInfo ds res) cpr - | listLengthCmp ds arity /= GT -- length ds <= arity - -- Sometimes the old strictness analyser has more - -- demands than the arity justifies - = mk_strict_sig name arity $ - mkTopDmdType (map newDemand ds) (newRes res cpr) - -newStrictnessFromOld name arity other cpr - = -- Either no strictness info, or arity is too small - -- In either case we can't say anything useful - mk_strict_sig name arity $ - mkTopDmdType (replicate arity lazyDmd) (newRes False cpr) - -mk_strict_sig name arity dmd_ty - = WARN( arity /= dmdTypeDepth dmd_ty, ppr name <+> (ppr arity $$ ppr dmd_ty) ) - mkStrictSig dmd_ty - -newRes True _ = BotRes -newRes False ReturnsCPR = retCPR -newRes False NoCPRInfo = TopRes - -newDemand :: Demand.Demand -> NewDemand.Demand -newDemand (WwLazy True) = Abs -newDemand (WwLazy False) = lazyDmd -newDemand WwStrict = evalDmd -newDemand (WwUnpack unpk ds) = Eval (Prod (map newDemand ds)) -newDemand WwPrim = lazyDmd -newDemand WwEnum = evalDmd - -oldDemand :: NewDemand.Demand -> Demand.Demand -oldDemand Abs = WwLazy True -oldDemand Top = WwLazy False -oldDemand Bot = WwStrict -oldDemand (Box Bot) = WwStrict -oldDemand (Box Abs) = WwLazy False -oldDemand (Box (Eval _)) = WwStrict -- Pass box only -oldDemand (Defer d) = WwLazy False -oldDemand (Eval (Prod ds)) = WwUnpack True (map oldDemand ds) -oldDemand (Eval (Poly _)) = WwStrict -oldDemand (Call _) = WwStrict - -#endif /* OLD_STRICTNESS */ -\end{code} - - -\begin{code} -seqNewDemandInfo :: Maybe Demand -> () -seqNewDemandInfo Nothing = () -seqNewDemandInfo (Just dmd) = seqDemand dmd -\end{code} - - -%************************************************************************ -%* * - IdDetails -%* * -%************************************************************************ - -\begin{code} --- | The 'IdDetails' of an 'Id' give stable, and necessary, --- information about the Id. -data IdDetails - = VanillaId - - -- | The 'Id' for a record selector - | RecSelId - { sel_tycon :: TyCon -- ^ For a data type family, this is the /instance/ 'TyCon' - -- not the family 'TyCon' - , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: - -- data T = forall a. MkT { x :: a } - } -- See Note [Naughty record selectors] in TcTyClsDecls - - | DataConWorkId DataCon -- ^ The 'Id' is for a data constructor /worker/ - | DataConWrapId DataCon -- ^ The 'Id' is for a data constructor /wrapper/ - - -- [the only reasons we need to know is so that - -- a) to support isImplicitId - -- b) when desugaring a RecordCon we can get - -- from the Id back to the data con] - - | ClassOpId Class -- ^ The 'Id' is an operation of a class - - | PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator - | FCallId ForeignCall -- ^ The 'Id' is for a foreign call - - | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) - - | DFunId -- ^ A dictionary function. We don't use this in an essential way, - -- currently, but it's kind of nice that we can keep track of - -- which Ids are DFuns, across module boundaries too - - -instance Outputable IdDetails where - ppr = pprIdDetails - -pprIdDetails :: IdDetails -> SDoc -pprIdDetails VanillaId = empty -pprIdDetails (DataConWorkId _) = ptext (sLit "[DataCon]") -pprIdDetails (DataConWrapId _) = ptext (sLit "[DataConWrapper]") -pprIdDetails (ClassOpId _) = ptext (sLit "[ClassOp]") -pprIdDetails (PrimOpId _) = ptext (sLit "[PrimOp]") -pprIdDetails (FCallId _) = ptext (sLit "[ForeignCall]") -pprIdDetails (TickBoxOpId _) = ptext (sLit "[TickBoxOp]") -pprIdDetails DFunId = ptext (sLit "[DFunId]") -pprIdDetails (RecSelId { sel_naughty = is_naughty }) - = brackets $ ptext (sLit "RecSel") <> pp_naughty - where - pp_naughty | is_naughty = ptext (sLit "(naughty)") - | otherwise = empty -\end{code} - - -%************************************************************************ -%* * -\subsection{The main IdInfo type} -%* * -%************************************************************************ - -\begin{code} --- | An 'IdInfo' gives /optional/ information about an 'Id'. If --- present it never lies, but it may not be present, in which case there --- is always a conservative assumption which can be made. --- --- Two 'Id's may have different info even though they have the same --- 'Unique' (and are hence the same 'Id'); for example, one might lack --- the properties attached to the other. --- --- The 'IdInfo' gives information about the value, or definition, of the --- 'Id'. It does not contain information about the 'Id''s usage, --- except for 'demandInfo' and 'lbvarInfo'. -data IdInfo - = IdInfo { - arityInfo :: !ArityInfo, -- ^ 'Id' arity - specInfo :: SpecInfo, -- ^ Specialisations of the 'Id's function which exist -#ifdef OLD_STRICTNESS - cprInfo :: CprInfo, -- ^ If the 'Id's function always constructs a product result - demandInfo :: Demand.Demand, -- ^ Whether or not the 'Id' is definitely demanded - strictnessInfo :: StrictnessInfo, -- ^ 'Id' strictness properties -#endif - workerInfo :: WorkerInfo, -- ^ Pointer to worker function. - -- Within one module this is irrelevant; the - -- inlining of a worker is handled via the 'Unfolding'. - -- However, when the module is imported by others, the - -- 'WorkerInfo' is used /only/ to indicate the form of - -- the RHS, so that interface files don't actually - -- need to contain the RHS; it can be derived from - -- the strictness info - - unfoldingInfo :: Unfolding, -- ^ The 'Id's unfolding - cafInfo :: CafInfo, -- ^ 'Id' CAF info - lbvarInfo :: LBVarInfo, -- ^ Info about a lambda-bound variable, if the 'Id' is one - inlinePragInfo :: InlinePragma, -- ^ Any inline pragma atached to the 'Id' - occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program - - newStrictnessInfo :: Maybe StrictSig, -- ^ Id strictness information. Reason for Maybe: - -- the DmdAnal phase needs to know whether - -- this is the first visit, so it can assign botSig. - -- Other customers want topSig. So @Nothing@ is good. - - newDemandInfo :: Maybe Demand -- ^ Id demand information. Similarly we want to know - -- if there's no known demand yet, for when we are looking - -- for CPR info - } - --- | Just evaluate the 'IdInfo' to WHNF -seqIdInfo :: IdInfo -> () -seqIdInfo (IdInfo {}) = () - --- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the --- compiler -megaSeqIdInfo :: IdInfo -> () -megaSeqIdInfo info - = seqSpecInfo (specInfo info) `seq` - seqWorker (workerInfo info) `seq` - --- Omitting this improves runtimes a little, presumably because --- some unfoldings are not calculated at all --- seqUnfolding (unfoldingInfo info) `seq` - - seqNewDemandInfo (newDemandInfo info) `seq` - seqNewStrictnessInfo (newStrictnessInfo info) `seq` - -#ifdef OLD_STRICTNESS - Demand.seqDemand (demandInfo info) `seq` - seqStrictnessInfo (strictnessInfo info) `seq` - seqCpr (cprInfo info) `seq` -#endif - - seqCaf (cafInfo info) `seq` - seqLBVar (lbvarInfo info) `seq` - seqOccInfo (occInfo info) -\end{code} - -Setters - -\begin{code} -setWorkerInfo :: IdInfo -> WorkerInfo -> IdInfo -setWorkerInfo info wk = wk `seq` info { workerInfo = wk } -setSpecInfo :: IdInfo -> SpecInfo -> IdInfo -setSpecInfo info sp = sp `seq` info { specInfo = sp } -setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo -setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } -setOccInfo :: IdInfo -> OccInfo -> IdInfo -setOccInfo info oc = oc `seq` info { occInfo = oc } -#ifdef OLD_STRICTNESS -setStrictnessInfo info st = st `seq` info { strictnessInfo = st } -#endif - -- Try to avoid spack leaks by seq'ing - -setUnfoldingInfoLazily :: IdInfo -> Unfolding -> IdInfo -setUnfoldingInfoLazily info uf -- Lazy variant to avoid looking at the - = -- unfolding of an imported Id unless necessary - info { unfoldingInfo = uf } -- (In this case the demand-zapping is redundant.) - -setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo -setUnfoldingInfo info uf - -- We do *not* seq on the unfolding info, For some reason, doing so - -- actually increases residency significantly. - = info { unfoldingInfo = uf } - -#ifdef OLD_STRICTNESS -setDemandInfo info dd = info { demandInfo = dd } -setCprInfo info cp = info { cprInfo = cp } -#endif - -setArityInfo :: IdInfo -> ArityInfo -> IdInfo -setArityInfo info ar = info { arityInfo = ar } -setCafInfo :: IdInfo -> CafInfo -> IdInfo -setCafInfo info caf = info { cafInfo = caf } - -setLBVarInfo :: IdInfo -> LBVarInfo -> IdInfo -setLBVarInfo info lb = {-lb `seq`-} info { lbvarInfo = lb } - -setNewDemandInfo :: IdInfo -> Maybe Demand -> IdInfo -setNewDemandInfo info dd = dd `seq` info { newDemandInfo = dd } -setNewStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo -setNewStrictnessInfo info dd = dd `seq` info { newStrictnessInfo = dd } -\end{code} - - -\begin{code} --- | Basic 'IdInfo' that carries no useful information whatsoever -vanillaIdInfo :: IdInfo -vanillaIdInfo - = IdInfo { - cafInfo = vanillaCafInfo, - arityInfo = unknownArity, -#ifdef OLD_STRICTNESS - cprInfo = NoCPRInfo, - demandInfo = wwLazy, - strictnessInfo = NoStrictnessInfo, -#endif - specInfo = emptySpecInfo, - workerInfo = NoWorker, - unfoldingInfo = noUnfolding, - lbvarInfo = NoLBVarInfo, - inlinePragInfo = defaultInlinePragma, - occInfo = NoOccInfo, - newDemandInfo = Nothing, - newStrictnessInfo = Nothing - } - --- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references -noCafIdInfo :: IdInfo -noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs - -- Used for built-in type Ids in MkId. -\end{code} - - -%************************************************************************ -%* * -\subsection[arity-IdInfo]{Arity info about an @Id@} -%* * -%************************************************************************ - -For locally-defined Ids, the code generator maintains its own notion -of their arities; so it should not be asking... (but other things -besides the code-generator need arity info!) - -\begin{code} --- | An 'ArityInfo' of @n@ tells us that partial application of this --- 'Id' to up to @n-1@ value arguments does essentially no work. --- --- That is not necessarily the same as saying that it has @n@ leading --- lambdas, because coerces may get in the way. --- --- The arity might increase later in the compilation process, if --- an extra lambda floats up to the binding site. -type ArityInfo = Arity - --- | It is always safe to assume that an 'Id' has an arity of 0 -unknownArity :: Arity -unknownArity = 0 :: Arity - -ppArityInfo :: Int -> SDoc -ppArityInfo 0 = empty -ppArityInfo n = hsep [ptext (sLit "Arity"), int n] -\end{code} - -%************************************************************************ -%* * -\subsection{Inline-pragma information} -%* * -%************************************************************************ - -\begin{code} --- | Tells when the inlining is active. --- When it is active the thing may be inlined, depending on how --- big it is. --- --- If there was an @INLINE@ pragma, then as a separate matter, the --- RHS will have been made to look small with a Core inline 'Note' --- --- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves --- entirely as a way to inhibit inlining until we want it -type InlinePragInfo = InlinePragma -\end{code} - - -%************************************************************************ -%* * - SpecInfo -%* * -%************************************************************************ - -\begin{code} --- | Records the specializations of this 'Id' that we know about --- in the form of rewrite 'CoreRule's that target them -data SpecInfo - = SpecInfo - [CoreRule] - VarSet -- Locally-defined free vars of *both* LHS and RHS - -- of rules. I don't think it needs to include the - -- ru_fn though. - -- Note [Rule dependency info] in OccurAnal - --- | Assume that no specilizations exist: always safe -emptySpecInfo :: SpecInfo -emptySpecInfo = SpecInfo [] emptyVarSet - -isEmptySpecInfo :: SpecInfo -> Bool -isEmptySpecInfo (SpecInfo rs _) = null rs - --- | Retrieve the locally-defined free variables of both the left and --- right hand sides of the specialization rules -specInfoFreeVars :: SpecInfo -> VarSet -specInfoFreeVars (SpecInfo _ fvs) = fvs - -specInfoRules :: SpecInfo -> [CoreRule] -specInfoRules (SpecInfo rules _) = rules - --- | Change the name of the function the rule is keyed on on all of the 'CoreRule's -setSpecInfoHead :: Name -> SpecInfo -> SpecInfo -setSpecInfoHead fn (SpecInfo rules fvs) - = SpecInfo (map (setRuleIdName fn) rules) fvs - -seqSpecInfo :: SpecInfo -> () -seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs -\end{code} - -%************************************************************************ -%* * -\subsection[worker-IdInfo]{Worker info about an @Id@} -%* * -%************************************************************************ - -There might not be a worker, even for a strict function, because: -(a) the function might be small enough to inline, so no need - for w/w split -(b) the strictness info might be "SSS" or something, so no w/w split. - -Sometimes the arity of a wrapper changes from the original arity from -which it was generated, so we always emit the "original" arity into -the interface file, as part of the worker info. - -How can this happen? Sometimes we get - f = coerce t (\x y -> $wf x y) -at the moment of w/w split; but the eta reducer turns it into - f = coerce t $wf -which is perfectly fine except that the exposed arity so far as -the code generator is concerned (zero) differs from the arity -when we did the split (2). - -All this arises because we use 'arity' to mean "exactly how many -top level lambdas are there" in interface files; but during the -compilation of this module it means "how many things can I apply -this to". - -\begin{code} - --- | If this Id has a worker then we store a reference to it. Worker --- functions are generated by the worker\/wrapper pass, using information --- information from strictness analysis. -data WorkerInfo = NoWorker -- ^ No known worker function - | HasWorker Id Arity -- ^ The 'Arity' is the arity of the /wrapper/ at the moment of the - -- worker\/wrapper split, which may be different from the current 'Id' 'Aritiy' - -seqWorker :: WorkerInfo -> () -seqWorker (HasWorker id a) = id `seq` a `seq` () -seqWorker NoWorker = () - -ppWorkerInfo :: WorkerInfo -> SDoc -ppWorkerInfo NoWorker = empty -ppWorkerInfo (HasWorker wk_id _) = ptext (sLit "Worker") <+> ppr wk_id - -workerExists :: WorkerInfo -> Bool -workerExists NoWorker = False -workerExists (HasWorker _ _) = True - --- | The 'Id' of the worker function if it exists, or a panic otherwise -workerId :: WorkerInfo -> Id -workerId (HasWorker id _) = id -workerId NoWorker = panic "workerId: NoWorker" - --- | The 'Arity' of the worker function at the time of the split if it exists, or a panic otherwise -wrapperArity :: WorkerInfo -> Arity -wrapperArity (HasWorker _ a) = a -wrapperArity NoWorker = panic "wrapperArity: NoWorker" -\end{code} - - -%************************************************************************ -%* * -\subsection[CG-IdInfo]{Code generator-related information} -%* * -%************************************************************************ - -\begin{code} --- CafInfo is used to build Static Reference Tables (see simplStg/SRT.lhs). - --- | Records whether an 'Id' makes Constant Applicative Form references -data CafInfo - = MayHaveCafRefs -- ^ Indicates that the 'Id' is for either: - -- - -- 1. A function or static constructor - -- that refers to one or more CAFs, or - -- - -- 2. A real live CAF - - | NoCafRefs -- ^ A function or static constructor - -- that refers to no CAFs. - deriving (Eq, Ord) - --- | Assumes that the 'Id' has CAF references: definitely safe -vanillaCafInfo :: CafInfo -vanillaCafInfo = MayHaveCafRefs - -mayHaveCafRefs :: CafInfo -> Bool -mayHaveCafRefs MayHaveCafRefs = True -mayHaveCafRefs _ = False - -seqCaf :: CafInfo -> () -seqCaf c = c `seq` () - -ppCafInfo :: CafInfo -> SDoc -ppCafInfo NoCafRefs = ptext (sLit "NoCafRefs") -ppCafInfo MayHaveCafRefs = empty -\end{code} - -%************************************************************************ -%* * -\subsection[cpr-IdInfo]{Constructed Product Result info about an @Id@} -%* * -%************************************************************************ - -\begin{code} -#ifdef OLD_STRICTNESS --- | If the @Id@ is a function then it may have Constructed Product Result --- (CPR) info. A CPR analysis phase detects whether: --- --- 1. The function's return value has a product type, i.e. an algebraic type --- with a single constructor. Examples of such types are tuples and boxed --- primitive values. --- --- 2. The function always 'constructs' the value that it is returning. It --- must do this on every path through, and it's OK if it calls another --- function which constructs the result. --- --- If this is the case then we store a template which tells us the --- function has the CPR property and which components of the result are --- also CPRs. -data CprInfo - = NoCPRInfo -- ^ No, this function does not return a constructed product - | ReturnsCPR -- ^ Yes, this function returns a constructed product - - -- Implicitly, this means "after the function has been applied - -- to all its arguments", so the worker\/wrapper builder in - -- WwLib.mkWWcpr checks that that it is indeed saturated before - -- making use of the CPR info - - -- We used to keep nested info about sub-components, but - -- we never used it so I threw it away - --- | It's always safe to assume that an 'Id' does not have the CPR property -noCprInfo :: CprInt -noCprInfo = NoCPRInfo - -seqCpr :: CprInfo -> () -seqCpr ReturnsCPR = () -seqCpr NoCPRInfo = () - -ppCprInfo NoCPRInfo = empty -ppCprInfo ReturnsCPR = ptext (sLit "__M") - -instance Outputable CprInfo where - ppr = ppCprInfo - -instance Show CprInfo where - showsPrec p c = showsPrecSDoc p (ppr c) -#endif -\end{code} - -%************************************************************************ -%* * -\subsection[lbvar-IdInfo]{Lambda-bound var info about an @Id@} -%* * -%************************************************************************ - -\begin{code} --- | If the 'Id' is a lambda-bound variable then it may have lambda-bound --- variable info. Sometimes we know whether the lambda binding this variable --- is a \"one-shot\" lambda; that is, whether it is applied at most once. --- --- This information may be useful in optimisation, as computations may --- safely be floated inside such a lambda without risk of duplicating --- work. -data LBVarInfo = NoLBVarInfo -- ^ No information - | IsOneShotLambda -- ^ The lambda is applied at most once). - --- | It is always safe to assume that an 'Id' has no lambda-bound variable information -noLBVarInfo :: LBVarInfo -noLBVarInfo = NoLBVarInfo - -hasNoLBVarInfo :: LBVarInfo -> Bool -hasNoLBVarInfo NoLBVarInfo = True -hasNoLBVarInfo IsOneShotLambda = False - -seqLBVar :: LBVarInfo -> () -seqLBVar l = l `seq` () - -pprLBVarInfo :: LBVarInfo -> SDoc -pprLBVarInfo NoLBVarInfo = empty -pprLBVarInfo IsOneShotLambda = ptext (sLit "OneShot") - -instance Outputable LBVarInfo where - ppr = pprLBVarInfo - -instance Show LBVarInfo where - showsPrec p c = showsPrecSDoc p (ppr c) -\end{code} - - -%************************************************************************ -%* * -\subsection{Bulk operations on IdInfo} -%* * -%************************************************************************ - -\begin{code} --- | This is used to remove information on lambda binders that we have --- setup as part of a lambda group, assuming they will be applied all at once, --- but turn out to be part of an unsaturated lambda as in e.g: --- --- > (\x1. \x2. e) arg1 -zapLamInfo :: IdInfo -> Maybe IdInfo -zapLamInfo info@(IdInfo {occInfo = occ, newDemandInfo = demand}) - | is_safe_occ occ && is_safe_dmd demand - = Nothing - | otherwise - = Just (info {occInfo = safe_occ, newDemandInfo = Nothing}) - where - -- The "unsafe" occ info is the ones that say I'm not in a lambda - -- because that might not be true for an unsaturated lambda - is_safe_occ (OneOcc in_lam _ _) = in_lam - is_safe_occ _other = True - - safe_occ = case occ of - OneOcc _ once int_cxt -> OneOcc insideLam once int_cxt - _other -> occ - - is_safe_dmd Nothing = True - is_safe_dmd (Just dmd) = not (isStrictDmd dmd) -\end{code} - -\begin{code} --- | Remove demand info on the 'IdInfo' if it is present, otherwise return @Nothing@ -zapDemandInfo :: IdInfo -> Maybe IdInfo -zapDemandInfo info@(IdInfo {newDemandInfo = dmd}) - | isJust dmd = Just (info {newDemandInfo = Nothing}) - | otherwise = Nothing -\end{code} - -\begin{code} -zapFragileInfo :: IdInfo -> Maybe IdInfo --- ^ Zap info that depends on free variables -zapFragileInfo info - = Just (info `setSpecInfo` emptySpecInfo - `setWorkerInfo` NoWorker - `setUnfoldingInfo` noUnfolding - `setOccInfo` if isFragileOcc occ then NoOccInfo else occ) - where - occ = occInfo info -\end{code} - -%************************************************************************ -%* * -\subsection{TickBoxOp} -%* * -%************************************************************************ - -\begin{code} -type TickBoxId = Int - --- | Tick box for Hpc-style coverage -data TickBoxOp - = TickBox Module {-# UNPACK #-} !TickBoxId - -instance Outputable TickBoxOp where - ppr (TickBox mod n) = ptext (sLit "tick") <+> ppr (mod,n) -\end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/IdInfo.lhs-boot ghc-6.13-20091231/compiler/basicTypes/IdInfo.lhs-boot --- ghc-6.12.1/compiler/basicTypes/IdInfo.lhs-boot 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/IdInfo.lhs-boot 1969-12-31 16:00:00.000000000 -0800 @@ -1,8 +0,0 @@ -\begin{code} -module IdInfo where -import Outputable -data IdInfo -data IdDetails - -pprIdDetails :: IdDetails -> SDoc -\end{code} \ No newline at end of file diff -ruN ghc-6.12.1/compiler/basicTypes/Id.lhs ghc-6.13-20091231/compiler/basicTypes/Id.lhs --- ghc-6.12.1/compiler/basicTypes/Id.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/Id.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,761 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[Id]{@Ids@: Value and constructor identifiers} - -\begin{code} --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id' represents names that not only have a 'Name.Name' but also a 'TypeRep.Type' and some additional --- details (a 'IdInfo.IdInfo' and one of 'Var.LocalIdDetails' or 'IdInfo.GlobalIdDetails') that --- are added, modified and inspected by various compiler passes. These 'Var.Var' names may either --- be global or local, see "Var#globalvslocal" --- --- * 'Var.Var': see "Var#name_types" -module Id ( - -- * The main types - Id, DictId, - - -- ** Simple construction - mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, - mkLocalId, mkLocalIdWithInfo, mkExportedLocalId, - mkSysLocal, mkSysLocalM, mkUserLocal, mkUserLocalM, - mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, - mkWorkerId, - - -- ** Taking an Id apart - idName, idType, idUnique, idInfo, idDetails, - isId, idPrimRep, - recordSelectorFieldLabel, - - -- ** Modifying an Id - setIdName, setIdUnique, Id.setIdType, - setIdExported, setIdNotExported, - globaliseId, localiseId, - setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, - zapLamIdInfo, zapDemandIdInfo, zapFragileIdInfo, transferPolyIdInfo, - - - -- ** Predicates on Ids - isImplicitId, isDeadBinder, isDictId, isStrictId, - isExportedId, isLocalId, isGlobalId, - isRecordSelector, isNaughtyRecordSelector, - isClassOpId_maybe, isDFunId, - isPrimOpId, isPrimOpId_maybe, - isFCallId, isFCallId_maybe, - isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon, - isConLikeId, isBottomingId, idIsFrom, - isTickBoxOp, isTickBoxOp_maybe, - hasNoBinding, - - -- ** Inline pragma stuff - idInlinePragma, setInlinePragma, modifyInlinePragma, - idInlineActivation, setInlineActivation, idRuleMatchInfo, - - -- ** One-shot lambdas - isOneShotBndr, isOneShotLambda, isStateHackType, - setOneShotLambda, clearOneShotLambda, - - -- ** Reading 'IdInfo' fields - idArity, - idNewDemandInfo, idNewDemandInfo_maybe, - idNewStrictness, idNewStrictness_maybe, - idWorkerInfo, - idUnfolding, - idSpecialisation, idCoreRules, idHasRules, - idCafInfo, - idLBVarInfo, - idOccInfo, - -#ifdef OLD_STRICTNESS - idDemandInfo, - idStrictness, - idCprInfo, -#endif - - -- ** Writing 'IdInfo' fields - setIdUnfolding, - setIdArity, - setIdNewDemandInfo, - setIdNewStrictness, zapIdNewStrictness, - setIdWorkerInfo, - setIdSpecialisation, - setIdCafInfo, - setIdOccInfo, zapIdOccInfo, - -#ifdef OLD_STRICTNESS - setIdStrictness, - setIdDemandInfo, - setIdCprInfo, -#endif - ) where - -#include "HsVersions.h" - -import CoreSyn ( CoreRule, Unfolding ) - -import IdInfo -import BasicTypes - --- Imported and re-exported -import Var( Var, Id, DictId, - idInfo, idDetails, globaliseId, - isId, isLocalId, isGlobalId, isExportedId ) -import qualified Var - -import TyCon -import Type -import TcType -import TysPrim -#ifdef OLD_STRICTNESS -import qualified Demand -#endif -import DataCon -import NewDemand -import Name -import Module -import Class -import PrimOp -import ForeignCall -import Maybes -import SrcLoc -import Outputable -import Unique -import UniqSupply -import FastString -import Util( count ) -import StaticFlags - --- infixl so you can say (id `set` a `set` b) -infixl 1 `setIdUnfolding`, - `setIdArity`, - `setIdNewDemandInfo`, - `setIdNewStrictness`, - `setIdWorkerInfo`, - `setIdSpecialisation`, - `setInlinePragma`, - `idCafInfo` -#ifdef OLD_STRICTNESS - ,`idCprInfo` - ,`setIdStrictness` - ,`setIdDemandInfo` -#endif -\end{code} - -%************************************************************************ -%* * -\subsection{Basic Id manipulation} -%* * -%************************************************************************ - -\begin{code} -idName :: Id -> Name -idName = Var.varName - -idUnique :: Id -> Unique -idUnique = Var.varUnique - -idType :: Id -> Kind -idType = Var.varType - -idPrimRep :: Id -> PrimRep -idPrimRep id = typePrimRep (idType id) - -setIdName :: Id -> Name -> Id -setIdName = Var.setVarName - -setIdUnique :: Id -> Unique -> Id -setIdUnique = Var.setVarUnique - --- | Not only does this set the 'Id' 'Type', it also evaluates the type to try and --- reduce space usage -setIdType :: Id -> Type -> Id -setIdType id ty = seqType ty `seq` Var.setVarType id ty - -setIdExported :: Id -> Id -setIdExported = Var.setIdExported - -setIdNotExported :: Id -> Id -setIdNotExported = Var.setIdNotExported - -localiseId :: Id -> Id --- Make an with the same unique and type as the --- incoming Id, but with an *Internal* Name and *LocalId* flavour -localiseId id - | isLocalId id && isInternalName name - = id - | otherwise - = mkLocalIdWithInfo (localiseName name) (idType id) (idInfo id) - where - name = idName id - -lazySetIdInfo :: Id -> IdInfo -> Id -lazySetIdInfo = Var.lazySetIdInfo - -setIdInfo :: Id -> IdInfo -> Id -setIdInfo id info = seqIdInfo info `seq` (lazySetIdInfo id info) - -- Try to avoid spack leaks by seq'ing - -modifyIdInfo :: (IdInfo -> IdInfo) -> Id -> Id -modifyIdInfo fn id = setIdInfo id (fn (idInfo id)) - --- maybeModifyIdInfo tries to avoid unnecesary thrashing -maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id -maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info -maybeModifyIdInfo Nothing id = id -\end{code} - -%************************************************************************ -%* * -\subsection{Simple Id construction} -%* * -%************************************************************************ - -Absolutely all Ids are made by mkId. It is just like Var.mkId, -but in addition it pins free-tyvar-info onto the Id's type, -where it can easily be found. - -Note [Free type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -At one time we cached the free type variables of the type of an Id -at the root of the type in a TyNote. The idea was to avoid repeating -the free-type-variable calculation. But it turned out to slow down -the compiler overall. I don't quite know why; perhaps finding free -type variables of an Id isn't all that common whereas applying a -substitution (which changes the free type variables) is more common. -Anyway, we removed it in March 2008. - -\begin{code} --- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" -mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id -mkGlobalId = Var.mkGlobalVar - --- | Make a global 'Id' without any extra information at all -mkVanillaGlobal :: Name -> Type -> Id -mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo - --- | Make a global 'Id' with no global information but some generic 'IdInfo' -mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id -mkVanillaGlobalWithInfo = mkGlobalId VanillaId - - --- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" -mkLocalId :: Name -> Type -> Id -mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo - -mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id -mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info - -- Note [Free type variables] - --- | Create a local 'Id' that is marked as exported. --- This prevents things attached to it from being removed as dead code. -mkExportedLocalId :: Name -> Type -> Id -mkExportedLocalId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo - -- Note [Free type variables] - - --- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") --- that are created by the compiler out of thin air -mkSysLocal :: FastString -> Unique -> Type -> Id -mkSysLocal fs uniq ty = mkLocalId (mkSystemVarName uniq fs) ty - -mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id -mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty)) - - --- | Create a user local 'Id'. These are local 'Id's (see "Var#globalvslocal") with a name and location that the user might recognize -mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id -mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty - -mkUserLocalM :: MonadUnique m => OccName -> Type -> SrcSpan -> m Id -mkUserLocalM occ ty loc = getUniqueM >>= (\uniq -> return (mkUserLocal occ uniq ty loc)) - -\end{code} - -Make some local @Ids@ for a template @CoreExpr@. These have bogus -@Uniques@, but that's OK because the templates are supposed to be -instantiated before use. - -\begin{code} --- | Workers get local names. "CoreTidy" will externalise these if necessary -mkWorkerId :: Unique -> Id -> Type -> Id -mkWorkerId uniq unwrkr ty - = mkLocalId wkr_name ty - where - wkr_name = mkInternalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcSpan unwrkr) - --- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings -mkTemplateLocal :: Int -> Type -> Id -mkTemplateLocal i ty = mkSysLocal (fsLit "tpl") (mkBuiltinUnique i) ty - --- | Create a template local for a series of types -mkTemplateLocals :: [Type] -> [Id] -mkTemplateLocals = mkTemplateLocalsNum 1 - --- | Create a template local for a series of type, but start from a specified template local -mkTemplateLocalsNum :: Int -> [Type] -> [Id] -mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys -\end{code} - - -%************************************************************************ -%* * -\subsection{Special Ids} -%* * -%************************************************************************ - -\begin{code} --- | If the 'Id' is that for a record selector, extract the 'sel_tycon' and label. Panic otherwise -recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel) -recordSelectorFieldLabel id - = case Var.idDetails id of - RecSelId { sel_tycon = tycon } -> (tycon, idName id) - _ -> panic "recordSelectorFieldLabel" - -isRecordSelector :: Id -> Bool -isNaughtyRecordSelector :: Id -> Bool -isPrimOpId :: Id -> Bool -isFCallId :: Id -> Bool -isDataConWorkId :: Id -> Bool -isDFunId :: Id -> Bool - -isClassOpId_maybe :: Id -> Maybe Class -isPrimOpId_maybe :: Id -> Maybe PrimOp -isFCallId_maybe :: Id -> Maybe ForeignCall -isDataConWorkId_maybe :: Id -> Maybe DataCon - -isRecordSelector id = case Var.idDetails id of - RecSelId {} -> True - _ -> False - -isNaughtyRecordSelector id = case Var.idDetails id of - RecSelId { sel_naughty = n } -> n - _ -> False - -isClassOpId_maybe id = case Var.idDetails id of - ClassOpId cls -> Just cls - _other -> Nothing - -isPrimOpId id = case Var.idDetails id of - PrimOpId _ -> True - _ -> False - -isDFunId id = case Var.idDetails id of - DFunId -> True - _ -> False - -isPrimOpId_maybe id = case Var.idDetails id of - PrimOpId op -> Just op - _ -> Nothing - -isFCallId id = case Var.idDetails id of - FCallId _ -> True - _ -> False - -isFCallId_maybe id = case Var.idDetails id of - FCallId call -> Just call - _ -> Nothing - -isDataConWorkId id = case Var.idDetails id of - DataConWorkId _ -> True - _ -> False - -isDataConWorkId_maybe id = case Var.idDetails id of - DataConWorkId con -> Just con - _ -> Nothing - -isDataConId_maybe :: Id -> Maybe DataCon -isDataConId_maybe id = case Var.idDetails id of - DataConWorkId con -> Just con - DataConWrapId con -> Just con - _ -> Nothing - -idDataCon :: Id -> DataCon --- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer. --- --- 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. - --- Data constructor workers used to be things of this kind, but --- they aren't any more. Instead, we inject a binding for --- them at the CorePrep stage. --- EXCEPT: unboxed tuples, which definitely have no binding -hasNoBinding id = case Var.idDetails id of - PrimOpId _ -> True -- See Note [Primop wrappers] - FCallId _ -> True - DataConWorkId dc -> isUnboxedTupleCon dc - _ -> False - -isImplicitId :: Id -> Bool --- ^ 'isImplicitId' tells whether an 'Id's info is implied by other --- declarations, so we don't need to put its signature in an interface --- file, even if it's mentioned in some other interface unfolding. -isImplicitId id - = case Var.idDetails id of - FCallId _ -> True - ClassOpId _ -> True - PrimOpId _ -> True - DataConWorkId _ -> True - DataConWrapId _ -> True - -- These are are implied by their type or class decl; - -- remember that all type and class decls appear in the interface file. - -- The dfun id is not an implicit Id; it must *not* be omitted, because - -- it carries version info for the instance decl - _ -> False - -idIsFrom :: Module -> Id -> Bool -idIsFrom mod id = nameIsLocalOrFrom mod (idName id) -\end{code} - -Note [Primop wrappers] -~~~~~~~~~~~~~~~~~~~~~~ -Currently hasNoBinding claims that PrimOpIds don't have a curried -function definition. But actually they do, in GHC.PrimopWrappers, -which is auto-generated from prelude/primops.txt.pp. So actually, hasNoBinding -could return 'False' for PrimOpIds. - -But we'd need to add something in CoreToStg to swizzle any unsaturated -applications of GHC.Prim.plusInt# to GHC.PrimopWrappers.plusInt#. - -Nota Bene: GHC.PrimopWrappers is needed *regardless*, because it's -used by GHCi, which does not implement primops direct at all. - - - -\begin{code} -isDeadBinder :: Id -> Bool -isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) - | otherwise = False -- TyVars count as not dead -\end{code} - -\begin{code} -isTickBoxOp :: Id -> Bool -isTickBoxOp id = - case Var.idDetails id of - TickBoxOpId _ -> True - _ -> False - -isTickBoxOp_maybe :: Id -> Maybe TickBoxOp -isTickBoxOp_maybe id = - case Var.idDetails id of - TickBoxOpId tick -> Just tick - _ -> Nothing -\end{code} - -%************************************************************************ -%* * -\subsection{IdInfo stuff} -%* * -%************************************************************************ - -\begin{code} - --------------------------------- - -- ARITY -idArity :: Id -> Arity -idArity id = arityInfo (idInfo id) - -setIdArity :: Id -> Arity -> Id -setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id - -#ifdef OLD_STRICTNESS - --------------------------------- - -- (OLD) STRICTNESS -idStrictness :: Id -> StrictnessInfo -idStrictness id = strictnessInfo (idInfo id) - -setIdStrictness :: Id -> StrictnessInfo -> Id -setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id -#endif - --- | Returns true if an application to n args would diverge -isBottomingId :: Id -> Bool -isBottomingId id = isBottomingSig (idNewStrictness id) - -idNewStrictness_maybe :: Id -> Maybe StrictSig -idNewStrictness :: Id -> StrictSig - -idNewStrictness_maybe id = newStrictnessInfo (idInfo id) -idNewStrictness id = idNewStrictness_maybe id `orElse` topSig - -setIdNewStrictness :: Id -> StrictSig -> Id -setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id - -zapIdNewStrictness :: Id -> Id -zapIdNewStrictness id = modifyIdInfo (`setNewStrictnessInfo` Nothing) id - --- | This predicate says whether the 'Id' has a strict demand placed on it or --- has a type such that it can always be evaluated strictly (e.g., an --- unlifted type, but see the comment for 'isStrictType'). We need to --- check separately whether the 'Id' has a so-called \"strict type\" because if --- the demand for the given @id@ hasn't been computed yet but @id@ has a strict --- type, we still want @isStrictId id@ to be @True@. -isStrictId :: Id -> Bool -isStrictId id - = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id ) - (isStrictDmd (idNewDemandInfo id)) || - (isStrictType (idType id)) - - --------------------------------- - -- WORKER ID -idWorkerInfo :: Id -> WorkerInfo -idWorkerInfo id = workerInfo (idInfo id) - -setIdWorkerInfo :: Id -> WorkerInfo -> Id -setIdWorkerInfo id work_info = modifyIdInfo (`setWorkerInfo` work_info) id - - --------------------------------- - -- UNFOLDING -idUnfolding :: Id -> Unfolding -idUnfolding id = unfoldingInfo (idInfo id) - -setIdUnfolding :: Id -> Unfolding -> Id -setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id - -#ifdef OLD_STRICTNESS - --------------------------------- - -- (OLD) DEMAND -idDemandInfo :: Id -> Demand.Demand -idDemandInfo id = demandInfo (idInfo id) - -setIdDemandInfo :: Id -> Demand.Demand -> Id -setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id -#endif - -idNewDemandInfo_maybe :: Id -> Maybe NewDemand.Demand -idNewDemandInfo :: Id -> NewDemand.Demand - -idNewDemandInfo_maybe id = newDemandInfo (idInfo id) -idNewDemandInfo id = newDemandInfo (idInfo id) `orElse` NewDemand.topDmd - -setIdNewDemandInfo :: Id -> NewDemand.Demand -> Id -setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` Just dmd) id - - --------------------------------- - -- SPECIALISATION -idSpecialisation :: Id -> SpecInfo -idSpecialisation id = specInfo (idInfo id) - -idCoreRules :: Id -> [CoreRule] -idCoreRules id = specInfoRules (idSpecialisation id) - -idHasRules :: Id -> Bool -idHasRules id = not (isEmptySpecInfo (idSpecialisation id)) - -setIdSpecialisation :: Id -> SpecInfo -> Id -setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id - - --------------------------------- - -- CAF INFO -idCafInfo :: Id -> CafInfo -#ifdef OLD_STRICTNESS -idCafInfo id = case cgInfo (idInfo id) of - NoCgInfo -> pprPanic "idCafInfo" (ppr id) - info -> cgCafInfo info -#else -idCafInfo id = cafInfo (idInfo id) -#endif - -setIdCafInfo :: Id -> CafInfo -> Id -setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id - - --------------------------------- - -- CPR INFO -#ifdef OLD_STRICTNESS -idCprInfo :: Id -> CprInfo -idCprInfo id = cprInfo (idInfo id) - -setIdCprInfo :: Id -> CprInfo -> Id -setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id -#endif - - --------------------------------- - -- Occcurrence INFO -idOccInfo :: Id -> OccInfo -idOccInfo id = occInfo (idInfo id) - -setIdOccInfo :: Id -> OccInfo -> Id -setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id - -zapIdOccInfo :: Id -> Id -zapIdOccInfo b = b `setIdOccInfo` NoOccInfo -\end{code} - - - --------------------------------- - -- INLINING -The inline pragma tells us to be very keen to inline this Id, but it's still -OK not to if optimisation is switched off. - -\begin{code} -idInlinePragma :: Id -> InlinePragma -idInlinePragma id = inlinePragInfo (idInfo id) - -setInlinePragma :: Id -> InlinePragma -> Id -setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id - -modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id -modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id - -idInlineActivation :: Id -> Activation -idInlineActivation id = inlinePragmaActivation (idInlinePragma id) - -setInlineActivation :: Id -> Activation -> Id -setInlineActivation id act = modifyInlinePragma id (\(InlinePragma _ match_info) -> InlinePragma act match_info) - -idRuleMatchInfo :: Id -> RuleMatchInfo -idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id) - -isConLikeId :: Id -> Bool -isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id) -\end{code} - - - --------------------------------- - -- ONE-SHOT LAMBDAS -\begin{code} -idLBVarInfo :: Id -> LBVarInfo -idLBVarInfo id = lbvarInfo (idInfo id) - --- | Returns whether the lambda associated with the 'Id' is certainly applied at most once --- OR we are applying the \"state hack\" which makes it appear as if theis is the case for --- lambdas used in @IO@. You should prefer using this over 'isOneShotLambda' -isOneShotBndr :: Id -> Bool --- This one is the "business end", called externally. --- Its main purpose is to encapsulate the Horrible State Hack -isOneShotBndr id = isOneShotLambda id || isStateHackType (idType id) - --- | Should we apply the state hack to values of this 'Type'? -isStateHackType :: Type -> Bool -isStateHackType ty - | opt_NoStateHack - = False - | otherwise - = case splitTyConApp_maybe ty of - Just (tycon,_) -> tycon == statePrimTyCon - _ -> False - -- This is a gross hack. It claims that - -- every function over realWorldStatePrimTy is a one-shot - -- function. This is pretty true in practice, and makes a big - -- difference. For example, consider - -- a `thenST` \ r -> ...E... - -- The early full laziness pass, if it doesn't know that r is one-shot - -- will pull out E (let's say it doesn't mention r) to give - -- let lvl = E in a `thenST` \ r -> ...lvl... - -- When `thenST` gets inlined, we end up with - -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... - -- and we don't re-inline E. - -- - -- It would be better to spot that r was one-shot to start with, but - -- I don't want to rely on that. - -- - -- Another good example is in fill_in in PrelPack.lhs. We should be able to - -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. - - --- | Returns whether the lambda associated with the 'Id' is certainly applied at most once. --- You probably want to use 'isOneShotBndr' instead -isOneShotLambda :: Id -> Bool -isOneShotLambda id = case idLBVarInfo id of - IsOneShotLambda -> True - NoLBVarInfo -> False - -setOneShotLambda :: Id -> Id -setOneShotLambda id = modifyIdInfo (`setLBVarInfo` IsOneShotLambda) id - -clearOneShotLambda :: Id -> Id -clearOneShotLambda id - | isOneShotLambda id = modifyIdInfo (`setLBVarInfo` NoLBVarInfo) id - | otherwise = id - --- The OneShotLambda functions simply fiddle with the IdInfo flag --- But watch out: this may change the type of something else --- f = \x -> e --- If we change the one-shot-ness of x, f's type changes -\end{code} - -\begin{code} -zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id -zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id - -zapLamIdInfo :: Id -> Id -zapLamIdInfo = zapInfo zapLamInfo - -zapDemandIdInfo :: Id -> Id -zapDemandIdInfo = zapInfo zapDemandInfo - -zapFragileIdInfo :: Id -> Id -zapFragileIdInfo = zapInfo zapFragileInfo -\end{code} - -Note [transferPolyIdInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - f = /\a. let g = rhs in ... - -where g has interesting strictness information. Then if we float thus - - g' = /\a. rhs - f = /\a. ...[g' a/g] - -we *do not* want to lose g's - * strictness information - * arity - * inline pragma (though that is bit more debatable) - -It's simple to retain strictness and arity, but not so simple to retain - * worker info - * rules -so we simply discard those. Sooner or later this may bite us. - -This transfer is used in two places: - FloatOut (long-distance let-floating) - SimplUtils.abstractFloats (short-distance let-floating) - -If we abstract wrt one or more *value* binders, we must modify the -arity and strictness info before transferring it. E.g. - f = \x. e ---> - g' = \y. \x. e - + substitute (g' y) for g -Notice that g' has an arity one more than the original g - -\begin{code} -transferPolyIdInfo :: Id -- Original Id - -> [Var] -- Abstract wrt these variables - -> Id -- New Id - -> Id -transferPolyIdInfo old_id abstract_wrt new_id - = modifyIdInfo transfer new_id - where - arity_increase = count isId abstract_wrt -- Arity increases by the - -- number of value binders - - old_info = idInfo old_id - old_arity = arityInfo old_info - old_inline_prag = inlinePragInfo old_info - new_arity = old_arity + arity_increase - old_strictness = newStrictnessInfo old_info - new_strictness = fmap (increaseStrictSigArity arity_increase) old_strictness - - transfer new_info = new_info `setNewStrictnessInfo` new_strictness - `setArityInfo` new_arity - `setInlinePragInfo` old_inline_prag -\end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/Literal.lhs ghc-6.13-20091231/compiler/basicTypes/Literal.lhs --- ghc-6.12.1/compiler/basicTypes/Literal.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/Literal.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,419 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1998 -% -\section[Literal]{@Literal@: Machine literals (unboxed, of course)} - -\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 Literal - ( - -- * Main data type - Literal(..) -- Exported to ParseIface - - -- ** Creating Literals - , mkMachInt, mkMachWord - , mkMachInt64, mkMachWord64 - , mkMachFloat, mkMachDouble - , mkMachChar, mkMachString - - -- ** Operations on Literals - , literalType - , hashLiteral - - -- ** Predicates on Literals and their contents - , litIsDupable, litIsTrivial - , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange - , isZeroLit - , litFitsInChar - - -- ** Coercions - , word2IntLit, int2WordLit - , narrow8IntLit, narrow16IntLit, narrow32IntLit - , narrow8WordLit, narrow16WordLit, narrow32WordLit - , char2IntLit, int2CharLit - , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit - , nullAddrLit, float2DoubleLit, double2FloatLit - ) where - -import TysPrim -import Type -import Outputable -import FastTypes -import FastString -import BasicTypes -import Binary -import Constants - -import Data.Int -import Data.Ratio -import Data.Word -import Data.Char -\end{code} - - -%************************************************************************ -%* * -\subsection{Literals} -%* * -%************************************************************************ - -\begin{code} --- | So-called 'Literal's are one of: --- --- * An unboxed (/machine/) literal ('MachInt', 'MachFloat', etc.), --- which is presumed to be surrounded by appropriate constructors --- (@Int#@, etc.), so that the overall thing makes sense. --- --- * The literal derived from the label mentioned in a \"foreign label\" --- declaration ('MachLabel') -data Literal - = ------------------ - -- First the primitive guys - MachChar Char -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar' - - | MachStr FastString -- ^ A string-literal: stored and emitted - -- UTF-8 encoded, we'll arrange to decode it - -- at runtime. Also emitted with a @'\0'@ - -- terminator. Create with 'mkMachString' - - | MachNullAddr -- ^ The @NULL@ pointer, the only pointer value - -- that can be represented as a Literal. Create - -- with 'nullAddrLit' - - | MachInt Integer -- ^ @Int#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachInt' - | MachInt64 Integer -- ^ @Int64#@ - at least 64 bits. Create with 'mkMachInt64' - | MachWord Integer -- ^ @Word#@ - at least @WORD_SIZE_IN_BITS@ bits. Create with 'mkMachWord' - | MachWord64 Integer -- ^ @Word64#@ - at least 64 bits. Create with 'mkMachWord64' - - | MachFloat Rational -- ^ @Float#@. Create with 'mkMachFloat' - | MachDouble Rational -- ^ @Double#@. Create with 'mkMachDouble' - - | MachLabel FastString - (Maybe Int) - FunctionOrData - -- ^ A label literal. Parameters: - -- - -- 1) The name of the symbol mentioned in the declaration - -- - -- 2) The size (in bytes) of the arguments - -- the label expects. Only applicable with - -- @stdcall@ labels. @Just x@ => @\@ will - -- be appended to label name when emitting assembly. -\end{code} - -Binary instance - -\begin{code} -instance Binary Literal where - put_ bh (MachChar aa) = do putByte bh 0; put_ bh aa - put_ bh (MachStr ab) = do putByte bh 1; put_ bh ab - put_ bh (MachNullAddr) = do putByte bh 2 - put_ bh (MachInt ad) = do putByte bh 3; put_ bh ad - put_ bh (MachInt64 ae) = do putByte bh 4; put_ bh ae - put_ bh (MachWord af) = do putByte bh 5; put_ bh af - put_ bh (MachWord64 ag) = do putByte bh 6; put_ bh ag - put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah - put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai - put_ bh (MachLabel aj mb fod) - = do putByte bh 9 - put_ bh aj - put_ bh mb - put_ bh fod - get bh = do - h <- getByte bh - case h of - 0 -> do - aa <- get bh - return (MachChar aa) - 1 -> do - ab <- get bh - return (MachStr ab) - 2 -> do - return (MachNullAddr) - 3 -> do - ad <- get bh - return (MachInt ad) - 4 -> do - ae <- get bh - return (MachInt64 ae) - 5 -> do - af <- get bh - return (MachWord af) - 6 -> do - ag <- get bh - return (MachWord64 ag) - 7 -> do - ah <- get bh - return (MachFloat ah) - 8 -> do - ai <- get bh - return (MachDouble ai) - 9 -> do - aj <- get bh - mb <- get bh - fod <- get bh - return (MachLabel aj mb fod) -\end{code} - -\begin{code} -instance Outputable Literal where - ppr lit = pprLit lit - -instance Show Literal where - showsPrec p lit = showsPrecSDoc p (ppr lit) - -instance Eq Literal where - a == b = case (a `compare` b) of { EQ -> True; _ -> False } - a /= b = case (a `compare` b) of { EQ -> False; _ -> True } - -instance Ord Literal 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 = cmpLit a b -\end{code} - - - Construction - ~~~~~~~~~~~~ -\begin{code} --- | Creates a 'Literal' of type @Int#@ -mkMachInt :: Integer -> Literal -mkMachInt x = -- ASSERT2( inIntRange x, integer x ) - -- Not true: you can write out of range Int# literals - -- For example, one can write (intToWord# 0xffff0000) to - -- get a particular Word bit-pattern, and there's no other - -- convenient way to write such literals, which is why we allow it. - MachInt x - --- | Creates a 'Literal' of type @Word#@ -mkMachWord :: Integer -> Literal -mkMachWord x = -- ASSERT2( inWordRange x, integer x ) - MachWord x - --- | Creates a 'Literal' of type @Int64#@ -mkMachInt64 :: Integer -> Literal -mkMachInt64 x = MachInt64 x - --- | Creates a 'Literal' of type @Word64#@ -mkMachWord64 :: Integer -> Literal -mkMachWord64 x = MachWord64 x - --- | Creates a 'Literal' of type @Float#@ -mkMachFloat :: Rational -> Literal -mkMachFloat = MachFloat - --- | Creates a 'Literal' of type @Double#@ -mkMachDouble :: Rational -> Literal -mkMachDouble = MachDouble - --- | Creates a 'Literal' of type @Char#@ -mkMachChar :: Char -> Literal -mkMachChar = MachChar - --- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to --- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@ -mkMachString :: String -> Literal -mkMachString s = MachStr (mkFastString s) -- stored UTF-8 encoded - -inIntRange, inWordRange :: Integer -> Bool -inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT -inWordRange x = x >= 0 && x <= tARGET_MAX_WORD - -inCharRange :: Char -> Bool -inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR - --- | Tests whether the literal represents a zero of whatever type it is -isZeroLit :: Literal -> Bool -isZeroLit (MachInt 0) = True -isZeroLit (MachInt64 0) = True -isZeroLit (MachWord 0) = True -isZeroLit (MachWord64 0) = True -isZeroLit (MachFloat 0) = True -isZeroLit (MachDouble 0) = True -isZeroLit _ = False -\end{code} - - Coercions - ~~~~~~~~~ -\begin{code} -word2IntLit, int2WordLit, - narrow8IntLit, narrow16IntLit, narrow32IntLit, - narrow8WordLit, narrow16WordLit, narrow32WordLit, - char2IntLit, int2CharLit, - float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit, - float2DoubleLit, double2FloatLit - :: Literal -> Literal - -word2IntLit (MachWord w) - | w > tARGET_MAX_INT = MachInt (w - tARGET_MAX_WORD - 1) - | otherwise = MachInt w - -int2WordLit (MachInt i) - | i < 0 = MachWord (1 + tARGET_MAX_WORD + i) -- (-1) ---> tARGET_MAX_WORD - | otherwise = MachWord i - -narrow8IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int8)) -narrow16IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int16)) -narrow32IntLit (MachInt i) = MachInt (toInteger (fromInteger i :: Int32)) -narrow8WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word8)) -narrow16WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16)) -narrow32WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32)) - -char2IntLit (MachChar c) = MachInt (toInteger (ord c)) -int2CharLit (MachInt i) = MachChar (chr (fromInteger i)) - -float2IntLit (MachFloat f) = MachInt (truncate f) -int2FloatLit (MachInt i) = MachFloat (fromInteger i) - -double2IntLit (MachDouble f) = MachInt (truncate f) -int2DoubleLit (MachInt i) = MachDouble (fromInteger i) - -float2DoubleLit (MachFloat f) = MachDouble f -double2FloatLit (MachDouble d) = MachFloat d - -nullAddrLit :: Literal -nullAddrLit = MachNullAddr -\end{code} - - Predicates - ~~~~~~~~~~ -\begin{code} --- | True if there is absolutely no penalty to duplicating the literal. --- False principally of strings -litIsTrivial :: Literal -> Bool --- c.f. CoreUtils.exprIsTrivial -litIsTrivial (MachStr _) = False -litIsTrivial _ = True - --- | True if code space does not go bad if we duplicate this literal --- Currently we treat it just like 'litIsTrivial' -litIsDupable :: Literal -> Bool --- c.f. CoreUtils.exprIsDupable -litIsDupable (MachStr _) = False -litIsDupable _ = True - -litFitsInChar :: Literal -> Bool -litFitsInChar (MachInt i) - = fromInteger i <= ord minBound - && fromInteger i >= ord maxBound -litFitsInChar _ = False -\end{code} - - Types - ~~~~~ -\begin{code} --- | Find the Haskell 'Type' the literal occupies -literalType :: Literal -> Type -literalType MachNullAddr = addrPrimTy -literalType (MachChar _) = charPrimTy -literalType (MachStr _) = addrPrimTy -literalType (MachInt _) = intPrimTy -literalType (MachWord _) = wordPrimTy -literalType (MachInt64 _) = int64PrimTy -literalType (MachWord64 _) = word64PrimTy -literalType (MachFloat _) = floatPrimTy -literalType (MachDouble _) = doublePrimTy -literalType (MachLabel _ _ _) = addrPrimTy -\end{code} - - - Comparison - ~~~~~~~~~~ -\begin{code} -cmpLit :: Literal -> Literal -> Ordering -cmpLit (MachChar a) (MachChar b) = a `compare` b -cmpLit (MachStr a) (MachStr b) = a `compare` b -cmpLit (MachNullAddr) (MachNullAddr) = EQ -cmpLit (MachInt a) (MachInt b) = a `compare` b -cmpLit (MachWord a) (MachWord b) = a `compare` b -cmpLit (MachInt64 a) (MachInt64 b) = a `compare` b -cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b -cmpLit (MachFloat a) (MachFloat b) = a `compare` b -cmpLit (MachDouble a) (MachDouble b) = a `compare` b -cmpLit (MachLabel a _ _) (MachLabel b _ _) = a `compare` b -cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT - | otherwise = GT - -litTag :: Literal -> FastInt -litTag (MachChar _) = _ILIT(1) -litTag (MachStr _) = _ILIT(2) -litTag (MachNullAddr) = _ILIT(3) -litTag (MachInt _) = _ILIT(4) -litTag (MachWord _) = _ILIT(5) -litTag (MachInt64 _) = _ILIT(6) -litTag (MachWord64 _) = _ILIT(7) -litTag (MachFloat _) = _ILIT(8) -litTag (MachDouble _) = _ILIT(9) -litTag (MachLabel _ _ _) = _ILIT(10) -\end{code} - - Printing - ~~~~~~~~ -* MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo") - exceptions: MachFloat gets an initial keyword prefix. - -\begin{code} -pprLit :: Literal -> SDoc -pprLit (MachChar ch) = pprHsChar ch -pprLit (MachStr s) = pprHsString s -pprLit (MachInt i) = pprIntVal i -pprLit (MachInt64 i) = ptext (sLit "__int64") <+> integer i -pprLit (MachWord w) = ptext (sLit "__word") <+> integer w -pprLit (MachWord64 w) = ptext (sLit "__word64") <+> integer w -pprLit (MachFloat f) = ptext (sLit "__float") <+> rational f -pprLit (MachDouble d) = rational d -pprLit (MachNullAddr) = ptext (sLit "__NULL") -pprLit (MachLabel l mb fod) = ptext (sLit "__label") <+> b <+> ppr fod - where b = case mb of - Nothing -> pprHsString l - Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) - -pprIntVal :: Integer -> SDoc --- ^ Print negative integers with parens to be sure it's unambiguous -pprIntVal i | i < 0 = parens (integer i) - | otherwise = integer i -\end{code} - - -%************************************************************************ -%* * -\subsection{Hashing} -%* * -%************************************************************************ - -Hash values should be zero or a positive integer. No negatives please. -(They mess up the UniqFM for some reason.) - -\begin{code} -hashLiteral :: Literal -> Int -hashLiteral (MachChar c) = ord c + 1000 -- Keep it out of range of common ints -hashLiteral (MachStr s) = hashFS s -hashLiteral (MachNullAddr) = 0 -hashLiteral (MachInt i) = hashInteger i -hashLiteral (MachInt64 i) = hashInteger i -hashLiteral (MachWord i) = hashInteger i -hashLiteral (MachWord64 i) = hashInteger i -hashLiteral (MachFloat r) = hashRational r -hashLiteral (MachDouble r) = hashRational r -hashLiteral (MachLabel s _ _) = hashFS s - -hashRational :: Rational -> Int -hashRational r = hashInteger (numerator r) - -hashInteger :: Integer -> Int -hashInteger i = 1 + abs (fromInteger (i `rem` 10000)) - -- The 1+ is to avoid zero, which is a Bad Number - -- since we use * to combine hash values - -hashFS :: FastString -> Int -hashFS s = iBox (uniqueOfFS s) -\end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/MkId.lhs ghc-6.13-20091231/compiler/basicTypes/MkId.lhs --- ghc-6.12.1/compiler/basicTypes/MkId.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/MkId.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,1110 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The AQUA Project, Glasgow University, 1998 -% - -This module contains definitions for the IdInfo for things that -have a standard form, namely: - -- data constructors -- record selectors -- method and superclass selectors -- primitive operations - -\begin{code} -{-# OPTIONS -fno-warn-missing-signatures #-} --- 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 --- --- for details - -module MkId ( - mkDictFunId, mkDefaultMethodId, - mkDictSelId, - - mkDataConIds, - mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId, - - mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody, - wrapFamInstBody, unwrapFamInstScrut, - mkUnpackCase, mkProductBox, - - -- And some particular Ids; see below for why they are wired in - wiredInIds, ghcPrimIds, - unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId, - lazyId, lazyIdKey, - - mkRuntimeErrorApp, mkImpossibleExpr, - rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID, - nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, - pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID, - - unsafeCoerceName - ) where - -#include "HsVersions.h" - -import Rules -import TysPrim -import TysWiredIn -import PrelRules -import Type -import Coercion -import TcType -import CoreUtils ( exprType, mkCoerce ) -import CoreUnfold -import Literal -import TyCon -import Class -import VarSet -import Name -import PrimOp -import ForeignCall -import DataCon -import Id -import Var ( Var, TyVar, mkCoVar, mkExportedLocalVar ) -import IdInfo -import NewDemand -import CoreSyn -import Unique -import PrelNames -import BasicTypes hiding ( SuccessFlag(..) ) -import Util -import Outputable -import FastString -import ListSetOps -import Module -\end{code} - -%************************************************************************ -%* * -\subsection{Wired in Ids} -%* * -%************************************************************************ - -Note [Wired-in Ids] -~~~~~~~~~~~~~~~~~~~ -There are several reasons why an Id might appear in the wiredInIds: - -(1) The ghcPrimIds are wired in because they can't be defined in - Haskell at all, although the can be defined in Core. They have - compulsory unfoldings, so they are always inlined and they have - no definition site. Their home module is GHC.Prim, so they - also have a description in primops.txt.pp, where they are called - 'pseudoops'. - -(2) The 'error' function, eRROR_ID, is wired in because we don't yet have - a way to express in an interface file that the result type variable - is 'open'; that is can be unified with an unboxed type - - [The interface file format now carry such information, but there's - no way yet of expressing at the definition site for these - error-reporting functions that they have an 'open' - result type. -- sof 1/99] - -(3) Other error functions (rUNTIME_ERROR_ID) are wired in (a) because - the desugarer generates code that mentiones them directly, and - (b) for the same reason as eRROR_ID - -(4) lazyId is wired in because the wired-in version overrides the - strictness of the version defined in GHC.Base - -In cases (2-4), the function has a definition in a library module, and -can be called; but the wired-in version means that the details are -never read from that module's interface file; instead, the full definition -is right here. - -\begin{code} -wiredInIds :: [Id] -wiredInIds - = [ - - eRROR_ID, -- This one isn't used anywhere else in the compiler - -- But we still need it in wiredInIds so that when GHC - -- compiles a program that mentions 'error' we don't - -- import its type from the interface file; we just get - -- the Id defined here. Which has an 'open-tyvar' type. - - rUNTIME_ERROR_ID, - iRREFUT_PAT_ERROR_ID, - nON_EXHAUSTIVE_GUARDS_ERROR_ID, - nO_METHOD_BINDING_ERROR_ID, - pAT_ERROR_ID, - rEC_CON_ERROR_ID, - rEC_SEL_ERROR_ID, - - lazyId - ] ++ ghcPrimIds - --- These Ids are exported from GHC.Prim -ghcPrimIds :: [Id] -ghcPrimIds - = [ -- These can't be defined in Haskell, but they have - -- perfectly reasonable unfoldings in Core - realWorldPrimId, - unsafeCoerceId, - nullAddrId, - seqId - ] -\end{code} - -%************************************************************************ -%* * -\subsection{Data constructors} -%* * -%************************************************************************ - -The wrapper for a constructor is an ordinary top-level binding that evaluates -any strict args, unboxes any args that are going to be flattened, and calls -the worker. - -We're going to build a constructor that looks like: - - data (Data a, C b) => T a b = T1 !a !Int b - - T1 = /\ a b -> - \d1::Data a, d2::C b -> - \p q r -> case p of { p -> - case q of { q -> - Con T1 [a,b] [p,q,r]}} - -Notice that - -* d2 is thrown away --- a context in a data decl is used to make sure - one *could* construct dictionaries at the site the constructor - is used, but the dictionary isn't actually used. - -* We have to check that we can construct Data dictionaries for - the types a and Int. Once we've done that we can throw d1 away too. - -* We use (case p of q -> ...) to evaluate p, rather than "seq" because - all that matters is that the arguments are evaluated. "seq" is - very careful to preserve evaluation order, which we don't need - to be here. - - You might think that we could simply give constructors some strictness - info, like PrimOps, and let CoreToStg do the let-to-case transformation. - But we don't do that because in the case of primops and functions strictness - is a *property* not a *requirement*. In the case of constructors we need to - do something active to evaluate the argument. - - Making an explicit case expression allows the simplifier to eliminate - it in the (common) case where the constructor arg is already evaluated. - -Note [Wrappers for data instance tycons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the case of data instances, the wrapper also applies the coercion turning -the representation type into the family instance type to cast the result of -the wrapper. For example, consider the declarations - - data family Map k :: * -> * - data instance Map (a, b) v = MapPair (Map a (Pair b v)) - -The tycon to which the datacon MapPair belongs gets a unique internal -name of the form :R123Map, and we call it the representation tycon. -In contrast, Map is the family tycon (accessible via -tyConFamInst_maybe). A coercion allows you to move between -representation and family type. It is accessible from :R123Map via -tyConFamilyCoercion_maybe and has kind - - Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} - -The wrapper and worker of MapPair get the types - - -- Wrapper - $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v - $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v) - - -- Worker - MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v - -This coercion is conditionally applied by wrapFamInstBody. - -It's a bit more complicated if the data instance is a GADT as well! - - data instance T [a] where - T1 :: forall b. b -> T [Maybe b] -Hence - Co7T a :: T [a] ~ :R7T a - -Now we want - - -- Wrapper - $WT1 :: forall b. b -> T [Maybe b] - $WT1 b v = T1 (Maybe b) b (Maybe b) v - `cast` sym (Co7T (Maybe b)) - - -- Worker - T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c - -\begin{code} -mkDataConIds :: Name -> Name -> DataCon -> DataConIds -mkDataConIds wrap_name wkr_name data_con - | isNewTyCon tycon -- Newtype, only has a worker - = DCIds Nothing nt_work_id - - | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper - || not (null eq_spec) -- NB: LoadIface.ifaceDeclSubBndrs - || isFamInstTyCon tycon -- depends on this test - = DCIds (Just alg_wrap_id) wrk_id - - | otherwise -- Algebraic, no wrapper - = DCIds Nothing wrk_id - where - (univ_tvs, ex_tvs, eq_spec, - eq_theta, dict_theta, orig_arg_tys, res_ty) = dataConFullSig data_con - tycon = dataConTyCon data_con -- The representation TyCon (not family) - - ----------- Worker (algebraic data types only) -------------- - -- The *worker* for the data constructor is the function that - -- takes the representation arguments and builds the constructor. - wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name - (dataConRepType data_con) wkr_info - - wkr_arity = dataConRepArity data_con - wkr_info = noCafIdInfo - `setArityInfo` wkr_arity - `setAllStrictnessInfo` Just wkr_sig - `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, - -- even if arity = 0 - - wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info) - -- Note [Data-con worker strictness] - -- Notice that we do *not* say the worker is strict - -- even if the data constructor is declared strict - -- e.g. data T = MkT !(Int,Int) - -- Why? Because the *wrapper* is strict (and its unfolding has case - -- expresssions that do the evals) but the *worker* itself is not. - -- If we pretend it is strict then when we see - -- case x of y -> $wMkT y - -- the simplifier thinks that y is "sure to be evaluated" (because - -- $wMkT is strict) and drops the case. No, $wMkT is not strict. - -- - -- When the simplifer sees a pattern - -- case e of MkT x -> ... - -- it uses the dataConRepStrictness of MkT to mark x as evaluated; - -- but that's fine... dataConRepStrictness comes from the data con - -- not from the worker Id. - - cpr_info | isProductTyCon tycon && - isDataTyCon tycon && - wkr_arity > 0 && - wkr_arity <= mAX_CPR_SIZE = retCPR - | otherwise = TopRes - -- RetCPR is only true for products that are real data types; - -- that is, not unboxed tuples or [non-recursive] newtypes - - ----------- Workers for newtypes -------------- - 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 - `setUnfoldingInfo` newtype_unf - id_arg1 = mkTemplateLocal 1 (head orig_arg_tys) - newtype_unf = ASSERT2( isVanillaDataCon data_con && - isSingleton orig_arg_tys, ppr data_con ) - -- Note [Newtype datacons] - mkCompulsoryUnfolding $ - mkLams wrap_tvs $ Lam id_arg1 $ - wrapNewTypeBody tycon res_ty_args (Var id_arg1) - - - ----------- Wrapper -------------- - -- We used to include the stupid theta in the wrapper's args - -- but now we don't. Instead the type checker just injects these - -- 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 - - ----------- Wrappers for algebraic data types -------------- - alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info - alg_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo - `setArityInfo` wrap_arity - -- It's important to specify the arity, so that partial - -- applications are treated as values - `setUnfoldingInfo` wrap_unf - `setAllStrictnessInfo` 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 - mk_dmd str | isMarkedStrict str = evalDmd - | otherwise = lazyDmd - -- The Cpr info can be important inside INLINE rhss, where the - -- wrapper constructor isn't inlined. - -- And the argument strictness can be important too; we - -- may not inline a contructor when it is partially applied. - -- For example: - -- data W = C !Int !Int !Int - -- ...(let w = C x in ...(w p q)...)... - -- we want to see that w is strict in its two arguments - - wrap_unf = mkImplicitUnfolding $ Note InlineMe $ - mkLams wrap_tvs $ - mkLams eq_args $ - mkLams dict_args $ mkLams id_args $ - foldr mk_case con_app - (zip (dict_args ++ id_args) all_strict_marks) - i3 [] - - 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 - `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) - - mk_case - :: (Id, StrictnessMark) -- Arg, strictness - -> (Int -> [Id] -> CoreExpr) -- Body - -> Int -- Next rep arg id - -> [Id] -- Rep args so far, reversed - -> CoreExpr - mk_case (arg,strict) body i rep_args - = case strict of - NotMarkedStrict -> body i (arg:rep_args) - MarkedStrict - | isUnLiftedType (idType arg) -> body i (arg:rep_args) - | otherwise -> - Case (Var arg) arg res_ty [(DEFAULT,[], body i (arg:rep_args))] - - MarkedUnboxed - -> unboxProduct i (Var arg) (idType arg) the_body - where - the_body i con_args = body i (reverse con_args ++ rep_args) - -mAX_CPR_SIZE :: Arity -mAX_CPR_SIZE = 10 --- We do not treat very big tuples as CPR-ish: --- a) for a start we get into trouble because there aren't --- "enough" unboxed tuple types (a tiresome restriction, --- but hard to fix), --- b) more importantly, big unboxed tuples get returned mainly --- on the stack, and are often then allocated in the heap --- by the caller. So doing CPR for them may in fact make --- things worse. - -mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n) - where - n = length tys -\end{code} - -Note [Newtype datacons] -~~~~~~~~~~~~~~~~~~~~~~~ -The "data constructor" for a newtype should always be vanilla. At one -point this wasn't true, because the newtype arising from - class C a => D a -looked like - newtype T:D a = D:D (C a) -so the data constructor for T:C had a single argument, namely the -predicate (C a). But now we treat that as an ordinary argument, not -part of the theta-type, so all is well. - - -%************************************************************************ -%* * -\subsection{Dictionary selectors} -%* * -%************************************************************************ - -Selecting a field for a dictionary. If there is just one field, then -there's nothing to do. - -Dictionary selectors may get nested forall-types. Thus: - - class Foo a where - op :: forall b. Ord b => a -> b -> b - -Then the top-level type for op is - - op :: forall a. Foo a => - forall b. Ord b => - a -> b -> b - -This is unlike ordinary record selectors, which have all the for-alls -at the outside. When dealing with classes it's very convenient to -recover the original type signature from the class op selector. - -\begin{code} -mkDictSelId :: Bool -- True <=> don't include the unfolding - -- Little point on imports without -O, because the - -- dictionary itself won't be visible - -> Name -> Class -> Id -mkDictSelId no_unf name clas - = mkGlobalId (ClassOpId clas) name sel_ty info - where - sel_ty = mkForAllTys tyvars (mkFunTy (idType dict_id) (idType the_arg_id)) - -- We can't just say (exprType rhs), because that would give a type - -- C a -> C a - -- for a single-op class (after all, the selector is the identity) - -- But it's type must expose the representation of the dictionary - -- to get (say) C a -> (a -> a) - - info = noCafIdInfo - `setArityInfo` 1 - `setAllStrictnessInfo` Just strict_sig - `setUnfoldingInfo` (if no_unf then noUnfolding - else mkImplicitUnfolding rhs) - - -- We no longer use 'must-inline' on record selectors. They'll - -- inline like crazy if they scrutinise a constructor - - -- The strictness signature is of the form U(AAAVAAAA) -> T - -- where the V depends on which item we are selecting - -- It's worth giving one, so that absence info etc is generated - -- even if the selector isn't inlined - strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes) - arg_dmd | isNewTyCon tycon = evalDmd - | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs - | id <- arg_ids ]) - - tycon = classTyCon clas - [data_con] = tyConDataCons tycon - tyvars = dataConUnivTyVars data_con - arg_tys = {- ASSERT( isVanillaDataCon data_con ) -} dataConRepArgTys data_con - eq_theta = dataConEqTheta data_con - the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name - - pred = mkClassPred clas (mkTyVarTys tyvars) - dict_id = mkTemplateLocal 1 $ mkPredTy pred - (eq_ids,n) = mkCoVarLocals 2 $ mkPredTys eq_theta - arg_ids = mkTemplateLocalsNum n arg_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) - - rhs = mkLams tyvars (Lam dict_id rhs_body) - rhs_body | isNewTyCon 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)] -\end{code} - - -%************************************************************************ -%* * - Boxing and unboxing -%* * -%************************************************************************ - -\begin{code} --- unbox a product type... --- we will recurse into newtypes, casting along the way, and unbox at the --- first product data constructor we find. e.g. --- --- data PairInt = PairInt Int Int --- newtype S = MkS PairInt --- newtype T = MkT S --- --- If we have e = MkT (MkS (PairInt 0 1)) and some body expecting a list of --- ids, we get (modulo int passing) --- --- case (e `cast` CoT) `cast` CoS of --- PairInt a b -> body [a,b] --- --- The Ints passed around are just for creating fresh locals -unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> CoreExpr -unboxProduct i arg arg_ty body - = result - where - result = mkUnpackCase the_id arg con_args boxing_con rhs - (_tycon, _tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty - ([the_id], i') = mkLocals i [arg_ty] - (con_args, i'') = mkLocals i' tys - rhs = body i'' con_args - -mkUnpackCase :: Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr --- (mkUnpackCase x e args Con body) --- returns --- case (e `cast` ...) of bndr { Con args -> body } --- --- the type of the bndr passed in is irrelevent -mkUnpackCase bndr arg unpk_args boxing_con body - = Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)] - where - (cast_arg, bndr_ty) = go (idType bndr) arg - go ty arg - | (tycon, tycon_args, _, _) <- splitProductType "mkUnpackCase" ty - , isNewTyCon tycon && not (isRecursiveTyCon tycon) - = go (newTyConInstRhs tycon tycon_args) - (unwrapNewTypeBody tycon tycon_args arg) - | otherwise = (arg, ty) - --- ...and the dual -reboxProduct :: [Unique] -- uniques to create new local binders - -> Type -- type of product to box - -> ([Unique], -- remaining uniques - CoreExpr, -- boxed product - [Id]) -- Ids being boxed into product -reboxProduct us ty - = let - (_tycon, _tycon_args, _pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty - - us' = dropList con_arg_tys us - - arg_ids = zipWith (mkSysLocal (fsLit "rb")) us con_arg_tys - - bind_rhs = mkProductBox arg_ids ty - - in - (us', bind_rhs, arg_ids) - -mkProductBox :: [Id] -> Type -> CoreExpr -mkProductBox arg_ids ty - = result_expr - where - (tycon, tycon_args, pack_con, _con_arg_tys) = splitProductType "mkProductBox" ty - - 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) - - wrap expr = wrapNewTypeBody tycon tycon_args expr - - --- (mkReboxingAlt us con xs rhs) basically constructs the case --- alternative (con, xs, rhs) --- but it does the reboxing necessary to construct the *source* --- arguments, xs, from the representation arguments ys. --- For example: --- data T = MkT !(Int,Int) Bool --- --- mkReboxingAlt MkT [x,b] r --- = (DataAlt MkT, [y::Int,z::Int,b], let x = (y,z) in r) --- --- mkDataAlt should really be in DataCon, but it can't because --- it manipulates CoreSyn. - -mkReboxingAlt - :: [Unique] -- Uniques for the new Ids - -> DataCon - -> [Var] -- Source-level args, including existential dicts - -> CoreExpr -- RHS - -> CoreAlt - -mkReboxingAlt us con args rhs - | not (any isMarkedUnboxed stricts) - = (DataAlt con, args, rhs) - - | otherwise - = let - (binds, args') = go args stricts us - in - (DataAlt con, args', mkLets binds rhs) - - where - stricts = dataConExStricts con ++ dataConStrictMarks con - - go [] _stricts _us = ([], []) - - -- Type variable case - go (arg:args) stricts us - | 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' - (us', bind_rhs, unpacked_args) = reboxProduct us (idType arg) - in - (NonRec arg bind_rhs : binds, unpacked_args ++ unpacked_args') - | otherwise - = let (binds, args') = go args stricts us - in (binds, arg:args') - go (_ : _) [] _ = panic "mkReboxingAlt" -\end{code} - - -%************************************************************************ -%* * - Wrapping and unwrapping newtypes and type families -%* * -%************************************************************************ - -\begin{code} -wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr --- The wrapper for the data constructor for a newtype looks like this: --- newtype T a = MkT (a,Int) --- MkT :: forall a. (a,Int) -> T a --- MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a) --- where CoT is the coercion TyCon assoicated with the newtype --- --- The call (wrapNewTypeBody T [a] e) returns the --- body of the wrapper, namely --- e `cast` (CoT [a]) --- --- If a coercion constructor is provided in the newtype, then we use --- it, otherwise the wrap/unwrap are both no-ops --- --- If the we are dealing with a newtype *instance*, we have a second coercion --- identifying the family instance with the constructor of the newtype --- instance. This coercion is applied in any case (ie, composed with the --- coercion constructor of the newtype or applied by itself). - -wrapNewTypeBody tycon args result_expr - = wrapFamInstBody tycon args inner - where - inner - | Just co_con <- newTyConCo_maybe tycon - = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr - | otherwise - = result_expr - --- 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 --- computing the right type arguments for the coercion requires more than just --- a spliting operation (cf, TcPat.tcConPat). - -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 - --- 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 --- instance of the representation type, to the corresponding instance of the --- family instance type. --- See Note [Wrappers for data instance tycons] -wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -wrapFamInstBody tycon args body - | Just co_con <- tyConFamilyCoercion_maybe tycon - = mkCoerce (mkSymCoercion (mkTyConApp 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 - | otherwise - = scrut -\end{code} - - -%************************************************************************ -%* * -\subsection{Primitive operations} -%* * -%************************************************************************ - -\begin{code} -mkPrimOpId :: PrimOp -> Id -mkPrimOpId prim_op - = id - where - (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op - ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty) - name = mkWiredInName gHC_PRIM (primOpOcc prim_op) - (mkPrimOpIdUnique (primOpTag prim_op)) - (AnId id) UserSyntax - id = mkGlobalId (PrimOpId prim_op) name ty info - - info = noCafIdInfo - `setSpecInfo` mkSpecInfo (primOpRules prim_op name) - `setArityInfo` arity - `setAllStrictnessInfo` Just strict_sig - --- For each ccall we manufacture a separate CCallOpId, giving it --- a fresh unique, a type that is correct for this particular ccall, --- and a CCall structure that gives the correct details about calling --- convention etc. --- --- The *name* of this Id is a local name whose OccName gives the full --- details of the ccall, type and all. This means that the interface --- file reader can reconstruct a suitable Id - -mkFCallId :: Unique -> ForeignCall -> Type -> Id -mkFCallId uniq fcall ty - = ASSERT( isEmptyVarSet (tyVarsOfType ty) ) - -- A CCallOpId should have no free type variables; - -- when doing substitutions won't substitute over it - mkGlobalId (FCallId fcall) name ty info - where - occ_str = showSDoc (braces (ppr fcall <+> ppr ty)) - -- The "occurrence name" of a ccall is the full info about the - -- ccall; it is encoded, but may have embedded spaces etc! - - name = mkFCallName uniq occ_str - - info = noCafIdInfo - `setArityInfo` arity - `setAllStrictnessInfo` Just strict_sig - - (_, tau) = tcSplitForAllTys ty - (arg_tys, _) = tcSplitFunTys tau - arity = length arg_tys - strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes) - --- Tick boxes and breakpoints are both represented as TickBoxOpIds, --- except for the type: --- --- a plain HPC tick box has type (State# RealWorld) --- a breakpoint Id has type forall a.a --- --- The breakpoint Id will be applied to a list of arbitrary free variables, --- which is why it needs a polymorphic type. - -mkTickBoxOpId :: Unique -> Module -> TickBoxId -> Id -mkTickBoxOpId uniq mod ix = mkTickBox' uniq mod ix realWorldStatePrimTy - -mkBreakPointOpId :: Unique -> Module -> TickBoxId -> Id -mkBreakPointOpId uniq mod ix = mkTickBox' uniq mod ix ty - where ty = mkSigmaTy [openAlphaTyVar] [] openAlphaTy - -mkTickBox' uniq mod ix ty = mkGlobalId (TickBoxOpId tickbox) name ty info - where - tickbox = TickBox mod ix - occ_str = showSDoc (braces (ppr tickbox)) - name = mkTickBoxOpName uniq occ_str - info = noCafIdInfo -\end{code} - - -%************************************************************************ -%* * -\subsection{DictFuns and default methods} -%* * -%************************************************************************ - -Important notes about dict funs and default methods -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Dict funs and default methods are *not* ImplicitIds. Their definition -involves user-written code, so we can't figure out their strictness etc -based on fixed info, as we can for constructors and record selectors (say). - -We build them as LocalIds, but with External Names. This ensures that -they are taken to account by free-variable finding and dependency -analysis (e.g. CoreFVs.exprFreeVars). - -Why shouldn't they be bound as GlobalIds? Because, in particular, if -they are globals, the specialiser floats dict uses above their defns, -which prevents good simplifications happening. Also the strictness -analyser treats a occurrence of a GlobalId as imported and assumes it -contains strictness in its IdInfo, which isn't true if the thing is -bound in the same module as the occurrence. - -It's OK for dfuns to be LocalIds, because we form the instance-env to -pass on to the next module (md_insts) in CoreTidy, afer tidying -and globalising the top-level Ids. - -BUT make sure they are *exported* LocalIds (mkExportedLocalId) so -that they aren't discarded by the occurrence analyser. - -\begin{code} -mkDefaultMethodId dm_name ty = mkExportedLocalId dm_name ty - -mkDictFunId :: Name -- Name to use for the dict fun; - -> [TyVar] - -> ThetaType - -> Class - -> [Type] - -> Id - -mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys - = mkExportedLocalVar DFunId dfun_name dfun_ty vanillaIdInfo - where - dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) -\end{code} - - -%************************************************************************ -%* * -\subsection{Un-definable} -%* * -%************************************************************************ - -These Ids can't be defined in Haskell. They could be defined in -unfoldings in the wired-in GHC.Prim interface file, but we'd have to -ensure that they were definitely, definitely inlined, because there is -no curried identifier for them. That's what mkCompulsoryUnfolding -does. If we had a way to get a compulsory unfolding from an interface -file, we could do that, but we don't right now. - -unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that -just gets expanded into a type coercion wherever it occurs. Hence we -add it as a built-in Id with an unfolding here. - -The type variables we use here are "open" type variables: this means -they can unify with both unlifted and lifted types. Hence we provide -another gun with which to shoot yourself in the foot. - -\begin{code} -mkWiredInIdName mod fs uniq id - = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax - -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 - -errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID -recSelErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID -runtimeErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID -irrefutPatErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID -recConErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recConError") recConErrorIdKey rEC_CON_ERROR_ID -patErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "patError") patErrorIdKey pAT_ERROR_ID -noMethodBindingErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "noMethodBindingError") - noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID -nonExhaustiveGuardsErrorName - = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "nonExhaustiveGuardsError") - nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID -\end{code} - -\begin{code} ------------------------------------------------- --- unsafeCoerce# :: forall a b. a -> b -unsafeCoerceId - = pcMiscPrelId unsafeCoerceName ty info - where - info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs - - - ty = mkForAllTys [openAlphaTyVar,openBetaTyVar] - (mkFunTy openAlphaTy openBetaTy) - [x] = mkTemplateLocals [openAlphaTy] - rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $ - Cast (Var x) (mkUnsafeCoercion openAlphaTy openBetaTy) - ------------------------------------------------- -nullAddrId :: Id --- nullAddr# :: Addr# --- The reason is is here is because we don't provide --- a way to write this literal in Haskell. -nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info - where - info = noCafIdInfo `setUnfoldingInfo` - mkCompulsoryUnfolding (Lit nullAddrLit) - ------------------------------------------------- -seqId :: Id -- See Note [seqId magic] -seqId = pcMiscPrelId seqName ty info - where - info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs - - - ty = mkForAllTys [alphaTyVar,openBetaTyVar] - (mkFunTy alphaTy (mkFunTy openBetaTy openBetaTy)) - [x,y] = mkTemplateLocals [alphaTy, openBetaTy] - rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(DEFAULT, [], Var y)]) - ------------------------------------------------- -lazyId :: Id -- See Note [lazyId magic] -lazyId = pcMiscPrelId lazyIdName ty info - where - info = noCafIdInfo - ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy) -\end{code} - -Note [seqId magic] -~~~~~~~~~~~~~~~~~~ -'seq' is special in several ways. - -a) Its second arg can have an unboxed type - x `seq` (v +# w) - -b) Its fixity is set in LoadIface.ghcPrimIface - -c) It has quite a bit of desugaring magic. - See DsUtils.lhs Note [Desugaring seq (1)] and (2) and (3) - -d) There is some special rule handing: Note [RULES for seq] - -Note [Rules for seq] -~~~~~~~~~~~~~~~~~~~~ -Roman found situations where he had - case (f n) of _ -> e -where he knew that f (which was strict in n) would terminate if n did. -Notice that the result of (f n) is discarded. So it makes sense to -transform to - case n of _ -> e - -Rather than attempt some general analysis to support this, I've added -enough support that you can do this using a rewrite rule: - - RULE "f/seq" forall n. seq (f n) e = seq n e - -You write that rule. When GHC sees a case expression that discards -its result, it mentally transforms it to a call to 'seq' and looks for -a RULE. (This is done in Simplify.rebuildCase.) As usual, the -correctness of the rule is up to you. - -To make this work, we need to be careful that the magical desugaring -done in Note [seqId magic] item (c) is *not* done on the LHS of a rule. -Or rather, we arrange to un-do it, in DsBinds.decomposeRuleLhs. - - -Note [lazyId magic] -~~~~~~~~~~~~~~~~~~~ - lazy :: forall a?. a? -> a? (i.e. works for unboxed types too) - -Used to lazify pseq: pseq a b = a `seq` lazy b - -Also, no strictness: by being a built-in Id, all the info about lazyId comes from here, -not from GHC.Base.hi. This is important, because the strictness -analyser will spot it as strict! - -Also no unfolding in lazyId: it gets "inlined" by a HACK in CorePrep. -It's very important to do this inlining *after* unfoldings are exposed -in the interface file. Otherwise, the unfolding for (say) pseq in the -interface file will not mention 'lazy', so if we inline 'pseq' we'll totally -miss the very thing that 'lazy' was there for in the first place. -See Trac #3259 for a real world example. - -lazyId is defined in GHC.Base, so we don't *have* to inline it. If it -appears un-applied, we'll end up just calling it. - -------------------------------------------------------------- -@realWorld#@ used to be a magic literal, \tr{void#}. If things get -nasty as-is, change it back to a literal (@Literal@). - -voidArgId is a Local Id used simply as an argument in functions -where we just want an arg to avoid having a thunk of unlifted type. -E.g. - x = \ void :: State# RealWorld -> (# p, q #) - -This comes up in strictness analysis - -\begin{code} -realWorldPrimId -- :: State# RealWorld - = pcMiscPrelId realWorldName realWorldStatePrimTy - (noCafIdInfo `setUnfoldingInfo` evaldUnfolding) - -- The evaldUnfolding makes it look that realWorld# is evaluated - -- which in turn makes Simplify.interestingArg return True, - -- which in turn makes INLINE things applied to realWorld# likely - -- to be inlined - -voidArgId :: Id -voidArgId -- :: State# RealWorld - = mkSysLocal (fsLit "void") voidArgIdKey realWorldStatePrimTy -\end{code} - - -%************************************************************************ -%* * -\subsection[PrelVals-error-related]{@error@ and friends; @trace@} -%* * -%************************************************************************ - -GHC randomly injects these into the code. - -@patError@ is just a version of @error@ for pattern-matching -failures. It knows various ``codes'' which expand to longer -strings---this saves space! - -@absentErr@ is a thing we put in for ``absent'' arguments. They jolly -well shouldn't be yanked on, but if one is, then you will get a -friendly message from @absentErr@ (rather than a totally random -crash). - -@parError@ is a special version of @error@ which the compiler does -not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@ -templates, but we don't ever expect to generate code for it. - -\begin{code} -mkRuntimeErrorApp - :: Id -- Should be of type (forall a. Addr# -> a) - -- where Addr# points to a UTF8 encoded string - -> Type -- The type to instantiate 'a' - -> String -- The string to print - -> CoreExpr - -mkRuntimeErrorApp err_id res_ty err_msg - = mkApps (Var err_id) [Type res_ty, err_string] - where - err_string = Lit (mkMachString err_msg) - -mkImpossibleExpr :: Type -> CoreExpr -mkImpossibleExpr res_ty - = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative" - -rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName -rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName -iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName -rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName -pAT_ERROR_ID = mkRuntimeErrorId patErrorName -nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName -nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName - --- The runtime error Ids take a UTF8-encoded string as argument - -mkRuntimeErrorId :: Name -> Id -mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy - -runtimeErrorTy :: Type -runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy) -\end{code} - -\begin{code} -eRROR_ID = pc_bottoming_Id errorName errorTy - -errorTy :: Type -errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy) - -- Notice the openAlphaTyVar. It says that "error" can be applied - -- to unboxed as well as boxed types. This is OK because it never - -- returns, so the return type is irrelevant. -\end{code} - - -%************************************************************************ -%* * -\subsection{Utilities} -%* * -%************************************************************************ - -\begin{code} -pcMiscPrelId :: Name -> Type -> IdInfo -> Id -pcMiscPrelId name ty info - = mkVanillaGlobalWithInfo name ty info - -- We lie and say the thing is imported; otherwise, we get into - -- a mess with dependency analysis; e.g., core2stg may heave in - -- random calls to GHCbase.unpackPS__. If GHCbase is the module - -- being compiled, then it's just a matter of luck if the definition - -- will be in "the right place" to be in scope. - -pc_bottoming_Id :: Name -> Type -> Id --- Function of arity 1, which diverges after being given one argument -pc_bottoming_Id name ty - = pcMiscPrelId name ty bottoming_info - where - bottoming_info = vanillaIdInfo `setAllStrictnessInfo` Just strict_sig - `setArityInfo` 1 - -- Make arity and strictness agree - - -- Do *not* mark them as NoCafRefs, because they can indeed have - -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle, - -- which has some CAFs - -- In due course we may arrange that these error-y things are - -- regarded by the GC as permanently live, in which case we - -- can give them NoCaf info. As it is, any function that calls - -- any pc_bottoming_Id will itself have CafRefs, which bloats - -- SRTs. - - strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes) - -- These "bottom" out, no matter what their arguments -\end{code} - diff -ruN ghc-6.12.1/compiler/basicTypes/MkId.lhs-boot ghc-6.13-20091231/compiler/basicTypes/MkId.lhs-boot --- ghc-6.12.1/compiler/basicTypes/MkId.lhs-boot 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/MkId.lhs-boot 1969-12-31 16:00:00.000000000 -0800 @@ -1,9 +0,0 @@ -\begin{code} -module MkId where -import Name( Name ) -import DataCon( DataCon, DataConIds ) - -mkDataConIds :: Name -> Name -> DataCon -> DataConIds -\end{code} - - diff -ruN ghc-6.12.1/compiler/basicTypes/Module.lhs ghc-6.13-20091231/compiler/basicTypes/Module.lhs --- ghc-6.12.1/compiler/basicTypes/Module.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/Module.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,436 +0,0 @@ -% -% (c) The University of Glasgow, 2004-2006 -% - -Module -~~~~~~~~~~ -Simply the name of a module, represented as a FastString. -These are Uniquable, hence we can build FiniteMaps with Modules as -the keys. - -\begin{code} -module Module - ( - -- * The ModuleName type - ModuleName, - pprModuleName, - moduleNameFS, - moduleNameString, - moduleNameSlashes, - mkModuleName, - mkModuleNameFS, - stableModuleNameCmp, - - -- * The PackageId type - PackageId, - fsToPackageId, - packageIdFS, - stringToPackageId, - packageIdString, - stablePackageIdCmp, - - -- * Wired-in PackageIds - -- $wired_in_packages - primPackageId, - integerPackageId, - basePackageId, - rtsPackageId, - haskell98PackageId, - thPackageId, - dphSeqPackageId, - dphParPackageId, - mainPackageId, - - -- * The Module type - Module, - modulePackageId, moduleName, - pprModule, - mkModule, - stableModuleCmp, - - -- * The ModuleLocation type - ModLocation(..), - addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn, - - -- * Module mappings - ModuleEnv, - elemModuleEnv, extendModuleEnv, extendModuleEnvList, - extendModuleEnvList_C, plusModuleEnv_C, - delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv, - lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv, - moduleEnvKeys, moduleEnvElts, moduleEnvToList, - unitModuleEnv, isEmptyModuleEnv, - foldModuleEnv, extendModuleEnv_C, filterModuleEnv, - - -- * ModuleName mappings - ModuleNameEnv, - - -- * Sets of Modules - ModuleSet, - emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet - ) where - -import Config -import Outputable -import qualified Pretty -import Unique -import FiniteMap -import LazyUniqFM -import FastString -import Binary -import Util - -import System.FilePath -\end{code} - -%************************************************************************ -%* * -\subsection{Module locations} -%* * -%************************************************************************ - -\begin{code} --- | Where a module lives on the file system: the actual locations --- of the .hs, .hi and .o files, if we have them -data ModLocation - = ModLocation { - ml_hs_file :: Maybe FilePath, - -- The source file, if we have one. Package modules - -- probably don't have source files. - - ml_hi_file :: FilePath, - -- Where the .hi file is, whether or not it exists - -- yet. Always of form foo.hi, even if there is an - -- hi-boot file (we add the -boot suffix later) - - ml_obj_file :: FilePath - -- Where the .o file is, whether or not it exists yet. - -- (might not exist either because the module hasn't - -- been compiled yet, or because it is part of a - -- package with a .a file) - } deriving Show - -instance Outputable ModLocation where - ppr = text . show -\end{code} - -For a module in another package, the hs_file and obj_file -components of ModLocation are undefined. - -The locations specified by a ModLocation may or may not -correspond to actual files yet: for example, even if the object -file doesn't exist, the ModLocation still contains the path to -where the object file will reside if/when it is created. - -\begin{code} -addBootSuffix :: FilePath -> FilePath --- ^ Add the @-boot@ suffix to .hs, .hi and .o files -addBootSuffix path = path ++ "-boot" - -addBootSuffix_maybe :: Bool -> FilePath -> FilePath --- ^ Add the @-boot@ suffix if the @Bool@ argument is @True@ -addBootSuffix_maybe is_boot path - | is_boot = addBootSuffix path - | otherwise = path - -addBootSuffixLocn :: ModLocation -> ModLocation --- ^ Add the @-boot@ suffix to all file paths associated with the module -addBootSuffixLocn locn - = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn) - , ml_hi_file = addBootSuffix (ml_hi_file locn) - , ml_obj_file = addBootSuffix (ml_obj_file locn) } -\end{code} - - -%************************************************************************ -%* * -\subsection{The name of a module} -%* * -%************************************************************************ - -\begin{code} --- | A ModuleName is essentially a simple string, e.g. @Data.List@. -newtype ModuleName = ModuleName FastString - -instance Uniquable ModuleName where - getUnique (ModuleName nm) = getUnique nm - -instance Eq ModuleName where - nm1 == nm2 = getUnique nm1 == getUnique nm2 - --- Warning: gives an ordering relation based on the uniques of the --- FastStrings which are the (encoded) module names. This is _not_ --- a lexicographical ordering. -instance Ord ModuleName where - nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2 - -instance Outputable ModuleName where - ppr = pprModuleName - -instance Binary ModuleName where - put_ bh (ModuleName fs) = put_ bh fs - get bh = do fs <- get bh; return (ModuleName fs) - -stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering --- ^ Compares module names lexically, rather than by their 'Unique's -stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2 - -pprModuleName :: ModuleName -> SDoc -pprModuleName (ModuleName nm) = - getPprStyle $ \ sty -> - if codeStyle sty - then ftext (zEncodeFS nm) - else ftext nm - -moduleNameFS :: ModuleName -> FastString -moduleNameFS (ModuleName mod) = mod - -moduleNameString :: ModuleName -> String -moduleNameString (ModuleName mod) = unpackFS mod - -mkModuleName :: String -> ModuleName -mkModuleName s = ModuleName (mkFastString s) - -mkModuleNameFS :: FastString -> ModuleName -mkModuleNameFS s = ModuleName s - --- | Returns the string version of the module name, with dots replaced by slashes -moduleNameSlashes :: ModuleName -> String -moduleNameSlashes = dots_to_slashes . moduleNameString - where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) -\end{code} - -%************************************************************************ -%* * -\subsection{A fully qualified module} -%* * -%************************************************************************ - -\begin{code} --- | A Module is a pair of a 'PackageId' and a 'ModuleName'. -data Module = Module { - modulePackageId :: !PackageId, -- pkg-1.0 - moduleName :: !ModuleName -- A.B.C - } - deriving (Eq, Ord) - -instance Uniquable Module where - getUnique (Module p n) = getUnique (packageIdFS p `appendFS` moduleNameFS n) - -instance Outputable Module where - ppr = pprModule - -instance Binary Module where - put_ bh (Module p n) = put_ bh p >> put_ bh n - get bh = do p <- get bh; n <- get bh; return (Module p n) - --- | This gives a stable ordering, as opposed to the Ord instance which --- gives an ordering based on the 'Unique's of the components, which may --- not be stable from run to run of the compiler. -stableModuleCmp :: Module -> Module -> Ordering -stableModuleCmp (Module p1 n1) (Module p2 n2) - = (p1 `stablePackageIdCmp` p2) `thenCmp` - (n1 `stableModuleNameCmp` n2) - -mkModule :: PackageId -> ModuleName -> Module -mkModule = Module - -pprModule :: Module -> SDoc -pprModule mod@(Module p n) = pprPackagePrefix p mod <> pprModuleName n - -pprPackagePrefix :: PackageId -> Module -> PprStyle -> Pretty.Doc -pprPackagePrefix p mod = getPprStyle doc - where - doc sty - | codeStyle sty = - if p == mainPackageId - then empty -- never qualify the main package in code - else ftext (zEncodeFS (packageIdFS p)) <> char '_' - | qualModule sty mod = ftext (packageIdFS (modulePackageId mod)) <> char ':' - -- the PrintUnqualified tells us which modules have to - -- be qualified with package names - | otherwise = empty -\end{code} - -%************************************************************************ -%* * -\subsection{PackageId} -%* * -%************************************************************************ - -\begin{code} --- | Essentially just a string identifying a package, including the version: e.g. parsec-1.0 -newtype PackageId = PId FastString deriving( Eq ) - -- here to avoid module loops with PackageConfig - -instance Uniquable PackageId where - getUnique pid = getUnique (packageIdFS pid) - --- Note: *not* a stable lexicographic ordering, a faster unique-based --- ordering. -instance Ord PackageId where - nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2 - -stablePackageIdCmp :: PackageId -> PackageId -> Ordering --- ^ Compares package ids lexically, rather than by their 'Unique's -stablePackageIdCmp p1 p2 = packageIdFS p1 `compare` packageIdFS p2 - -instance Outputable PackageId where - ppr pid = text (packageIdString pid) - -instance Binary PackageId where - put_ bh pid = put_ bh (packageIdFS pid) - get bh = do { fs <- get bh; return (fsToPackageId fs) } - -fsToPackageId :: FastString -> PackageId -fsToPackageId = PId - -packageIdFS :: PackageId -> FastString -packageIdFS (PId fs) = fs - -stringToPackageId :: String -> PackageId -stringToPackageId = fsToPackageId . mkFastString - -packageIdString :: PackageId -> String -packageIdString = unpackFS . packageIdFS - - --- ----------------------------------------------------------------------------- --- $wired_in_packages --- Certain packages are known to the compiler, in that we know about certain --- entities that reside in these packages, and the compiler needs to --- declare static Modules and Names that refer to these packages. Hence --- the wired-in packages can't include version numbers, since we don't want --- to bake the version numbers of these packages into GHC. --- --- So here's the plan. Wired-in packages are still versioned as --- normal in the packages database, and you can still have multiple --- versions of them installed. However, for each invocation of GHC, --- only a single instance of each wired-in package will be recognised --- (the desired one is selected via @-package@\/@-hide-package@), and GHC --- will use the unversioned 'PackageId' below when referring to it, --- including in .hi files and object file symbols. Unselected --- versions of wired-in packages will be ignored, as will any other --- package that depends directly or indirectly on it (much as if you --- had used @-ignore-package@). - --- Make sure you change 'Packages.findWiredInPackages' if you add an entry here - -integerPackageId, primPackageId, - basePackageId, rtsPackageId, haskell98PackageId, - thPackageId, dphSeqPackageId, dphParPackageId, - mainPackageId :: PackageId -primPackageId = fsToPackageId (fsLit "ghc-prim") -integerPackageId = fsToPackageId (fsLit cIntegerLibrary) -basePackageId = fsToPackageId (fsLit "base") -rtsPackageId = fsToPackageId (fsLit "rts") -haskell98PackageId = fsToPackageId (fsLit "haskell98") -thPackageId = fsToPackageId (fsLit "template-haskell") -dphSeqPackageId = fsToPackageId (fsLit "dph-seq") -dphParPackageId = fsToPackageId (fsLit "dph-par") - --- | 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 --- to symbol names, since there can be only one main package per program. -mainPackageId = fsToPackageId (fsLit "main") -\end{code} - -%************************************************************************ -%* * -\subsection{@ModuleEnv@s} -%* * -%************************************************************************ - -\begin{code} --- | A map keyed off of 'Module's -newtype ModuleEnv elt = ModuleEnv (FiniteMap Module elt) - -filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a -filterModuleEnv f (ModuleEnv e) = ModuleEnv (filterFM f e) - -elemModuleEnv :: Module -> ModuleEnv a -> Bool -elemModuleEnv m (ModuleEnv e) = elemFM m e - -extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a -extendModuleEnv (ModuleEnv e) m x = ModuleEnv (addToFM e m x) - -extendModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> Module -> a -> ModuleEnv a -extendModuleEnv_C f (ModuleEnv e) m x = ModuleEnv (addToFM_C f e m x) - -extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a -extendModuleEnvList (ModuleEnv e) xs = ModuleEnv (addListToFM e xs) - -extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)] - -> ModuleEnv a -extendModuleEnvList_C f (ModuleEnv e) xs = ModuleEnv (addListToFM_C f e xs) - -plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a -plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (plusFM_C f e1 e2) - -delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a -delModuleEnvList (ModuleEnv e) ms = ModuleEnv (delListFromFM e ms) - -delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a -delModuleEnv (ModuleEnv e) m = ModuleEnv (delFromFM e m) - -plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a -plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (plusFM e1 e2) - -lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a -lookupModuleEnv (ModuleEnv e) m = lookupFM e m - -lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a -lookupWithDefaultModuleEnv (ModuleEnv e) x m = lookupWithDefaultFM e x m - -mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b -mapModuleEnv f (ModuleEnv e) = ModuleEnv (mapFM (\_ v -> f v) e) - -mkModuleEnv :: [(Module, a)] -> ModuleEnv a -mkModuleEnv xs = ModuleEnv (listToFM xs) - -emptyModuleEnv :: ModuleEnv a -emptyModuleEnv = ModuleEnv emptyFM - -moduleEnvKeys :: ModuleEnv a -> [Module] -moduleEnvKeys (ModuleEnv e) = keysFM e - -moduleEnvElts :: ModuleEnv a -> [a] -moduleEnvElts (ModuleEnv e) = eltsFM e - -moduleEnvToList :: ModuleEnv a -> [(Module, a)] -moduleEnvToList (ModuleEnv e) = fmToList e - -unitModuleEnv :: Module -> a -> ModuleEnv a -unitModuleEnv m x = ModuleEnv (unitFM m x) - -isEmptyModuleEnv :: ModuleEnv a -> Bool -isEmptyModuleEnv (ModuleEnv e) = isEmptyFM e - -foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b -foldModuleEnv f x (ModuleEnv e) = foldFM (\_ v -> f v) x e -\end{code} - -\begin{code} --- | A set of 'Module's -type ModuleSet = FiniteMap Module () - -mkModuleSet :: [Module] -> ModuleSet -extendModuleSet :: ModuleSet -> Module -> ModuleSet -emptyModuleSet :: ModuleSet -moduleSetElts :: ModuleSet -> [Module] -elemModuleSet :: Module -> ModuleSet -> Bool - -emptyModuleSet = emptyFM -mkModuleSet ms = listToFM [(m,()) | m <- ms ] -extendModuleSet s m = addToFM s m () -moduleSetElts = keysFM -elemModuleSet = elemFM -\end{code} - -A ModuleName has a Unique, so we can build mappings of these using -UniqFM. - -\begin{code} --- | A map keyed off of 'ModuleName's (actually, their 'Unique's) -type ModuleNameEnv elt = UniqFM elt -\end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/Module.lhs-boot ghc-6.13-20091231/compiler/basicTypes/Module.lhs-boot --- ghc-6.12.1/compiler/basicTypes/Module.lhs-boot 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/Module.lhs-boot 1969-12-31 16:00:00.000000000 -0800 @@ -1,10 +0,0 @@ -\begin{code} -module Module where - -data Module -data ModuleName -data PackageId -moduleName :: Module -> ModuleName -modulePackageId :: Module -> PackageId -packageIdString :: PackageId -> String -\end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/NameEnv.lhs ghc-6.13-20091231/compiler/basicTypes/NameEnv.lhs --- ghc-6.12.1/compiler/basicTypes/NameEnv.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/NameEnv.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,87 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[NameEnv]{@NameEnv@: name environments} - -\begin{code} -module NameEnv ( - -- * Var, Id and TyVar environments (maps) - NameEnv, - - -- ** Manipulating these environments - mkNameEnv, - emptyNameEnv, unitNameEnv, nameEnvElts, nameEnvUniqueElts, - extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, - extendNameEnvList, extendNameEnvList_C, - foldNameEnv, filterNameEnv, - plusNameEnv, plusNameEnv_C, - lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, - elemNameEnv, mapNameEnv - ) where - -#include "HsVersions.h" - -import Name -import Unique -import LazyUniqFM -import Maybes -import Outputable -\end{code} - -%************************************************************************ -%* * -\subsection{Name environment} -%* * -%************************************************************************ - -\begin{code} -newtype NameEnv a = A (UniqFM a) -- Domain is Name - -emptyNameEnv :: NameEnv a -mkNameEnv :: [(Name,a)] -> NameEnv a -nameEnvElts :: NameEnv a -> [a] -nameEnvUniqueElts :: NameEnv a -> [(Unique, a)] -extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a -extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b -extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a -plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a -plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a -extendNameEnvList :: NameEnv a -> [(Name,a)] -> NameEnv a -extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a -delFromNameEnv :: NameEnv a -> Name -> NameEnv a -delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a -elemNameEnv :: Name -> NameEnv a -> Bool -unitNameEnv :: Name -> a -> NameEnv a -lookupNameEnv :: NameEnv a -> Name -> Maybe a -lookupNameEnv_NF :: NameEnv a -> Name -> a -foldNameEnv :: (a -> b -> b) -> b -> NameEnv a -> b -filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt -mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 - -nameEnvElts (A x) = eltsUFM x -emptyNameEnv = A emptyUFM -unitNameEnv x y = A $ unitUFM x y -extendNameEnv (A x) y z = A $ addToUFM x y z -extendNameEnvList (A x) l = A $ addListToUFM x l -lookupNameEnv (A x) y = lookupUFM x y -mkNameEnv l = A $ listToUFM l -elemNameEnv x (A y) = elemUFM x y -foldNameEnv a b (A c) = foldUFM a b c -plusNameEnv (A x) (A y) = A $ plusUFM x y -plusNameEnv_C f (A x) (A y) = A $ plusUFM_C f x y -extendNameEnv_C f (A x) y z = A $ addToUFM_C f x y z -mapNameEnv f (A x) = A $ mapUFM f x -nameEnvUniqueElts (A x) = ufmToList x -extendNameEnv_Acc x y (A z) a b = A $ addToUFM_Acc x y z a b -extendNameEnvList_C x (A y) z = A $ addListToUFM_C x y z -delFromNameEnv (A x) y = A $ delFromUFM x y -delListFromNameEnv (A x) y = A $ delListFromUFM x y -filterNameEnv x (A y) = A $ filterUFM x y - -lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n) - -instance Outputable a => Outputable (NameEnv a) where - ppr (A x) = ppr x -\end{code} - diff -ruN ghc-6.12.1/compiler/basicTypes/Name.lhs ghc-6.13-20091231/compiler/basicTypes/Name.lhs --- ghc-6.12.1/compiler/basicTypes/Name.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/Name.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,502 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[Name]{@Name@: to transmit name info from renamer to typechecker} - -\begin{code} --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name' is the type of names that have had their scoping and binding resolved. They --- have an 'OccName.OccName' but also a 'Unique.Unique' that disambiguates Names that have --- the same 'OccName.OccName' and indeed is used for all 'Name.Name' comparison. Names --- also contain information about where they originated from, see "Name#name_sorts" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var': see "Var#name_types" --- --- #name_sorts# --- Names are one of: --- --- * External, if they name things declared in other modules. Some external --- Names are wired in, i.e. they name primitives defined in the compiler itself --- --- * Internal, if they name things in the module being compiled. Some internal --- Names are system names, if they are names manufactured by the compiler - -module Name ( - -- * The main types - Name, -- Abstract - BuiltInSyntax(..), - - -- ** Creating 'Name's - mkInternalName, mkSystemName, - mkSystemVarName, mkSysTvName, - mkFCallName, mkIPName, - mkTickBoxOpName, - mkExternalName, mkWiredInName, - - -- ** Manipulating and deconstructing 'Name's - nameUnique, setNameUnique, - nameOccName, nameModule, nameModule_maybe, - tidyNameOcc, - hashName, localiseName, - - nameSrcLoc, nameSrcSpan, pprNameLoc, - - -- ** Predicates on 'Name's - isSystemName, isInternalName, isExternalName, - isTyVarName, isTyConName, isDataConName, - isValName, isVarName, - isWiredInName, isBuiltInSyntax, - wiredInNameTyThing_maybe, - nameIsLocalOrFrom, - - -- * Class 'NamedThing' and overloaded friends - NamedThing(..), - getSrcLoc, getSrcSpan, getOccString, - - pprInfixName, pprPrefixName, pprModulePrefix, - - -- Re-export the OccName stuff - module OccName - ) where - -import {-# SOURCE #-} TypeRep( TyThing ) - -import OccName -import Module -import SrcLoc -import Unique -import Maybes -import Binary -import StaticFlags -import FastTypes -import FastString -import Outputable - -import Data.Array -import Data.Word ( Word32 ) -\end{code} - -%************************************************************************ -%* * -\subsection[Name-datatype]{The @Name@ datatype, and name construction} -%* * -%************************************************************************ - -\begin{code} --- | A unique, unambigious name for something, containing information about where --- that thing originated. -data Name = Name { - n_sort :: NameSort, -- What sort of name it is - n_occ :: !OccName, -- Its occurrence name - n_uniq :: FastInt, -- UNPACK doesn't work, recursive type ---(note later when changing Int# -> FastInt: is that still true about UNPACK?) - n_loc :: !SrcSpan -- Definition site - } - --- 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 --- the SrcLoc in a Name all that often. - -data NameSort - = External Module - - | WiredIn Module TyThing BuiltInSyntax - -- A variant of External, for wired-in things - - | Internal -- A user-defined Id or TyVar - -- defined in the module being compiled - - | System -- A system-defined Id or TyVar. Typically the - -- OccName is very uninformative (like 's') - --- | BuiltInSyntax is for things like @(:)@, @[]@ and tuples, --- which have special syntactic forms. They aren't in scope --- as such. -data BuiltInSyntax = BuiltInSyntax | UserSyntax -\end{code} - -Notes about the NameSorts: - -1. Initially, top-level Ids (including locally-defined ones) get External names, - and all other local Ids get Internal names - -2. Things with a External name are given C static labels, so they finally - appear in the .o file's symbol table. They appear in the symbol table - in the form M.n. If originally-local things have this property they - must be made @External@ first. - -3. In the tidy-core phase, a External that is not visible to an importer - is changed to Internal, and a Internal that is visible is changed to External - -4. A System Name differs in the following ways: - a) has unique attached when printing dumps - b) unifier eliminates sys tyvars in favour of user provs where possible - - Before anything gets printed in interface files or output code, it's - fed through a 'tidy' processor, which zaps the OccNames to have - unique names; and converts all sys-locals to user locals - If any desugarer sys-locals have survived that far, they get changed to - "ds1", "ds2", etc. - -Built-in syntax => It's a syntactic form, not "in scope" (e.g. []) - -Wired-in thing => The thing (Id, TyCon) is fully known to the compiler, - not read from an interface file. - E.g. Bool, True, Int, Float, and many others - -All built-in syntax is for wired-in things. - -\begin{code} -nameUnique :: Name -> Unique -nameOccName :: Name -> OccName -nameModule :: Name -> Module -nameSrcLoc :: Name -> SrcLoc -nameSrcSpan :: Name -> SrcSpan - -nameUnique name = mkUniqueGrimily (iBox (n_uniq name)) -nameOccName name = n_occ name -nameSrcLoc name = srcSpanStart (n_loc name) -nameSrcSpan name = n_loc name -\end{code} - -%************************************************************************ -%* * -\subsection{Predicates on names} -%* * -%************************************************************************ - -\begin{code} -nameIsLocalOrFrom :: Module -> Name -> Bool -isInternalName :: Name -> Bool -isExternalName :: Name -> Bool -isSystemName :: Name -> Bool -isWiredInName :: Name -> Bool - -isWiredInName (Name {n_sort = WiredIn _ _ _}) = True -isWiredInName _ = False - -wiredInNameTyThing_maybe :: Name -> Maybe TyThing -wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing -wiredInNameTyThing_maybe _ = Nothing - -isBuiltInSyntax :: Name -> Bool -isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True -isBuiltInSyntax _ = False - -isExternalName (Name {n_sort = External _}) = True -isExternalName (Name {n_sort = WiredIn _ _ _}) = True -isExternalName _ = False - -isInternalName name = not (isExternalName name) - -nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr name) -nameModule_maybe :: Name -> Maybe Module -nameModule_maybe (Name { n_sort = External mod}) = Just mod -nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod -nameModule_maybe _ = Nothing - -nameIsLocalOrFrom from name - | isExternalName name = from == nameModule name - | otherwise = True - -isTyVarName :: Name -> Bool -isTyVarName name = isTvOcc (nameOccName name) - -isTyConName :: Name -> Bool -isTyConName name = isTcOcc (nameOccName name) - -isDataConName :: Name -> Bool -isDataConName name = isDataOcc (nameOccName name) - -isValName :: Name -> Bool -isValName name = isValOcc (nameOccName name) - -isVarName :: Name -> Bool -isVarName = isVarOcc . nameOccName - -isSystemName (Name {n_sort = System}) = True -isSystemName _ = False -\end{code} - - -%************************************************************************ -%* * -\subsection{Making names} -%* * -%************************************************************************ - -\begin{code} --- | 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 } - -- 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 - -- * the insides of the compiler don't care: they use the Unique - -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the - -- uniques if you get confused - -- * for interface files we tidyCore first, which puts the uniques - -- into the print name (see setNameVisibility below) - --- | Create a name which definitely originates in the given module -mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name -mkExternalName uniq mod occ loc - = Name { n_uniq = getKeyFastInt uniq, n_sort = External mod, - n_occ = occ, n_loc = loc } - --- | Create a name which is actually defined by the compiler itself -mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name -mkWiredInName mod occ uniq thing built_in - = Name { n_uniq = getKeyFastInt uniq, - n_sort = WiredIn mod thing built_in, - n_occ = occ, n_loc = wiredInSrcSpan } - --- | Create a name brought into being by the compiler -mkSystemName :: Unique -> OccName -> Name -mkSystemName uniq occ = Name { n_uniq = getKeyFastInt uniq, n_sort = System, - n_occ = occ, n_loc = noSrcSpan } - -mkSystemVarName :: Unique -> FastString -> Name -mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) - -mkSysTvName :: Unique -> FastString -> Name -mkSysTvName uniq fs = mkSystemName uniq (mkOccNameFS tvName fs) - --- | Make a name for a foreign call -mkFCallName :: Unique -> String -> Name - -- The encoded string completely describes the ccall -mkFCallName uniq str = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal, - n_occ = mkVarOcc str, n_loc = noSrcSpan } - - -mkTickBoxOpName :: Unique -> String -> Name -mkTickBoxOpName uniq str - = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal, - n_occ = mkVarOcc str, n_loc = noSrcSpan } - --- | Make the name of an implicit parameter -mkIPName :: Unique -> OccName -> Name -mkIPName uniq occ - = Name { n_uniq = getKeyFastInt uniq, - n_sort = Internal, - n_occ = occ, - n_loc = noSrcSpan } -\end{code} - -\begin{code} --- When we renumber/rename things, we need to be --- able to change a Name's Unique to match the cached --- one in the thing it's the name of. If you know what I mean. -setNameUnique :: Name -> Unique -> Name -setNameUnique name uniq = name {n_uniq = getKeyFastInt uniq} - -tidyNameOcc :: Name -> OccName -> Name --- We set the OccName of a Name when tidying --- In doing so, we change System --> Internal, so that when we print --- it we don't get the unique by default. It's tidy now! -tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal} -tidyNameOcc name occ = name { n_occ = occ } - --- | Make the 'Name' into an internal name, regardless of what it was to begin with -localiseName :: Name -> Name -localiseName n = n { n_sort = Internal } -\end{code} - -%************************************************************************ -%* * -\subsection{Hashing and comparison} -%* * -%************************************************************************ - -\begin{code} -hashName :: Name -> Int -- ToDo: should really be Word -hashName name = getKey (nameUnique name) + 1 - -- The +1 avoids keys with lots of zeros in the ls bits, which - -- interacts badly with the cheap and cheerful multiplication in - -- hashExpr - -cmpName :: Name -> Name -> Ordering -cmpName n1 n2 = iBox (n_uniq n1) `compare` iBox (n_uniq n2) -\end{code} - -%************************************************************************ -%* * -\subsection[Name-instances]{Instance declarations} -%* * -%************************************************************************ - -\begin{code} -instance Eq Name where - a == b = case (a `compare` b) of { EQ -> True; _ -> False } - a /= b = case (a `compare` b) of { EQ -> False; _ -> True } - -instance Ord Name 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 = cmpName a b - -instance Uniquable Name where - getUnique = nameUnique - -instance NamedThing Name where - getName n = n -\end{code} - -%************************************************************************ -%* * -\subsection{Binary} -%* * -%************************************************************************ - -\begin{code} -instance Binary Name where - put_ bh name = - case getUserData bh of - UserData{ ud_put_name = put_name } -> put_name bh name - - get bh = do - i <- get bh - return $! (ud_symtab (getUserData bh) ! fromIntegral (i::Word32)) -\end{code} - -%************************************************************************ -%* * -\subsection{Pretty printing} -%* * -%************************************************************************ - -\begin{code} -instance Outputable Name where - ppr name = pprName name - -instance OutputableBndr Name where - pprBndr _ name = pprName name - -pprName :: Name -> SDoc -pprName (Name {n_sort = sort, n_uniq = u, n_occ = occ}) - = getPprStyle $ \ sty -> - case sort of - WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin - External mod -> pprExternal sty uniq mod occ False UserSyntax - System -> pprSystem sty uniq occ - Internal -> pprInternal sty uniq occ - where uniq = mkUniqueGrimily (iBox u) - -pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc -pprExternal sty uniq mod occ is_wired is_builtin - | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ - -- In code style, always qualify - -- ToDo: maybe we could print all wired-in things unqualified - -- in code style, to reduce symbol table bloat? - | debugStyle sty = ppr mod <> dot <> ppr_occ_name occ - <> braces (hsep [if is_wired then ptext (sLit "(w)") else empty, - pprNameSpaceBrief (occNameSpace occ), - pprUnique uniq]) - | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax - | otherwise = pprModulePrefix sty mod occ <> ppr_occ_name occ - -pprInternal :: PprStyle -> Unique -> OccName -> SDoc -pprInternal sty uniq occ - | codeStyle sty = pprUnique uniq - | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), - pprUnique uniq]) - | dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq - -- For debug dumps, we're not necessarily dumping - -- tidied code, so we need to print the uniques. - | otherwise = ppr_occ_name occ -- User style - --- Like Internal, except that we only omit the unique in Iface style -pprSystem :: PprStyle -> Unique -> OccName -> SDoc -pprSystem sty uniq occ - | codeStyle sty = pprUnique uniq - | debugStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq - <> braces (pprNameSpaceBrief (occNameSpace occ)) - | otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq - -- If the tidy phase hasn't run, the OccName - -- is unlikely to be informative (like 's'), - -- so print the unique - - -pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc --- Print the "M." part of a name, based on whether it's in scope or not --- See Note [Printing original names] in HscTypes -pprModulePrefix sty mod occ - = case qualName sty mod occ of -- See Outputable.QualifyName: - NameQual modname -> ppr modname <> dot -- Name is in scope - NameNotInScope1 -> ppr mod <> dot -- Not in scope - NameNotInScope2 -> ppr (modulePackageId mod) <> colon -- Module not in - <> ppr (moduleName mod) <> dot -- scope eithber - _otherwise -> empty - -ppr_underscore_unique :: Unique -> SDoc --- Print an underscore separating the name from its unique --- But suppress it if we aren't printing the uniques anyway -ppr_underscore_unique uniq - | opt_SuppressUniques = empty - | otherwise = char '_' <> pprUnique uniq - -ppr_occ_name :: OccName -> SDoc -ppr_occ_name occ = ftext (occNameFS occ) - -- Don't use pprOccName; instead, just print the string of the OccName; - -- we print the namespace in the debug stuff above - --- In code style, we Z-encode the strings. The results of Z-encoding each FastString are --- cached behind the scenes in the FastString implementation. -ppr_z_occ_name :: OccName -> SDoc -ppr_z_occ_name occ = ftext (zEncodeFS (occNameFS occ)) - --- 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 -\end{code} - -%************************************************************************ -%* * -\subsection{Overloaded functions related to Names} -%* * -%************************************************************************ - -\begin{code} --- | A class allowing convenient access to the 'Name' of various datatypes -class NamedThing a where - getOccName :: a -> OccName - getName :: a -> Name - - getOccName n = nameOccName (getName n) -- Default method -\end{code} - -\begin{code} -getSrcLoc :: NamedThing a => a -> SrcLoc -getSrcSpan :: NamedThing a => a -> SrcSpan -getOccString :: NamedThing a => a -> String - -getSrcLoc = nameSrcLoc . getName -getSrcSpan = nameSrcSpan . getName -getOccString = occNameString . getOccName - -pprInfixName, pprPrefixName :: (Outputable a, NamedThing a) => a -> SDoc --- See Outputable.pprPrefixVar, pprInfixVar; --- add parens or back-quotes as appropriate -pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) -pprPrefixName n = pprPrefixVar (isSymOcc (getOccName n)) (ppr n) -\end{code} - diff -ruN ghc-6.12.1/compiler/basicTypes/Name.lhs-boot ghc-6.13-20091231/compiler/basicTypes/Name.lhs-boot --- ghc-6.12.1/compiler/basicTypes/Name.lhs-boot 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/Name.lhs-boot 1969-12-31 16:00:00.000000000 -0800 @@ -1,5 +0,0 @@ -\begin{code} -module Name where - -data Name -\end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/NameSet.lhs ghc-6.13-20091231/compiler/basicTypes/NameSet.lhs --- ghc-6.12.1/compiler/basicTypes/NameSet.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/NameSet.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,198 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1998 -% - -\begin{code} -module NameSet ( - -- * Names set type - NameSet, - - -- ** Manipulating these sets - emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets, - minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet, - delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet, - intersectsNameSet, intersectNameSet, - - -- * Free variables - FreeVars, - - -- ** Manipulating sets of free variables - isEmptyFVs, emptyFVs, plusFVs, plusFV, - mkFVs, addOneFV, unitFV, delFV, delFVs, - - -- * Defs and uses - Defs, Uses, DefUse, DefUses, - - -- ** Manipulating defs and uses - emptyDUs, usesOnly, mkDUs, plusDU, - findUses, duDefs, duUses, allUses - ) where - -#include "HsVersions.h" - -import Name -import UniqSet -\end{code} - -%************************************************************************ -%* * -\subsection[Sets of names} -%* * -%************************************************************************ - -\begin{code} -type NameSet = UniqSet Name - -emptyNameSet :: NameSet -unitNameSet :: Name -> NameSet -addListToNameSet :: NameSet -> [Name] -> NameSet -addOneToNameSet :: NameSet -> Name -> NameSet -mkNameSet :: [Name] -> NameSet -unionNameSets :: NameSet -> NameSet -> NameSet -unionManyNameSets :: [NameSet] -> NameSet -minusNameSet :: NameSet -> NameSet -> NameSet -elemNameSet :: Name -> NameSet -> Bool -nameSetToList :: NameSet -> [Name] -isEmptyNameSet :: NameSet -> Bool -delFromNameSet :: NameSet -> Name -> NameSet -delListFromNameSet :: NameSet -> [Name] -> NameSet -foldNameSet :: (Name -> b -> b) -> b -> NameSet -> b -filterNameSet :: (Name -> Bool) -> NameSet -> NameSet -intersectNameSet :: NameSet -> NameSet -> NameSet -intersectsNameSet :: NameSet -> NameSet -> Bool --- ^ True if there is a non-empty intersection. --- @s1 `intersectsNameSet` s2@ doesn't compute @s2@ if @s1@ is empty - -isEmptyNameSet = isEmptyUniqSet -emptyNameSet = emptyUniqSet -unitNameSet = unitUniqSet -mkNameSet = mkUniqSet -addListToNameSet = addListToUniqSet -addOneToNameSet = addOneToUniqSet -unionNameSets = unionUniqSets -unionManyNameSets = unionManyUniqSets -minusNameSet = minusUniqSet -elemNameSet = elementOfUniqSet -nameSetToList = uniqSetToList -delFromNameSet = delOneFromUniqSet -foldNameSet = foldUniqSet -filterNameSet = filterUniqSet -intersectNameSet = intersectUniqSets - -delListFromNameSet set ns = foldl delFromNameSet set ns - -intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2)) -\end{code} - - -%************************************************************************ -%* * -\subsection{Free variables} -%* * -%************************************************************************ - -These synonyms are useful when we are thinking of free variables - -\begin{code} -type FreeVars = NameSet - -plusFV :: FreeVars -> FreeVars -> FreeVars -addOneFV :: FreeVars -> Name -> FreeVars -unitFV :: Name -> FreeVars -emptyFVs :: FreeVars -plusFVs :: [FreeVars] -> FreeVars -mkFVs :: [Name] -> FreeVars -delFV :: Name -> FreeVars -> FreeVars -delFVs :: [Name] -> FreeVars -> FreeVars - -isEmptyFVs :: NameSet -> Bool -isEmptyFVs = isEmptyNameSet -emptyFVs = emptyNameSet -plusFVs = unionManyNameSets -plusFV = unionNameSets -mkFVs = mkNameSet -addOneFV = addOneToNameSet -unitFV = unitNameSet -delFV n s = delFromNameSet s n -delFVs ns s = delListFromNameSet s ns -\end{code} - - -%************************************************************************ -%* * - Defs and uses -%* * -%************************************************************************ - -\begin{code} --- | A set of names that are defined somewhere -type Defs = NameSet - --- | A set of names that are used somewhere -type Uses = NameSet - --- | @(Just ds, us) =>@ The use of any member of the @ds@ --- implies that all the @us@ are used too. --- Also, @us@ may mention @ds@. --- --- @Nothing =>@ Nothing is defined in this group, but --- nevertheless all the uses are essential. --- Used for instance declarations, for example -type DefUse = (Maybe Defs, Uses) - --- | A number of 'DefUse's in dependency order: earlier 'Defs' scope over later 'Uses' -type DefUses = [DefUse] - -emptyDUs :: DefUses -emptyDUs = [] - -usesOnly :: Uses -> DefUses -usesOnly uses = [(Nothing, uses)] - -mkDUs :: [(Defs,Uses)] -> DefUses -mkDUs pairs = [(Just defs, uses) | (defs,uses) <- pairs] - -plusDU :: DefUses -> DefUses -> DefUses -plusDU = (++) - -duDefs :: DefUses -> Defs -duDefs dus = foldr get emptyNameSet dus - where - get (Nothing, _u1) d2 = d2 - get (Just d1, _u1) d2 = d1 `unionNameSets` d2 - -duUses :: DefUses -> Uses --- ^ Just like 'allUses', but 'Defs' are not eliminated from the 'Uses' returned -duUses dus = foldr get emptyNameSet dus - where - get (_d1, u1) u2 = u1 `unionNameSets` u2 - -allUses :: DefUses -> Uses --- ^ Collect all 'Uses', regardless of whether the group is itself used, --- but remove 'Defs' on the way -allUses 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) - `minusNameSet` defs - -findUses :: DefUses -> Uses -> Uses --- ^ Given some 'DefUses' and some 'Uses', find all the uses, transitively. --- The result is a superset of the input 'Uses'; and includes things defined --- in the input 'DefUses' (but only if they are used) -findUses dus uses - = foldr get uses dus - where - get (Nothing, rhs_uses) uses - = rhs_uses `unionNameSets` uses - get (Just defs, rhs_uses) uses - | defs `intersectsNameSet` uses -- Used - || any (startsWithUnderscore . nameOccName) (nameSetToList defs) - -- At least one starts with an "_", - -- so treat the group as used - = rhs_uses `unionNameSets` uses - | otherwise -- No def is used - = uses -\end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/NewDemand.lhs ghc-6.13-20091231/compiler/basicTypes/NewDemand.lhs --- ghc-6.12.1/compiler/basicTypes/NewDemand.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/NewDemand.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,342 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[Demand]{@Demand@: the amount of demand on a value} - -\begin{code} -module NewDemand( - Demand(..), - topDmd, lazyDmd, seqDmd, evalDmd, errDmd, isStrictDmd, - isTop, isAbsent, seqDemand, - - DmdType(..), topDmdType, botDmdType, mkDmdType, mkTopDmdType, - dmdTypeDepth, seqDmdType, - DmdEnv, emptyDmdEnv, - DmdResult(..), retCPR, isBotRes, returnsCPR, resTypeArgDmd, - - Demands(..), mapDmds, zipWithDmds, allTop, seqDemands, - - StrictSig(..), mkStrictSig, topSig, botSig, cprSig, - isTopSig, - splitStrictSig, increaseStrictSigArity, - pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig, - ) where - -#include "HsVersions.h" - -import StaticFlags -import BasicTypes -import VarEnv -import UniqFM -import Util -import Outputable -\end{code} - - -%************************************************************************ -%* * -\subsection{Demands} -%* * -%************************************************************************ - -\begin{code} -data Demand - = Top -- T; used for unlifted types too, so that - -- A `lub` T = T - | Abs -- A - - | Call Demand -- C(d) - - | Eval Demands -- U(ds) - - | Defer Demands -- D(ds) - - | Box Demand -- B(d) - - | Bot -- B - deriving( Eq ) - -- Equality needed for fixpoints in DmdAnal - -data Demands = Poly Demand -- Polymorphic case - | Prod [Demand] -- Product case - deriving( Eq ) - -allTop :: Demands -> Bool -allTop (Poly d) = isTop d -allTop (Prod ds) = all isTop ds - -isTop :: Demand -> Bool -isTop Top = True -isTop _ = False - -isAbsent :: Demand -> Bool -isAbsent Abs = True -isAbsent _ = False - -mapDmds :: (Demand -> Demand) -> Demands -> Demands -mapDmds f (Poly d) = Poly (f d) -mapDmds f (Prod ds) = Prod (map f ds) - -zipWithDmds :: (Demand -> Demand -> Demand) - -> Demands -> Demands -> Demands -zipWithDmds f (Poly d1) (Poly d2) = Poly (d1 `f` d2) -zipWithDmds f (Prod ds1) (Poly d2) = Prod [d1 `f` d2 | d1 <- ds1] -zipWithDmds f (Poly d1) (Prod ds2) = Prod [d1 `f` d2 | d2 <- ds2] -zipWithDmds f (Prod ds1) (Prod ds2) - | length ds1 == length ds2 = Prod (zipWithEqual "zipWithDmds" f ds1 ds2) - | otherwise = Poly topDmd - -- This really can happen with polymorphism - -- \f. case f x of (a,b) -> ... - -- case f y of (a,b,c) -> ... - -- Here the two demands on f are C(LL) and C(LLL)! - -topDmd, lazyDmd, seqDmd, evalDmd, errDmd :: Demand -topDmd = Top -- The most uninformative demand -lazyDmd = Box Abs -seqDmd = Eval (Poly Abs) -- Polymorphic seq demand -evalDmd = Box seqDmd -- Evaluate and return -errDmd = Box Bot -- This used to be called X - -isStrictDmd :: Demand -> Bool -isStrictDmd Bot = True -isStrictDmd (Eval _) = True -isStrictDmd (Call _) = True -isStrictDmd (Box d) = isStrictDmd d -isStrictDmd _ = False - -seqDemand :: Demand -> () -seqDemand (Call d) = seqDemand d -seqDemand (Eval ds) = seqDemands ds -seqDemand (Defer ds) = seqDemands ds -seqDemand (Box d) = seqDemand d -seqDemand _ = () - -seqDemands :: Demands -> () -seqDemands (Poly d) = seqDemand d -seqDemands (Prod ds) = seqDemandList ds - -seqDemandList :: [Demand] -> () -seqDemandList [] = () -seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds - -instance Outputable Demand where - ppr Top = char 'T' - ppr Abs = char 'A' - ppr Bot = char 'B' - - ppr (Defer ds) = char 'D' <> ppr ds - ppr (Eval ds) = char 'U' <> ppr ds - - ppr (Box (Eval ds)) = char 'S' <> ppr ds - ppr (Box Abs) = char 'L' - ppr (Box Bot) = char 'X' - ppr d@(Box _) = pprPanic "ppr: Bad boxed demand" (ppr d) - - ppr (Call d) = char 'C' <> parens (ppr d) - - -instance Outputable Demands where - ppr (Poly Abs) = empty - ppr (Poly d) = parens (ppr d <> char '*') - ppr (Prod ds) = parens (hcat (map ppr ds)) - -- At one time I printed U(AAA) as U, but that - -- confuses (Poly Abs) with (Prod AAA), and the - -- worker/wrapper generation differs slightly for these two - -- [Reason: in the latter case we can avoid passing the arg; - -- see notes with WwLib.mkWWstr_one.] -\end{code} - - -%************************************************************************ -%* * -\subsection{Demand types} -%* * -%************************************************************************ - -\begin{code} -data DmdType = DmdType - DmdEnv -- Demand on explicitly-mentioned - -- free variables - [Demand] -- Demand on arguments - DmdResult -- Nature of result - - -- IMPORTANT INVARIANT - -- The default demand on free variables not in the DmdEnv is: - -- DmdResult = BotRes <=> Bot - -- DmdResult = TopRes/ResCPR <=> Abs - - -- ANOTHER IMPORTANT INVARIANT - -- The Demands in the argument list are never - -- Bot, Defer d - -- Handwavey reason: these don't correspond to calling conventions - -- See DmdAnal.funArgDemand for details - - --- This guy lets us switch off CPR analysis --- by making sure that everything uses TopRes instead of RetCPR --- Assuming, of course, that they don't mention RetCPR by name. --- They should onlyu use retCPR -retCPR :: DmdResult -retCPR | opt_CprOff = TopRes - | otherwise = RetCPR - -seqDmdType :: DmdType -> () -seqDmdType (DmdType _env ds res) = - {- ??? env `seq` -} seqDemandList ds `seq` res `seq` () - -type DmdEnv = VarEnv Demand - -data DmdResult = TopRes -- Nothing known - | RetCPR -- Returns a constructed product - | BotRes -- Diverges or errors - deriving( Eq, Show ) - -- Equality for fixpoints - -- Show needed for Show in Lex.Token (sigh) - --- Equality needed for fixpoints in DmdAnal -instance Eq DmdType where - (==) (DmdType fv1 ds1 res1) - (DmdType fv2 ds2 res2) = ufmToList fv1 == ufmToList fv2 - && ds1 == ds2 && res1 == res2 - -instance Outputable DmdType where - ppr (DmdType fv ds res) - = hsep [text "DmdType", - hcat (map ppr ds) <> ppr res, - if null fv_elts then empty - else braces (fsep (map pp_elt fv_elts))] - where - pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd - fv_elts = ufmToList fv - -instance Outputable DmdResult where - ppr TopRes = empty -- Keep these distinct from Demand letters - ppr RetCPR = char 'm' -- so that we can print strictness sigs as - ppr BotRes = char 'b' -- dddr - -- without ambiguity - -emptyDmdEnv :: VarEnv Demand -emptyDmdEnv = emptyVarEnv - -topDmdType, botDmdType, cprDmdType :: DmdType -topDmdType = DmdType emptyDmdEnv [] TopRes -botDmdType = DmdType emptyDmdEnv [] BotRes -cprDmdType = DmdType emptyVarEnv [] retCPR - -isTopDmdType :: DmdType -> Bool --- Only used on top-level types, hence the assert -isTopDmdType (DmdType env [] TopRes) = ASSERT( isEmptyVarEnv env) True -isTopDmdType _ = False - -isBotRes :: DmdResult -> Bool -isBotRes BotRes = True -isBotRes _ = False - -resTypeArgDmd :: DmdResult -> Demand --- TopRes and BotRes are polymorphic, so that --- BotRes = Bot -> BotRes --- TopRes = Top -> TopRes --- This function makes that concrete --- We can get a RetCPR, because of the way in which we are (now) --- giving CPR info to strict arguments. On the first pass, when --- nothing has demand info, we optimistically give CPR info or RetCPR to all args -resTypeArgDmd TopRes = Top -resTypeArgDmd RetCPR = Top -resTypeArgDmd BotRes = Bot - -returnsCPR :: DmdResult -> Bool -returnsCPR RetCPR = True -returnsCPR _ = False - -mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType -mkDmdType fv ds res = DmdType fv ds res - -mkTopDmdType :: [Demand] -> DmdResult -> DmdType -mkTopDmdType ds res = DmdType emptyDmdEnv ds res - -dmdTypeDepth :: DmdType -> Arity -dmdTypeDepth (DmdType _ ds _) = length ds -\end{code} - - -%************************************************************************ -%* * -\subsection{Strictness signature -%* * -%************************************************************************ - -In a let-bound Id we record its strictness info. -In principle, this strictness info is a demand transformer, mapping -a demand on the Id into a DmdType, which gives - a) the free vars of the Id's value - b) the Id's arguments - c) an indication of the result of applying - the Id to its arguments - -However, in fact we store in the Id an extremely emascuated demand transfomer, -namely - a single DmdType -(Nevertheless we dignify StrictSig as a distinct type.) - -This DmdType gives the demands unleashed by the Id when it is applied -to as many arguments as are given in by the arg demands in the DmdType. - -For example, the demand transformer described by the DmdType - DmdType {x -> U(LL)} [V,A] Top -says that when the function is applied to two arguments, it -unleashes demand U(LL) on the free var x, V on the first arg, -and A on the second. - -If this same function is applied to one arg, all we can say is -that it uses x with U*(LL), and its arg with demand L. - -\begin{code} -newtype StrictSig = StrictSig DmdType - deriving( Eq ) - -instance Outputable StrictSig where - ppr (StrictSig ty) = ppr ty - -instance Show StrictSig where - show (StrictSig ty) = showSDoc (ppr ty) - -mkStrictSig :: DmdType -> StrictSig -mkStrictSig dmd_ty = StrictSig dmd_ty - -splitStrictSig :: StrictSig -> ([Demand], DmdResult) -splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) - -increaseStrictSigArity :: Int -> StrictSig -> StrictSig --- Add extra arguments to a strictness signature -increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res)) - = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res) - -isTopSig :: StrictSig -> Bool -isTopSig (StrictSig ty) = isTopDmdType ty - -topSig, botSig, cprSig :: StrictSig -topSig = StrictSig topDmdType -botSig = StrictSig botDmdType -cprSig = StrictSig cprDmdType - - --- appIsBottom returns true if an application to n args would diverge -appIsBottom :: StrictSig -> Int -> Bool -appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT -appIsBottom _ _ = False - -isBottomingSig :: StrictSig -> Bool -isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True -isBottomingSig _ = False - -seqStrictSig :: StrictSig -> () -seqStrictSig (StrictSig ty) = seqDmdType ty - -pprIfaceStrictSig :: StrictSig -> SDoc --- Used for printing top-level strictness pragmas in interface files -pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) - = hcat (map ppr dmds) <> ppr res -\end{code} - - diff -ruN ghc-6.12.1/compiler/basicTypes/OccName.lhs ghc-6.13-20091231/compiler/basicTypes/OccName.lhs --- ghc-6.12.1/compiler/basicTypes/OccName.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/OccName.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,819 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -\begin{code} --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName' represents names as strings with just a little more information: --- the \"namespace\" that the name came from, e.g. the namespace of value, type constructors or --- data constructors --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var': see "Var#name_types" -module OccName ( - -- * The 'NameSpace' type - NameSpace, -- Abstract - - -- ** Construction - -- $real_vs_source_data_constructors - tcName, clsName, tcClsName, dataName, varName, - tvName, srcDataName, - - -- ** Pretty Printing - pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief, - - -- * The 'OccName' type - OccName, -- Abstract, instance of Outputable - pprOccName, - - -- ** Construction - mkOccName, mkOccNameFS, - mkVarOcc, mkVarOccFS, - mkDataOcc, mkDataOccFS, - mkTyVarOcc, mkTyVarOccFS, - mkTcOcc, mkTcOccFS, - mkClsOcc, mkClsOccFS, - mkDFunOcc, - mkTupleOcc, - setOccNameSpace, - - -- ** Derived 'OccName's - isDerivedOccName, - mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, - mkDerivedTyConOcc, mkNewTyCoOcc, - mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, - mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, - mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, - mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, - mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, - mkInstTyCoOcc, mkEqPredCoOcc, - mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, - mkPDataTyConOcc, mkPDataDataConOcc, - mkPReprTyConOcc, - mkPADFunOcc, - - -- ** Deconstruction - occNameFS, occNameString, occNameSpace, - - isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, - parenSymOcc, startsWithUnderscore, - - isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace, - - isTupleOcc_maybe, - - -- * The 'OccEnv' type - OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, - lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, - occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, - filterOccEnv, delListFromOccEnv, delFromOccEnv, - - -- * The 'OccSet' type - OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, - extendOccSetList, - unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, occSetElts, - foldOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet, - - -- * Tidying up - TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv, - - -- * Lexical characteristics of Haskell names - isLexCon, isLexVar, isLexId, isLexSym, - isLexConId, isLexConSym, isLexVarId, isLexVarSym, - startsVarSym, startsVarId, startsConSym, startsConId - ) where - -import Util -import Unique -import BasicTypes -import UniqFM -import UniqSet -import FastString -import FastTypes -import Outputable -import Binary -import Data.Char -\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} -%* * -%************************************************************************ - -\begin{code} -data NameSpace = VarName -- Variables, including "real" data constructors - | DataName -- "Source" data constructors - | TvName -- Type variables - | TcClsName -- Type constructors and classes; Haskell has them - -- in the same name space for now. - deriving( Eq, Ord ) - {-! derive: Binary !-} - --- Note [Data Constructors] --- see also: Note [Data Constructor Naming] in DataCon.lhs --- --- $real_vs_source_data_constructors --- There are two forms of data constructor: --- --- [Source data constructors] The data constructors mentioned in Haskell source code --- --- [Real data constructors] The data constructors of the representation type, which may not be the same as the source type --- --- For example: --- --- > data T = T !(Int, Int) --- --- The source datacon has type @(Int, Int) -> T@ --- The real datacon has type @Int -> Int -> T@ --- --- GHC chooses a representation based on the strictness etc. - -tcName, clsName, tcClsName :: NameSpace -dataName, srcDataName :: NameSpace -tvName, varName :: NameSpace - --- Though type constructors and classes are in the same name space now, --- the NameSpace type is abstract, so we can easily separate them later -tcName = TcClsName -- Type constructors -clsName = TcClsName -- Classes -tcClsName = TcClsName -- Not sure which! - -dataName = DataName -srcDataName = DataName -- Haskell-source data constructors should be - -- in the Data name space - -tvName = TvName -varName = VarName - -isDataConNameSpace :: NameSpace -> Bool -isDataConNameSpace DataName = True -isDataConNameSpace _ = False - -isTcClsNameSpace :: NameSpace -> Bool -isTcClsNameSpace TcClsName = True -isTcClsNameSpace _ = False - -isTvNameSpace :: NameSpace -> Bool -isTvNameSpace TvName = True -isTvNameSpace _ = False - -isVarNameSpace :: NameSpace -> Bool -- Variables or type variables, but not constructors -isVarNameSpace TvName = True -isVarNameSpace VarName = True -isVarNameSpace _ = False - -isValNameSpace :: NameSpace -> Bool -isValNameSpace DataName = True -isValNameSpace VarName = True -isValNameSpace _ = False - -pprNameSpace :: NameSpace -> SDoc -pprNameSpace DataName = ptext (sLit "data constructor") -pprNameSpace VarName = ptext (sLit "variable") -pprNameSpace TvName = ptext (sLit "type variable") -pprNameSpace TcClsName = ptext (sLit "type constructor or class") - -pprNonVarNameSpace :: NameSpace -> SDoc -pprNonVarNameSpace VarName = empty -pprNonVarNameSpace ns = pprNameSpace ns - -pprNameSpaceBrief :: NameSpace -> SDoc -pprNameSpaceBrief DataName = char 'd' -pprNameSpaceBrief VarName = char 'v' -pprNameSpaceBrief TvName = ptext (sLit "tv") -pprNameSpaceBrief TcClsName = ptext (sLit "tc") -\end{code} - - -%************************************************************************ -%* * -\subsection[Name-pieces-datatypes]{The @OccName@ datatypes} -%* * -%************************************************************************ - -\begin{code} -data OccName = OccName - { occNameSpace :: !NameSpace - , occNameFS :: !FastString - } -\end{code} - - -\begin{code} -instance Eq OccName where - (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2 - -instance Ord OccName where - -- Compares lexicographically, *not* by Unique of the string - compare (OccName sp1 s1) (OccName sp2 s2) - = (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2) -\end{code} - - -%************************************************************************ -%* * -\subsection{Printing} -%* * -%************************************************************************ - -\begin{code} -instance Outputable OccName where - ppr = pprOccName - -pprOccName :: OccName -> SDoc -pprOccName (OccName sp occ) - = getPprStyle $ \ sty -> - if codeStyle sty - then ftext (zEncodeFS occ) - else ftext occ <> if debugStyle sty - then braces (pprNameSpaceBrief sp) - else empty -\end{code} - - -%************************************************************************ -%* * -\subsection{Construction} -%* * -%************************************************************************ - -\begin{code} -mkOccName :: NameSpace -> String -> OccName -mkOccName occ_sp str = OccName occ_sp (mkFastString str) - -mkOccNameFS :: NameSpace -> FastString -> OccName -mkOccNameFS occ_sp fs = OccName occ_sp fs - -mkVarOcc :: String -> OccName -mkVarOcc s = mkOccName varName s - -mkVarOccFS :: FastString -> OccName -mkVarOccFS fs = mkOccNameFS varName fs - -mkDataOcc :: String -> OccName -mkDataOcc = mkOccName dataName - -mkDataOccFS :: FastString -> OccName -mkDataOccFS = mkOccNameFS dataName - -mkTyVarOcc :: String -> OccName -mkTyVarOcc = mkOccName tvName - -mkTyVarOccFS :: FastString -> OccName -mkTyVarOccFS fs = mkOccNameFS tvName fs - -mkTcOcc :: String -> OccName -mkTcOcc = mkOccName tcName - -mkTcOccFS :: FastString -> OccName -mkTcOccFS = mkOccNameFS tcName - -mkClsOcc :: String -> OccName -mkClsOcc = mkOccName clsName - -mkClsOccFS :: FastString -> OccName -mkClsOccFS = mkOccNameFS clsName -\end{code} - - -%************************************************************************ -%* * - Environments -%* * -%************************************************************************ - -OccEnvs are used mainly for the envts in ModIfaces. - -They are efficient, because FastStrings have unique Int# keys. We assume -this key is less than 2^24, so we can make a Unique using - mkUnique ns key :: Unique -where 'ns' is a Char reprsenting the name space. This in turn makes it -easy to build an OccEnv. - -\begin{code} -instance Uniquable OccName where - getUnique (OccName ns fs) - = mkUnique char (iBox (uniqueOfFS fs)) - where -- See notes above about this getUnique function - char = case ns of - VarName -> 'i' - DataName -> 'd' - TvName -> 'v' - TcClsName -> 't' - -newtype OccEnv a = A (UniqFM a) - -emptyOccEnv :: OccEnv a -unitOccEnv :: OccName -> a -> OccEnv a -extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a -extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a -lookupOccEnv :: OccEnv a -> OccName -> Maybe a -mkOccEnv :: [(OccName,a)] -> OccEnv a -mkOccEnv_C :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a -elemOccEnv :: OccName -> OccEnv a -> Bool -foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b -occEnvElts :: OccEnv a -> [a] -extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a -plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a -plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a -mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b -delFromOccEnv :: OccEnv a -> OccName -> OccEnv a -delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a -filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt - -emptyOccEnv = A emptyUFM -unitOccEnv x y = A $ unitUFM x y -extendOccEnv (A x) y z = A $ addToUFM x y z -extendOccEnvList (A x) l = A $ addListToUFM x l -lookupOccEnv (A x) y = lookupUFM x y -mkOccEnv l = A $ listToUFM l -elemOccEnv x (A y) = elemUFM x y -foldOccEnv a b (A c) = foldUFM a b c -occEnvElts (A x) = eltsUFM x -plusOccEnv (A x) (A y) = A $ plusUFM x y -plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y -extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z -mapOccEnv f (A x) = A $ mapUFM f x -mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l -delFromOccEnv (A x) y = A $ delFromUFM x y -delListFromOccEnv (A x) y = A $ delListFromUFM x y -filterOccEnv x (A y) = A $ filterUFM x y - -instance Outputable a => Outputable (OccEnv a) where - ppr (A x) = ppr x - -type OccSet = UniqSet OccName - -emptyOccSet :: OccSet -unitOccSet :: OccName -> OccSet -mkOccSet :: [OccName] -> OccSet -extendOccSet :: OccSet -> OccName -> OccSet -extendOccSetList :: OccSet -> [OccName] -> OccSet -unionOccSets :: OccSet -> OccSet -> OccSet -unionManyOccSets :: [OccSet] -> OccSet -minusOccSet :: OccSet -> OccSet -> OccSet -elemOccSet :: OccName -> OccSet -> Bool -occSetElts :: OccSet -> [OccName] -foldOccSet :: (OccName -> b -> b) -> b -> OccSet -> b -isEmptyOccSet :: OccSet -> Bool -intersectOccSet :: OccSet -> OccSet -> OccSet -intersectsOccSet :: OccSet -> OccSet -> Bool - -emptyOccSet = emptyUniqSet -unitOccSet = unitUniqSet -mkOccSet = mkUniqSet -extendOccSet = addOneToUniqSet -extendOccSetList = addListToUniqSet -unionOccSets = unionUniqSets -unionManyOccSets = unionManyUniqSets -minusOccSet = minusUniqSet -elemOccSet = elementOfUniqSet -occSetElts = uniqSetToList -foldOccSet = foldUniqSet -isEmptyOccSet = isEmptyUniqSet -intersectOccSet = intersectUniqSets -intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2)) -\end{code} - - -%************************************************************************ -%* * -\subsection{Predicates and taking them apart} -%* * -%************************************************************************ - -\begin{code} -occNameString :: OccName -> String -occNameString (OccName _ s) = unpackFS s - -setOccNameSpace :: NameSpace -> OccName -> OccName -setOccNameSpace sp (OccName _ occ) = OccName sp occ - -isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool - -isVarOcc (OccName VarName _) = True -isVarOcc _ = False - -isTvOcc (OccName TvName _) = True -isTvOcc _ = False - -isTcOcc (OccName TcClsName _) = True -isTcOcc _ = False - --- | /Value/ 'OccNames's are those that are either in --- the variable or data constructor namespaces -isValOcc :: OccName -> Bool -isValOcc (OccName VarName _) = True -isValOcc (OccName DataName _) = True -isValOcc _ = False - -isDataOcc (OccName DataName _) = True -isDataOcc (OccName VarName s) - | isLexCon s = pprPanic "isDataOcc: check me" (ppr s) - -- Jan06: I don't think this should happen -isDataOcc _ = False - --- | Test if the 'OccName' is a data constructor that starts with --- a symbol (e.g. @:@, or @[]@) -isDataSymOcc :: OccName -> Bool -isDataSymOcc (OccName DataName s) = isLexConSym s -isDataSymOcc (OccName VarName s) - | isLexConSym s = pprPanic "isDataSymOcc: check me" (ppr s) - -- Jan06: I don't think this should happen -isDataSymOcc _ = False --- Pretty inefficient! - --- | Test if the 'OccName' is that for any operator (whether --- it is a data constructor or variable or whatever) -isSymOcc :: OccName -> Bool -isSymOcc (OccName DataName s) = isLexConSym s -isSymOcc (OccName TcClsName s) = isLexConSym s -isSymOcc (OccName VarName s) = isLexSym s -isSymOcc (OccName TvName s) = isLexSym s --- Pretty inefficient! - -parenSymOcc :: OccName -> SDoc -> SDoc --- ^ Wrap parens around an operator -parenSymOcc occ doc | isSymOcc occ = parens doc - | otherwise = doc -\end{code} - - -\begin{code} -startsWithUnderscore :: OccName -> Bool --- ^ Haskell 98 encourages compilers to suppress warnings about unsed --- names in a pattern if they start with @_@: this implements that test -startsWithUnderscore occ = case occNameString occ of - ('_' : _) -> True - _other -> False -\end{code} - - -%************************************************************************ -%* * -\subsection{Making system names} -%* * -%************************************************************************ - -Here's our convention for splitting up the interface file name space: - - d... dictionary identifiers - (local variables, so no name-clash worries) - -All of these other OccNames contain a mixture of alphabetic -and symbolic characters, and hence cannot possibly clash with -a user-written type or function name - - $f... Dict-fun identifiers (from inst decls) - $dmop Default method for 'op' - $pnC n'th superclass selector for class C - $wf Worker for functtoin 'f' - $sf.. Specialised version of f - T:C Tycon for dictionary for class C - D:C Data constructor for dictionary for class C - NTCo:T Coercion connecting newtype T with its representation type - TFCo:R Coercion connecting a data family to its respresentation type R - -In encoded form these appear as Zdfxxx etc - - :... keywords (export:, letrec: etc.) ---- I THINK THIS IS WRONG! - -This knowledge is encoded in the following functions. - -@mk_deriv@ generates an @OccName@ from the prefix and a string. -NB: The string must already be encoded! - -\begin{code} -mk_deriv :: NameSpace - -> String -- Distinguishes one sort of derived name from another - -> String - -> OccName - -mk_deriv occ_sp sys_prefix str = mkOccName occ_sp (sys_prefix ++ str) - -isDerivedOccName :: OccName -> Bool -isDerivedOccName occ = - case occNameString occ of - '$':c:_ | isAlphaNum c -> True - ':':c:_ | isAlphaNum c -> True - _other -> False -\end{code} - -\begin{code} -mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, - mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, - mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, - mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, - mkInstTyCoOcc, mkEqPredCoOcc, - mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, - mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, - mkPDataTyConOcc, mkPDataDataConOcc, mkPReprTyConOcc, mkPADFunOcc - :: OccName -> OccName - --- These derived variables have a prefix that no Haskell value could have -mkDataConWrapperOcc = mk_simple_deriv varName "$W" -mkWorkerOcc = mk_simple_deriv varName "$w" -mkDefaultMethodOcc = mk_simple_deriv varName "$dm" -mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies -mkClassTyConOcc = mk_simple_deriv tcName "T:" -- as a tycon/datacon -mkClassDataConOcc = mk_simple_deriv dataName "D:" -- We go straight to the "real" data con - -- for datacons from classes -mkDictOcc = mk_simple_deriv varName "$d" -mkIPOcc = mk_simple_deriv varName "$i" -mkSpecOcc = mk_simple_deriv varName "$s" -mkForeignExportOcc = mk_simple_deriv varName "$f" -mkNewTyCoOcc = mk_simple_deriv tcName "NTCo:" -- Coercion for newtypes -mkInstTyCoOcc = mk_simple_deriv tcName "TFCo:" -- Coercion for type functions -mkEqPredCoOcc = mk_simple_deriv tcName "$co" - --- used in derived instances -mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" -mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" -mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" - --- Generic derivable classes -mkGenOcc1 = mk_simple_deriv varName "$gfrom" -mkGenOcc2 = mk_simple_deriv varName "$gto" - --- data T = MkT ... deriving( Data ) needs defintions for --- $tT :: Data.Generics.Basics.DataType --- $cMkT :: Data.Generics.Basics.Constr -mkDataTOcc = mk_simple_deriv varName "$t" -mkDataCOcc = mk_simple_deriv varName "$c" - --- Vectorisation -mkVectOcc = mk_simple_deriv varName "$v_" -mkVectTyConOcc = mk_simple_deriv tcName ":V_" -mkVectDataConOcc = mk_simple_deriv dataName ":VD_" -mkVectIsoOcc = mk_simple_deriv varName "$VI_" -mkPDataTyConOcc = mk_simple_deriv tcName ":VP_" -mkPDataDataConOcc = mk_simple_deriv dataName ":VPD_" -mkPReprTyConOcc = mk_simple_deriv tcName ":VR_" -mkPADFunOcc = mk_simple_deriv varName "$PA_" - -mk_simple_deriv :: NameSpace -> String -> OccName -> OccName -mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ) - --- Data constructor workers are made by setting the name space --- of the data constructor OccName (which should be a DataName) --- to VarName -mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ -\end{code} - -\begin{code} -mkSuperDictSelOcc :: Int -- ^ Index of superclass, e.g. 3 - -> OccName -- ^ Class, e.g. @Ord@ - -> OccName -- ^ Derived 'Occname', e.g. @$p3Ord@ -mkSuperDictSelOcc index cls_occ - = mk_deriv varName "$p" (show index ++ occNameString cls_occ) - -mkLocalOcc :: Unique -- ^ Unique to combine with the 'OccName' - -> OccName -- ^ Local name, e.g. @sat@ - -> OccName -- ^ Nice unique version, e.g. @$L23sat@ -mkLocalOcc uniq occ - = mk_deriv varName ("$L" ++ show uniq) (occNameString occ) - -- The Unique might print with characters - -- that need encoding (e.g. 'z'!) -\end{code} - -\begin{code} --- | Derive a name for the representation type constructor of a --- @data@\/@newtype@ instance. -mkInstTyTcOcc :: String -- ^ Family name, e.g. @Map@ - -> OccSet -- ^ avoid these Occs - -> OccName -- ^ @R:Map@ -mkInstTyTcOcc str set = - chooseUniqueOcc tcName ('R' : ':' : str) set -\end{code} - -\begin{code} -mkDFunOcc :: String -- ^ Typically the class and type glommed together e.g. @OrdMaybe@. - -- Only used in debug mode, for extra clarity - -> Bool -- ^ Is this a hs-boot instance DFun? - -> OccSet -- ^ avoid these Occs - -> OccName -- ^ E.g. @$f3OrdMaybe@ - --- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real --- thing when we compile the mother module. Reason: we don't know exactly --- what the mother module will call it. - -mkDFunOcc info_str is_boot set - = chooseUniqueOcc VarName (prefix ++ info_str) set - where - prefix | is_boot = "$fx" - | otherwise = "$f" -\end{code} - -Sometimes we need to pick an OccName that has not already been used, -given a set of in-use OccNames. - -\begin{code} -chooseUniqueOcc :: NameSpace -> String -> OccSet -> OccName -chooseUniqueOcc ns str set = loop (mkOccName ns str) (0::Int) - where - loop occ n - | occ `elemOccSet` set = loop (mkOccName ns (str ++ show n)) (n+1) - | otherwise = occ -\end{code} - -We used to add a '$m' to indicate a method, but that gives rise to bad -error messages from the type checker when we print the function name or pattern -of an instance-decl binding. Why? Because the binding is zapped -to use the method name in place of the selector name. -(See TcClassDcl.tcMethodBind) - -The way it is now, -ddump-xx output may look confusing, but -you can always say -dppr-debug to get the uniques. - -However, we *do* have to zap the first character to be lower case, -because overloaded constructors (blarg) generate methods too. -And convert to VarName space - -e.g. a call to constructor MkFoo where - data (Ord a) => Foo a = MkFoo a - -If this is necessary, we do it by prefixing '$m'. These -guys never show up in error messages. What a hack. - -\begin{code} -mkMethodOcc :: OccName -> OccName -mkMethodOcc occ@(OccName VarName _) = occ -mkMethodOcc occ = mk_simple_deriv varName "$m" occ -\end{code} - - -%************************************************************************ -%* * -\subsection{Tidying them up} -%* * -%************************************************************************ - -Before we print chunks of code we like to rename it so that -we don't have to print lots of silly uniques in it. But we mustn't -accidentally introduce name clashes! So the idea is that we leave the -OccName alone unless it accidentally clashes with one that is already -in scope; if so, we tack on '1' at the end and try again, then '2', and -so on till we find a unique one. - -There's a wrinkle for operators. Consider '>>='. We can't use '>>=1' -because that isn't a single lexeme. So we encode it to 'lle' and *then* -tack on the '1', if necessary. - -\begin{code} -type TidyOccEnv = OccEnv Int -- The in-scope OccNames - -- Range gives a plausible starting point for new guesses - -emptyTidyOccEnv :: TidyOccEnv -emptyTidyOccEnv = emptyOccEnv - -initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! -initTidyOccEnv = foldl (\env occ -> extendOccEnv env occ 1) emptyTidyOccEnv - -tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) - -tidyOccName in_scope occ@(OccName occ_sp fs) - = case lookupOccEnv in_scope occ of - Nothing -> -- Not already used: make it used - (extendOccEnv in_scope occ 1, occ) - - Just n -> -- Already used: make a new guess, - -- change the guess base, and try again - tidyOccName (extendOccEnv in_scope occ (n+1)) - (mkOccName occ_sp (unpackFS fs ++ show n)) -\end{code} - -%************************************************************************ -%* * - Stuff for dealing with tuples -%* * -%************************************************************************ - -\begin{code} -mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName -mkTupleOcc ns bx ar = OccName ns (mkFastString str) - where - -- no need to cache these, the caching is done in the caller - -- (TysWiredIn.mk_tuple) - str = case bx of - Boxed -> '(' : commas ++ ")" - Unboxed -> '(' : '#' : commas ++ "#)" - - commas = take (ar-1) (repeat ',') - -isTupleOcc_maybe :: OccName -> Maybe (NameSpace, Boxity, Arity) --- Tuples are special, because there are so many of them! -isTupleOcc_maybe (OccName ns fs) - = case unpackFS fs of - '(':'#':',':rest -> Just (ns, Unboxed, 2 + count_commas rest) - '(':',':rest -> Just (ns, Boxed, 2 + count_commas rest) - _other -> Nothing - where - count_commas (',':rest) = 1 + count_commas rest - count_commas _ = 0 -\end{code} - -%************************************************************************ -%* * -\subsection{Lexical categories} -%* * -%************************************************************************ - -These functions test strings to see if they fit the lexical categories -defined in the Haskell report. - -\begin{code} -isLexCon, isLexVar, isLexId, isLexSym :: FastString -> Bool -isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool - -isLexCon cs = isLexConId cs || isLexConSym cs -isLexVar cs = isLexVarId cs || isLexVarSym cs - -isLexId cs = isLexConId cs || isLexVarId cs -isLexSym cs = isLexConSym cs || isLexVarSym cs - -------------- - -isLexConId cs -- Prefix type or data constructors - | nullFS cs = False -- e.g. "Foo", "[]", "(,)" - | cs == (fsLit "[]") = True - | otherwise = startsConId (headFS cs) - -isLexVarId cs -- Ordinary prefix identifiers - | nullFS cs = False -- e.g. "x", "_x" - | otherwise = startsVarId (headFS cs) - -isLexConSym cs -- Infix type or data constructors - | nullFS cs = False -- e.g. ":-:", ":", "->" - | cs == (fsLit "->") = True - | otherwise = startsConSym (headFS cs) - -isLexVarSym cs -- Infix identifiers - | nullFS cs = False -- e.g. "+" - | otherwise = startsVarSym (headFS cs) - -------------- -startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool -startsVarSym c = isSymbolASCII c || (ord c > 0x7f && isSymbol c) -- Infix Ids -startsConSym c = c == ':' -- Infix data constructors -startsVarId c = isLower c || c == '_' -- Ordinary Ids -startsConId c = isUpper c || c == '(' -- Ordinary type constructors and data constructors - -isSymbolASCII :: Char -> Bool -isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" -\end{code} - -%************************************************************************ -%* * - Binary instance - Here rather than BinIface because OccName is abstract -%* * -%************************************************************************ - -\begin{code} -instance Binary NameSpace where - put_ bh VarName = do - putByte bh 0 - put_ bh DataName = do - putByte bh 1 - put_ bh TvName = do - putByte bh 2 - put_ bh TcClsName = do - putByte bh 3 - get bh = do - h <- getByte bh - case h of - 0 -> do return VarName - 1 -> do return DataName - 2 -> do return TvName - _ -> do return TcClsName - -instance Binary OccName where - put_ bh (OccName aa ab) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (OccName aa ab) -\end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/OccName.lhs-boot ghc-6.13-20091231/compiler/basicTypes/OccName.lhs-boot --- ghc-6.12.1/compiler/basicTypes/OccName.lhs-boot 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/OccName.lhs-boot 1969-12-31 16:00:00.000000000 -0800 @@ -1,5 +0,0 @@ -\begin{code} -module OccName where - -data OccName -\end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/RdrName.lhs ghc-6.13-20091231/compiler/basicTypes/RdrName.lhs --- ghc-6.12.1/compiler/basicTypes/RdrName.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/RdrName.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,725 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -\begin{code} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName' is the type of names that come directly from the parser. They --- have not yet had their scoping and binding resolved by the renamer and can be --- thought of to a first approximation as an 'OccName.OccName' with an optional module --- qualifier --- --- * 'Name.Name': see "Name#name_types" --- --- * 'Id.Id': see "Id#name_types" --- --- * 'Var.Var': see "Var#name_types" -module RdrName ( - -- * The main type - RdrName(..), -- Constructors exported only to BinIface - - -- ** Construction - mkRdrUnqual, mkRdrQual, - mkUnqual, mkVarUnqual, mkQual, mkOrig, - nameRdrName, getRdrName, - mkDerivedRdrName, - - -- ** Destruction - rdrNameOcc, rdrNameSpace, setRdrNameSpace, - isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, - isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, - - -- ** Printing - showRdrName, - - -- * Local mapping of 'RdrName' to 'Name.Name' - LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, - lookupLocalRdrEnv, lookupLocalRdrOcc, elemLocalRdrEnv, - - -- * Global mapping of 'RdrName' to 'GlobalRdrElt's - GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, - lookupGlobalRdrEnv, extendGlobalRdrEnv, - pprGlobalRdrEnv, globalRdrEnvElts, - lookupGRE_RdrName, lookupGRE_Name, getGRE_NameQualifier_maybes, - hideSomeUnquals, findLocalDupsRdrEnv, pickGREs, - - -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' - GlobalRdrElt(..), isLocalGRE, unQualOK, qualSpecOK, unQualSpecOK, - Provenance(..), pprNameProvenance, - Parent(..), - ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), - importSpecLoc, importSpecModule, isExplicitItem - ) where - -#include "HsVersions.h" - -import Module -import Name -import Maybes -import SrcLoc -import FastString -import Outputable -import Util -\end{code} - -%************************************************************************ -%* * -\subsection{The main data type} -%* * -%************************************************************************ - -\begin{code} --- | Do not use the data constructors of RdrName directly: prefer the family --- of functions that creates them, such as 'mkRdrUnqual' -data RdrName - = Unqual OccName - -- ^ Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. - -- Create such a 'RdrName' with 'mkRdrUnqual' - - | Qual ModuleName OccName - -- ^ A qualified name written by the user in - -- /source/ code. The module isn't necessarily - -- the module where the thing is defined; - -- just the one from which it is imported. - -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. - -- Create such a 'RdrName' with 'mkRdrQual' - - | Orig Module OccName - -- ^ An original name; the module is the /defining/ module. - -- This is used when GHC generates code that will be fed - -- into the renamer (e.g. from deriving clauses), but where - -- we want to say \"Use Prelude.map dammit\". One of these - -- can be created with 'mkOrig' - - | Exact Name - -- ^ We know exactly the 'Name'. This is used: - -- - -- (1) When the parser parses built-in syntax like @[]@ - -- and @(,)@, but wants a 'RdrName' from it - -- - -- (2) By Template Haskell, when TH has generated a unique name - -- - -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' -\end{code} - - -%************************************************************************ -%* * -\subsection{Simple functions} -%* * -%************************************************************************ - -\begin{code} -rdrNameOcc :: RdrName -> OccName -rdrNameOcc (Qual _ occ) = occ -rdrNameOcc (Unqual occ) = occ -rdrNameOcc (Orig _ occ) = occ -rdrNameOcc (Exact name) = nameOccName name - -rdrNameSpace :: RdrName -> NameSpace -rdrNameSpace = occNameSpace . rdrNameOcc - -setRdrNameSpace :: RdrName -> NameSpace -> RdrName --- ^ This rather gruesome function is used mainly by the parser. --- When parsing: --- --- > data T a = T | T1 Int --- --- we parse the data constructors as /types/ because of parser ambiguities, --- so then we need to change the /type constr/ to a /data constr/ --- --- The exact-name case /can/ occur when parsing: --- --- > data [] a = [] | a : [a] --- --- For the exact-name case we return an original name. -setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) -setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) -setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) -setRdrNameSpace (Exact n) ns = ASSERT( isExternalName n ) - Orig (nameModule n) - (setOccNameSpace ns (nameOccName n)) -\end{code} - -\begin{code} - -- These two are the basic constructors -mkRdrUnqual :: OccName -> RdrName -mkRdrUnqual occ = Unqual occ - -mkRdrQual :: ModuleName -> OccName -> RdrName -mkRdrQual mod occ = Qual mod occ - -mkOrig :: Module -> OccName -> RdrName -mkOrig mod occ = Orig mod occ - ---------------- --- | Produce an original 'RdrName' whose module that of a parent 'Name' but its 'OccName' --- is derived from that of it's parent using the supplied function -mkDerivedRdrName :: Name -> (OccName -> OccName) -> RdrName -mkDerivedRdrName parent mk_occ - = ASSERT2( isExternalName parent, ppr parent ) - mkOrig (nameModule parent) (mk_occ (nameOccName parent)) - ---------------- - -- These two are used when parsing source files - -- They do encode the module and occurrence names -mkUnqual :: NameSpace -> FastString -> RdrName -mkUnqual sp n = Unqual (mkOccNameFS sp n) - -mkVarUnqual :: FastString -> RdrName -mkVarUnqual n = Unqual (mkVarOccFS n) - --- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and --- the 'OccName' are taken from the first and second elements of the tuple respectively -mkQual :: NameSpace -> (FastString, FastString) -> RdrName -mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n) - -getRdrName :: NamedThing thing => thing -> RdrName -getRdrName name = nameRdrName (getName name) - -nameRdrName :: Name -> RdrName -nameRdrName name = Exact name --- Keep the Name even for Internal names, so that the --- unique is still there for debug printing, particularly --- of Types (which are converted to IfaceTypes before printing) - -nukeExact :: Name -> RdrName -nukeExact n - | isExternalName n = Orig (nameModule n) (nameOccName n) - | otherwise = Unqual (nameOccName n) -\end{code} - -\begin{code} -isRdrDataCon :: RdrName -> Bool -isRdrTyVar :: RdrName -> Bool -isRdrTc :: RdrName -> Bool - -isRdrDataCon rn = isDataOcc (rdrNameOcc rn) -isRdrTyVar rn = isTvOcc (rdrNameOcc rn) -isRdrTc rn = isTcOcc (rdrNameOcc rn) - -isSrcRdrName :: RdrName -> Bool -isSrcRdrName (Unqual _) = True -isSrcRdrName (Qual _ _) = True -isSrcRdrName _ = False - -isUnqual :: RdrName -> Bool -isUnqual (Unqual _) = True -isUnqual _ = False - -isQual :: RdrName -> Bool -isQual (Qual _ _) = True -isQual _ = False - -isQual_maybe :: RdrName -> Maybe (ModuleName, OccName) -isQual_maybe (Qual m n) = Just (m,n) -isQual_maybe _ = Nothing - -isOrig :: RdrName -> Bool -isOrig (Orig _ _) = True -isOrig _ = False - -isOrig_maybe :: RdrName -> Maybe (Module, OccName) -isOrig_maybe (Orig m n) = Just (m,n) -isOrig_maybe _ = Nothing - -isExact :: RdrName -> Bool -isExact (Exact _) = True -isExact _ = False - -isExact_maybe :: RdrName -> Maybe Name -isExact_maybe (Exact n) = Just n -isExact_maybe _ = Nothing -\end{code} - - -%************************************************************************ -%* * -\subsection{Instances} -%* * -%************************************************************************ - -\begin{code} -instance Outputable RdrName where - ppr (Exact name) = ppr name - ppr (Unqual occ) = ppr occ - ppr (Qual mod occ) = ppr mod <> dot <> ppr occ - ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ) - -instance OutputableBndr RdrName where - pprBndr _ n - | isTvOcc (rdrNameOcc n) = char '@' <+> ppr n - | otherwise = ppr n - -showRdrName :: RdrName -> String -showRdrName r = showSDoc (ppr r) - -instance Eq RdrName where - (Exact n1) == (Exact n2) = n1==n2 - -- Convert exact to orig - (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 - r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 - - (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 - (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 - (Unqual o1) == (Unqual o2) = o1==o2 - _ == _ = False - -instance Ord RdrName 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 } - - -- Exact < Unqual < Qual < Orig - -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig - -- before comparing so that Prelude.map == the exact Prelude.map, but - -- that meant that we reported duplicates when renaming bindings - -- generated by Template Haskell; e.g - -- do { n1 <- newName "foo"; n2 <- newName "foo"; - -- } - -- I think we can do without this conversion - compare (Exact n1) (Exact n2) = n1 `compare` n2 - compare (Exact _) _ = LT - - compare (Unqual _) (Exact _) = GT - compare (Unqual o1) (Unqual o2) = o1 `compare` o2 - compare (Unqual _) _ = LT - - compare (Qual _ _) (Exact _) = GT - compare (Qual _ _) (Unqual _) = GT - compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) - compare (Qual _ _) (Orig _ _) = LT - - compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) - compare (Orig _ _) _ = GT -\end{code} - -%************************************************************************ -%* * - LocalRdrEnv -%* * -%************************************************************************ - -\begin{code} --- | This environment is used to store local bindings (@let@, @where@, lambda, @case@). --- It is keyed by OccName, because we never use it for qualified names -type LocalRdrEnv = OccEnv Name - -emptyLocalRdrEnv :: LocalRdrEnv -emptyLocalRdrEnv = emptyOccEnv - -extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv -extendLocalRdrEnv env name - = extendOccEnv env (nameOccName name) name - -extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv -extendLocalRdrEnvList env names - = 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 - -lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name -lookupLocalRdrOcc env occ = lookupOccEnv env occ - -elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool -elemLocalRdrEnv rdr_name env - | isUnqual rdr_name = rdrNameOcc rdr_name `elemOccEnv` env - | otherwise = False -\end{code} - -%************************************************************************ -%* * - GlobalRdrEnv -%* * -%************************************************************************ - -\begin{code} -type GlobalRdrEnv = OccEnv [GlobalRdrElt] --- ^ Keyed by 'OccName'; when looking up a qualified name --- we look up the 'OccName' part, and then check the 'Provenance' --- to see if the appropriate qualification is valid. This --- saves routinely doubling the size of the env by adding both --- qualified and unqualified names to the domain. --- --- The list in the codomain is required because there may be name clashes --- These only get reported on lookup, not on construction --- --- INVARIANT: All the members of the list have distinct --- 'gre_name' fields; that is, no duplicate Names --- --- INVARIANT: Imported provenance => Name is an ExternalName --- However LocalDefs can have an InternalName. This --- happens only when type-checking a [d| ... |] Template --- Haskell quotation; see this note in RnNames --- Note [Top-level Names in Template Haskell decl quotes] - --- | An element of the 'GlobalRdrEnv' -data GlobalRdrElt - = GRE { gre_name :: Name, - gre_par :: Parent, - gre_prov :: Provenance -- ^ Why it's in scope - } - --- | The children of a Name are the things that are abbreviated by the ".." --- notation in export lists. Specifically: --- TyCon Children are * data constructors --- * record field ids --- Class Children are * class operations --- Each child has the parent thing as its Parent -data Parent = NoParent | ParentIs Name - deriving (Eq) - -instance Outputable Parent where - ppr NoParent = empty - ppr (ParentIs n) = ptext (sLit "parent:") <> ppr n - - -plusParent :: Parent -> Parent -> Parent -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 - -globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt] -globalRdrEnvElts env = foldOccEnv (++) [] env - -instance Outputable GlobalRdrElt where - ppr gre = ppr name <+> parens (ppr (gre_par gre) <+> pprNameProvenance gre) - where - name = gre_name gre - -pprGlobalRdrEnv :: GlobalRdrEnv -> SDoc -pprGlobalRdrEnv env - = vcat (map pp (occEnvElts env)) - where - pp gres = ppr (nameOccName (gre_name (head gres))) <> colon <+> - vcat [ ppr (gre_name gre) <+> pprNameProvenance gre - | gre <- gres] -\end{code} - -\begin{code} -lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] -lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of - Nothing -> [] - Just gres -> gres - -extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv -extendGlobalRdrEnv env gre = extendOccEnv_C add env occ [gre] - where - occ = nameOccName (gre_name gre) - add gres _ = gre:gres - -lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] -lookupGRE_RdrName rdr_name env - = case lookupOccEnv env (rdrNameOcc rdr_name) of - Nothing -> [] - Just gres -> pickGREs rdr_name gres - -lookupGRE_Name :: GlobalRdrEnv -> Name -> [GlobalRdrElt] -lookupGRE_Name env name - = [ gre | gre <- lookupGlobalRdrEnv env (nameOccName name), - gre_name gre == name ] - -getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] -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 - -pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] --- ^ Take a list of GREs which have the right OccName --- Pick those GREs that are suitable for this RdrName --- And for those, keep only only the Provenances that are suitable --- --- Consider: --- --- @ --- module A ( f ) where --- import qualified Foo( f ) --- import Baz( f ) --- f = undefined --- @ --- --- Let's suppose that @Foo.f@ and @Baz.f@ are the same entity really. --- The export of @f@ is ambiguous because it's in scope from the local def --- and the import. The lookup of @Unqual f@ should return a GRE for --- the locally-defined @f@, and a GRE for the imported @f@, with a /single/ --- provenance, namely the one for @Baz(f)@. -pickGREs rdr_name gres - = mapCatMaybes pick gres - where - rdr_is_unqual = isUnqual rdr_name - rdr_is_qual = isQual_maybe rdr_name - - pick :: GlobalRdrElt -> Maybe GlobalRdrElt - pick gre@(GRE {gre_prov = LocalDef, gre_name = n}) -- Local def - | rdr_is_unqual = Just gre - | Just (mod,_) <- rdr_is_qual -- Qualified name - , Just n_mod <- nameModule_maybe n -- Binder is External - , mod == moduleName n_mod = Just gre - | otherwise = Nothing - pick gre@(GRE {gre_prov = Imported [is]}) -- Single import (efficiency) - | rdr_is_unqual, - not (is_qual (is_decl is)) = Just gre - | Just (mod,_) <- rdr_is_qual, - mod == is_as (is_decl is) = Just gre - | otherwise = Nothing - pick gre@(GRE {gre_prov = Imported is}) -- Multiple import - | null filtered_is = Nothing - | otherwise = Just (gre {gre_prov = Imported filtered_is}) - where - filtered_is | rdr_is_unqual - = filter (not . is_qual . is_decl) is - | Just (mod,_) <- rdr_is_qual - = filter ((== mod) . is_as . is_decl) is - | otherwise - = [] - -isLocalGRE :: GlobalRdrElt -> Bool -isLocalGRE (GRE {gre_prov = LocalDef}) = True -isLocalGRE _ = False - -unQualOK :: GlobalRdrElt -> Bool --- ^ Test if an unqualifed version of this thing would be in scope -unQualOK (GRE {gre_prov = LocalDef}) = True -unQualOK (GRE {gre_prov = Imported is}) = any unQualSpecOK is - -plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv -plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 - -mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv -mkGlobalRdrEnv gres - = foldr add emptyGlobalRdrEnv gres - where - add gre env = extendOccEnv_C (foldr insertGRE) env - (nameOccName (gre_name gre)) - [gre] - -findLocalDupsRdrEnv :: GlobalRdrEnv -> [OccName] -> (GlobalRdrEnv, [[Name]]) --- ^ For each 'OccName', see if there are multiple local definitions --- for it. If so, remove all but one (to suppress subsequent error messages) --- and return a list of the duplicate bindings -findLocalDupsRdrEnv rdr_env occs - = go rdr_env [] occs - where - go rdr_env dups [] = (rdr_env, dups) - go rdr_env dups (occ:occs) - = case filter isLocalGRE gres of - [] -> WARN( True, ppr occ <+> ppr rdr_env ) - go rdr_env dups occs -- Weird! No binding for occ - [_] -> go rdr_env dups occs -- The common case - dup_gres -> go (extendOccEnv rdr_env occ (head dup_gres : nonlocal_gres)) - (map gre_name dup_gres : dups) - occs - where - gres = lookupOccEnv rdr_env occ `orElse` [] - nonlocal_gres = filterOut isLocalGRE gres - - -insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] -insertGRE new_g [] = [new_g] -insertGRE new_g (old_g : old_gs) - | gre_name new_g == gre_name old_g - = new_g `plusGRE` old_g : old_gs - | otherwise - = old_g : insertGRE new_g old_gs - -plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt --- Used when the gre_name fields match -plusGRE g1 g2 - = GRE { gre_name = gre_name g1, - gre_prov = gre_prov g1 `plusProv` gre_prov g2, - gre_par = gre_par g1 `plusParent` gre_par g2 } - -hideSomeUnquals :: GlobalRdrEnv -> [OccName] -> GlobalRdrEnv --- ^ Hide any unqualified bindings for the specified OccNames --- This is used in TH, when renaming a declaration bracket --- --- > [d| foo = ... |] --- --- We want unqualified @foo@ in "..." to mean this @foo@, not --- the one from the enclosing module. But the /qualified/ name --- from the enclosing module must certainly still be available - --- Seems like 5 times as much work as it deserves! -hideSomeUnquals rdr_env occs - = foldr hide rdr_env occs - where - hide occ env - | Just gres <- lookupOccEnv env occ = extendOccEnv env occ (map qual_gre gres) - | otherwise = env - qual_gre gre@(GRE { gre_name = name, gre_prov = LocalDef }) - = gre { gre_prov = Imported [imp_spec] } - where -- Local defs get transfomed to (fake) imported things - 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, - is_dloc = srcLocSpan (nameSrcLoc name) } - - qual_gre gre@(GRE { gre_prov = Imported 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 } } -\end{code} - -%************************************************************************ -%* * - Provenance -%* * -%************************************************************************ - -\begin{code} --- | The 'Provenance' of something says how it came to be in scope. --- It's quite elaborate so that we can give accurate unused-name warnings. -data Provenance - = LocalDef -- ^ The thing was defined locally - | Imported - [ImportSpec] -- ^ The thing was imported. - -- - -- INVARIANT: the list of 'ImportSpec' is non-empty - -data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, - is_item :: ImpItemSpec } - deriving( Eq, Ord ) - --- | Describes a particular import declaration and is --- shared among all the 'Provenance's for that decl -data ImpDeclSpec - = ImpDeclSpec { - is_mod :: ModuleName, -- ^ Module imported, e.g. @import Muggle@ - -- Note the @Muggle@ may well not be - -- the defining module for this thing! - - -- TODO: either should be Module, or there - -- should be a Maybe PackageId here too. - is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) - is_qual :: Bool, -- ^ Was this import qualified? - is_dloc :: SrcSpan -- ^ The location of the entire import declaration - } - --- | Describes import info a particular Name -data ImpItemSpec - = ImpAll -- ^ The import had no import list, - -- or had a hiding list - - | ImpSome { - is_explicit :: Bool, - is_iloc :: SrcSpan -- Location of the import item - } -- ^ The import had an import list. - -- The 'is_explicit' field is @True@ iff the thing was named - -- /explicitly/ in the import specs rather - -- than being imported as part of a "..." group. Consider: - -- - -- > import C( T(..) ) - -- - -- Here the constructors of @T@ are not named explicitly; - -- only @T@ is named explicitly. - -unQualSpecOK :: ImportSpec -> Bool --- ^ Is in scope unqualified? -unQualSpecOK is = not (is_qual (is_decl is)) - -qualSpecOK :: ModuleName -> ImportSpec -> Bool --- ^ Is in scope qualified with the given module? -qualSpecOK mod is = mod == is_as (is_decl is) - -importSpecLoc :: ImportSpec -> SrcSpan -importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl -importSpecLoc (ImpSpec _ item) = is_iloc item - -importSpecModule :: ImportSpec -> ModuleName -importSpecModule is = is_mod (is_decl is) - -isExplicitItem :: ImpItemSpec -> Bool -isExplicitItem ImpAll = False -isExplicitItem (ImpSome {is_explicit = exp}) = exp - --- Note [Comparing provenance] --- Comparison of provenance is just used for grouping --- error messages (in RnEnv.warnUnusedBinds) -instance Eq Provenance where - p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False - -instance Eq ImpDeclSpec where - p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False - -instance Eq ImpItemSpec where - p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False - -instance Ord Provenance where - compare LocalDef LocalDef = EQ - compare LocalDef (Imported _) = LT - compare (Imported _ ) LocalDef = GT - compare (Imported is1) (Imported is2) = compare (head is1) - {- See Note [Comparing provenance] -} (head is2) - -instance Ord ImpDeclSpec where - compare is1 is2 = (is_mod is1 `compare` is_mod is2) `thenCmp` - (is_dloc is1 `compare` is_dloc is2) - -instance Ord ImpItemSpec where - compare is1 is2 = is_iloc is1 `compare` is_iloc is2 -\end{code} - -\begin{code} -plusProv :: Provenance -> Provenance -> Provenance --- Choose LocalDef over Imported --- There is an obscure bug lurking here; in the presence --- of recursive modules, something can be imported *and* locally --- defined, and one might refer to it with a qualified name from --- the import -- but I'm going to ignore that because it makes --- the isLocalGRE predicate so much nicer this way -plusProv LocalDef LocalDef = panic "plusProv" -plusProv LocalDef _ = LocalDef -plusProv _ LocalDef = LocalDef -plusProv (Imported is1) (Imported is2) = Imported (is1++is2) - -pprNameProvenance :: GlobalRdrElt -> SDoc --- ^ Print out the place where the name was imported -pprNameProvenance (GRE {gre_name = name, gre_prov = LocalDef}) - = ptext (sLit "defined at") <+> ppr (nameSrcLoc name) -pprNameProvenance (GRE {gre_name = name, gre_prov = Imported whys}) - = case whys of - (why:_) -> sep [ppr why, nest 2 (ppr_defn (nameSrcLoc name))] - [] -> panic "pprNameProvenance" - --- 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 - -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 - where - loc = importSpecLoc imp_spec -\end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/SrcLoc.lhs ghc-6.13-20091231/compiler/basicTypes/SrcLoc.lhs --- ghc-6.12.1/compiler/basicTypes/SrcLoc.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/SrcLoc.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,514 +0,0 @@ -% -% (c) The University of Glasgow, 1992-2006 -% - -\begin{code} --- | 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 - - -- ** Constructing SrcLoc - mkSrcLoc, mkGeneralSrcLoc, - - noSrcLoc, -- "I'm sorry, I haven't a clue" - generatedSrcLoc, -- Code generated within the compiler - interactiveSrcLoc, -- Code from an interactive session - - advanceSrcLoc, - - -- ** Unsafely deconstructing SrcLoc - -- These are dubious exports, because they crash on some inputs - srcLocFile, -- return the file name part - srcLocLine, -- return the line part - srcLocCol, -- return the column part - - -- ** Misc. operations on SrcLoc - pprDefnLoc, - - -- ** Predicates on SrcLoc - isGoodSrcLoc, - - -- * SrcSpan - SrcSpan, -- Abstract - - -- ** Constructing SrcSpan - mkGeneralSrcSpan, mkSrcSpan, - noSrcSpan, - wiredInSrcSpan, -- Something wired into the compiler - srcLocSpan, - combineSrcSpans, - - -- ** Deconstructing SrcSpan - srcSpanStart, srcSpanEnd, - srcSpanFileName_maybe, - - -- ** Unsafely deconstructing SrcSpan - -- These are dubious exports, because they crash on some inputs - srcSpanFile, - srcSpanStartLine, srcSpanEndLine, - srcSpanStartCol, srcSpanEndCol, - - -- ** Predicates on SrcSpan - isGoodSrcSpan, isOneLineSpan, - - -- * Located - Located(..), - - -- ** Constructing Located - noLoc, - mkGeneralLocated, - - -- ** Deconstructing Located - getLoc, unLoc, - - -- ** Combining and comparing Located values - eqLocated, cmpLocated, combineLocs, addCLoc, - leftmost_smallest, leftmost_largest, rightmost, - spans, isSubspanOf - ) where - -import Util -import Outputable -import FastString -\end{code} - -%************************************************************************ -%* * -\subsection[SrcLoc-SrcLocations]{Source-location information} -%* * -%************************************************************************ - -We keep information about the {\em definition} point for each entity; -this is the obvious stuff: -\begin{code} --- | Represents a single point within a file -data SrcLoc - = SrcLoc FastString -- A precise location (file name) - {-# UNPACK #-} !Int -- line number, begins at 1 - {-# UNPACK #-} !Int -- column number, begins at 0 - -- Don't ask me why lines start at 1 and columns start at - -- zero. That's just the way it is, so there. --SDM - - | UnhelpfulLoc FastString -- Just a general indication -\end{code} - -%************************************************************************ -%* * -\subsection[SrcLoc-access-fns]{Access functions} -%* * -%************************************************************************ - -\begin{code} -mkSrcLoc :: FastString -> Int -> Int -> SrcLoc -mkSrcLoc x line col = SrcLoc x line col - --- | Built-in "bad" 'SrcLoc' values for particular locations -noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc -noSrcLoc = UnhelpfulLoc (fsLit "") -generatedSrcLoc = UnhelpfulLoc (fsLit "") -interactiveSrcLoc = UnhelpfulLoc (fsLit "") - --- | Creates a "bad" 'SrcLoc' that has no detailed information about its location -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 -srcLocFile (SrcLoc fname _ _) = fname -srcLocFile _other = (fsLit " Int -srcLocLine (SrcLoc _ l _) = l -srcLocLine _other = panic "srcLocLine: unknown line" - --- | Raises an error when used on a "bad" 'SrcLoc' -srcLocCol :: SrcLoc -> Int -srcLocCol (SrcLoc _ _ c) = c -srcLocCol _other = panic "srcLocCol: unknown col" - --- | Move the 'SrcLoc' down by one line if the character is a newline --- and across by one character in any other case -advanceSrcLoc :: SrcLoc -> Char -> SrcLoc -advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 0 -advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) -advanceSrcLoc loc _ = loc -- Better than nothing -\end{code} - -%************************************************************************ -%* * -\subsection[SrcLoc-instances]{Instance declarations for various names} -%* * -%************************************************************************ - -\begin{code} --- 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 - -instance Ord SrcLoc where - compare = cmpSrcLoc - -cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering -cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2 -cmpSrcLoc (UnhelpfulLoc _) _other = LT - -cmpSrcLoc (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 - ppr (SrcLoc src_path src_line src_col) - = getPprStyle $ \ sty -> - if userStyle sty || debugStyle sty then - hcat [ pprFastFilePath src_path, char ':', - int src_line, - char ':', int src_col - ] - else - hcat [text "{-# LINE ", int src_line, space, - char '\"', pprFastFilePath src_path, text " #-}"] - - ppr (UnhelpfulLoc s) = ftext s -\end{code} - -%************************************************************************ -%* * -\subsection[SrcSpan]{Source Spans} -%* * -%************************************************************************ - -\begin{code} -{- | -A SrcSpan delimits a portion of a text file. It could be represented -by a pair of (line,column) coordinates, but in fact we optimise -slightly by using more compact representations for single-line and -zero-length spans, both of which are quite common. - -The end position is defined to be the column /after/ the end of the -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 - = SrcSpanOneLine -- a common case: a single line - { srcSpanFile :: !FastString, - srcSpanLine :: {-# UNPACK #-} !Int, - srcSpanSCol :: {-# UNPACK #-} !Int, - srcSpanECol :: {-# UNPACK #-} !Int - } - - | SrcSpanMultiLine - { srcSpanFile :: !FastString, - srcSpanSLine :: {-# UNPACK #-} !Int, - srcSpanSCol :: {-# UNPACK #-} !Int, - srcSpanELine :: {-# UNPACK #-} !Int, - srcSpanECol :: {-# UNPACK #-} !Int - } - - | SrcSpanPoint - { srcSpanFile :: !FastString, - srcSpanLine :: {-# UNPACK #-} !Int, - srcSpanCol :: {-# UNPACK #-} !Int - } - - | 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 -#else - deriving Eq -#endif - --- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty -noSrcSpan, wiredInSrcSpan :: SrcSpan -noSrcSpan = UnhelpfulSpan (fsLit "") -wiredInSrcSpan = UnhelpfulSpan (fsLit "") - --- | Create a "bad" 'SrcSpan' that has not location information -mkGeneralSrcSpan :: FastString -> SrcSpan -mkGeneralSrcSpan = UnhelpfulSpan - --- | 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 - --- | 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 - | line1 == line2 = if col1 == col2 - then SrcSpanPoint file line1 col1 - else SrcSpanOneLine file line1 col1 col2 - | otherwise = SrcSpanMultiLine file line1 col1 line2 col2 - where - line1 = srcLocLine loc1 - line2 = srcLocLine loc2 - col1 = srcLocCol loc1 - col2 = srcLocCol loc2 - file = srcLocFile loc1 - --- | 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 - where - line1 = srcSpanStartLine start - col1 = srcSpanStartCol start - line2 = srcSpanEndLine end - col2 = srcSpanEndCol end - file = srcSpanFile start -\end{code} - -%************************************************************************ -%* * -\subsection[SrcSpan-predicates]{Predicates} -%* * -%************************************************************************ - -\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 - -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 - -\end{code} - -%************************************************************************ -%* * -\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions} -%* * -%************************************************************************ - -\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 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} - -%************************************************************************ -%* * -\subsection[SrcSpan-access-fns]{Access functions} -%* * -%************************************************************************ - -\begin{code} - --- | 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) - -srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str -srcSpanEnd s = - mkSrcLoc (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 - -\end{code} - -%************************************************************************ -%* * -\subsection[SrcSpan-instances]{Instances} -%* * -%************************************************************************ - -\begin{code} - --- We want to order SrcSpans first by the start point, then by the end point. -instance Ord SrcSpan where - a `compare` b = - (srcSpanStart a `compare` srcSpanStart b) `thenCmp` - (srcSpanEnd a `compare` srcSpanEnd b) - - -instance Outputable SrcSpan where - ppr span - = getPprStyle $ \ sty -> - if userStyle sty || debugStyle sty then - pprUserSpan True span - else - hcat [text "{-# LINE ", int (srcSpanStartLine span), space, - char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"] - -pprUserSpan :: Bool -> SrcSpan -> SDoc -pprUserSpan 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) - (char '-' <> int (end_col-1)) - -- For single-character or point spans, we just - -- output the starting column number - ] - - -pprUserSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol) - = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) - , parens (int sline <> char ',' <> int scol) - , char '-' - , parens (int eline <> char ',' <> - if ecol == 0 then int ecol else int (ecol-1)) - ] - -pprUserSpan 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 --- ^ Pretty prints information about the 'SrcSpan' in the style "defined at ..." -pprDefnLoc loc - | isGoodSrcSpan loc = ptext (sLit "Defined at") <+> ppr loc - | otherwise = ppr loc -\end{code} - -%************************************************************************ -%* * -\subsection[Located]{Attaching SrcSpans to things} -%* * -%************************************************************************ - -\begin{code} --- | We attach SrcSpans to lots of things, so let's have a datatype for it. -data Located e = L SrcSpan e - -unLoc :: Located e -> e -unLoc (L _ e) = e - -getLoc :: Located e -> SrcSpan -getLoc (L l _) = l - -noLoc :: e -> Located e -noLoc e = L noSrcSpan e - -mkGeneralLocated :: String -> e -> Located e -mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e - -combineLocs :: Located a -> Located b -> SrcSpan -combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) - --- | Combine locations from two 'Located' things and add them to a third thing -addCLoc :: Located a -> Located b -> c -> Located c -addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c - --- not clear whether to add a general Eq instance, but this is useful sometimes: - --- | Tests whether the two located things are equal -eqLocated :: Eq a => Located a -> Located a -> Bool -eqLocated a b = unLoc a == unLoc b - --- not clear whether to add a general Ord instance, but this is useful sometimes: - --- | Tests the ordering of the two located things -cmpLocated :: Ord a => Located a -> Located a -> Ordering -cmpLocated a b = unLoc a `compare` unLoc b - -instance Functor Located 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 -\end{code} - -%************************************************************************ -%* * -\subsection{Ordering SrcSpans for InteractiveUI} -%* * -%************************************************************************ - -\begin{code} --- | Alternative strategies for ordering 'SrcSpan's -leftmost_smallest, leftmost_largest, rightmost :: SrcSpan -> SrcSpan -> Ordering -rightmost = flip compare -leftmost_smallest = compare -leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b) - `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 - --- | Determines whether a span is enclosed by another one -isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other - -> SrcSpan -- ^ The span it may be enclosed by - -> Bool -isSubspanOf src parent - | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False - | otherwise = srcSpanStart parent <= srcSpanStart src && - srcSpanEnd parent >= srcSpanEnd src - -\end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/UniqSupply.lhs ghc-6.13-20091231/compiler/basicTypes/UniqSupply.lhs --- ghc-6.12.1/compiler/basicTypes/UniqSupply.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/UniqSupply.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,210 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -\begin{code} -module UniqSupply ( - -- * Main data type - UniqSupply, -- Abstractly - - -- ** Operations on supplies - uniqFromSupply, uniqsFromSupply, -- basic ops - - mkSplitUniqSupply, - splitUniqSupply, listSplitUniqSupply, - - -- * Unique supply monad and its abstraction - UniqSM, MonadUnique(..), - - -- ** Operations on the monad - initUs, initUs_, - lazyThenUs, lazyMapUs, - - -- ** Deprecated operations on 'UniqSM' - getUniqueUs, getUs, returnUs, thenUs, mapUs - ) where - -import Unique -import FastTypes - -import MonadUtils -import Control.Monad -#if __GLASGOW_HASKELL__ >= 611 -import GHC.IO (unsafeDupableInterleaveIO) -#else -import GHC.IOBase (unsafeDupableInterleaveIO) -#endif - -\end{code} - -%************************************************************************ -%* * -\subsection{Splittable Unique supply: @UniqSupply@} -%* * -%************************************************************************ - -\begin{code} --- | A value of type 'UniqSupply' is unique, and it can --- supply /one/ distinct 'Unique'. Also, from the supply, one can --- also manufacture an arbitrary number of further 'UniqueSupply' values, --- which will be distinct from the first and from all others. -data UniqSupply - = MkSplitUniqSupply FastInt -- make the Unique with this - UniqSupply UniqSupply - -- when split => these two supplies -\end{code} - -\begin{code} -mkSplitUniqSupply :: Char -> IO UniqSupply --- ^ Create a unique supply out of thin air. The character given must --- be distinct from those of all calls to this function in the compiler --- for the values generated to be truly unique. - -splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) --- ^ Build two 'UniqSupply' from a single one, each of which --- can supply its own 'Unique'. -listSplitUniqSupply :: UniqSupply -> [UniqSupply] --- ^ Create an infinite list of 'UniqSupply' from a single one -uniqFromSupply :: UniqSupply -> Unique --- ^ 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 -\end{code} - -\begin{code} -mkSplitUniqSupply c - = case fastOrd (cUnbox c) `shiftLFastInt` _ILIT(24) of - mask -> let - -- here comes THE MAGIC: - - -- This is one of the most hammered bits in the whole compiler - mk_supply - = unsafeDupableInterleaveIO ( - genSymZh >>= \ u_ -> case iUnbox u_ of { u -> ( - mk_supply >>= \ s1 -> - mk_supply >>= \ s2 -> - return (MkSplitUniqSupply (mask `bitOrFastInt` u) s1 s2) - )}) - in - mk_supply - -foreign import ccall unsafe "genSymZh" genSymZh :: IO Int - -splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) -listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2 -\end{code} - -\begin{code} -uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily (iBox n) -uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily (iBox n) : uniqsFromSupply s2 -\end{code} - -%************************************************************************ -%* * -\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@} -%* * -%************************************************************************ - -\begin{code} --- | A monad which just gives the ability to obtain 'Unique's -newtype UniqSM result = USM { unUSM :: UniqSupply -> (result, UniqSupply) } - -instance Monad UniqSM where - return = returnUs - (>>=) = thenUs - (>>) = thenUs_ - -instance Functor UniqSM where - fmap f (USM x) = USM (\us -> case x us of - (r, us') -> (f r, us')) - -instance Applicative UniqSM where - pure = returnUs - (USM f) <*> (USM x) = USM $ \us -> case f us of - (ff, us') -> case x us' of - (xx, us'') -> (ff xx, us'') - --- | Run the 'UniqSM' action, returning the final 'UniqSupply' -initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply) -initUs init_us m = case unUSM m init_us of { (r,us) -> (r,us) } - --- | Run the 'UniqSM' action, discarding the final 'UniqSupply' -initUs_ :: UniqSupply -> UniqSM a -> a -initUs_ init_us m = case unUSM m init_us of { (r, _) -> r } - -{-# INLINE thenUs #-} -{-# INLINE lazyThenUs #-} -{-# INLINE returnUs #-} -{-# INLINE splitUniqSupply #-} -\end{code} - -@thenUs@ is where we split the @UniqSupply@. -\begin{code} -instance MonadFix UniqSM where - mfix m = USM (\us -> let (r,us') = unUSM (m r) us in (r,us')) - -thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b -thenUs (USM expr) cont - = USM (\us -> case (expr us) of - (result, us') -> unUSM (cont result) us') - -lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b -lazyThenUs (USM expr) cont - = USM (\us -> let (result, us') = expr us in unUSM (cont result) us') - -thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b -thenUs_ (USM expr) (USM cont) - = USM (\us -> case (expr us) of { (_, us') -> cont us' }) - -returnUs :: a -> UniqSM a -returnUs result = USM (\us -> (result, us)) - -getUs :: UniqSM UniqSupply -getUs = USM (\us -> splitUniqSupply us) - --- | A monad for generating unique identifiers -class Monad m => MonadUnique m where - -- | Get a new UniqueSupply - getUniqueSupplyM :: m UniqSupply - -- | Get a new unique identifier - getUniqueM :: m Unique - -- | Get an infinite list of new unique identifiers - getUniquesM :: m [Unique] - - getUniqueM = liftM uniqFromSupply getUniqueSupplyM - getUniquesM = liftM uniqsFromSupply getUniqueSupplyM - -instance MonadUnique UniqSM where - getUniqueSupplyM = USM (\us -> splitUniqSupply us) - getUniqueM = getUniqueUs - getUniquesM = getUniquesUs - -getUniqueUs :: UniqSM Unique -getUniqueUs = USM (\us -> case splitUniqSupply us of - (us1,us2) -> (uniqFromSupply us1, us2)) - -getUniquesUs :: UniqSM [Unique] -getUniquesUs = USM (\us -> case splitUniqSupply us of - (us1,us2) -> (uniqsFromSupply us1, us2)) - -mapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b] -mapUs _ [] = returnUs [] -mapUs f (x:xs) - = f x `thenUs` \ r -> - mapUs f xs `thenUs` \ rs -> - returnUs (r:rs) -\end{code} - -\begin{code} --- {-# SPECIALIZE mapM :: (a -> UniqSM b) -> [a] -> UniqSM [b] #-} --- {-# SPECIALIZE mapAndUnzipM :: (a -> UniqSM (b,c)) -> [a] -> UniqSM ([b],[c]) #-} --- {-# SPECIALIZE mapAndUnzip3M :: (a -> UniqSM (b,c,d)) -> [a] -> UniqSM ([b],[c],[d]) #-} - -lazyMapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b] -lazyMapUs _ [] = returnUs [] -lazyMapUs f (x:xs) - = f x `lazyThenUs` \ r -> - lazyMapUs f xs `lazyThenUs` \ rs -> - returnUs (r:rs) -\end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/Unique.lhs ghc-6.13-20091231/compiler/basicTypes/Unique.lhs --- ghc-6.12.1/compiler/basicTypes/Unique.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/Unique.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,362 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -@Uniques@ are used to distinguish entities in the compiler (@Ids@, -@Classes@, etc.) from each other. Thus, @Uniques@ are the basic -comparison key in the compiler. - -If there is any single operation that needs to be fast, it is @Unique@ -comparison. Unsurprisingly, there is quite a bit of huff-and-puff -directed to that end. - -Some of the other hair in this code is to be able to use a -``splittable @UniqueSupply@'' if requested/possible (not standard -Haskell). - -\begin{code} -module Unique ( - -- * Main data types - Unique, Uniquable(..), - - -- ** Constructors, desctructors and operations on 'Unique's - hasKey, - - pprUnique, - - mkUnique, -- Used in UniqSupply - mkUniqueGrimily, -- Used in UniqSupply only! - getKey, getKeyFastInt, -- Used in Var, UniqFM, Name only! - - incrUnique, -- Used for renumbering - deriveUnique, -- Ditto - newTagUnique, -- Used in CgCase - initTyVarUnique, - - isTupleKey, - - -- ** Making built-in uniques - - -- now all the built-in Uniques (and functions to make them) - -- [the Oh-So-Wonderful Haskell module system wins again...] - mkAlphaTyVarUnique, - mkPrimOpIdUnique, - mkTupleTyConUnique, mkTupleDataConUnique, - mkPreludeMiscIdUnique, mkPreludeDataConUnique, - mkPreludeTyConUnique, mkPreludeClassUnique, - mkPArrDataConUnique, - - mkBuiltinUnique, - mkPseudoUniqueC, - mkPseudoUniqueD, - mkPseudoUniqueE, - mkPseudoUniqueH - ) where - -#include "HsVersions.h" - -import BasicTypes -import FastTypes -import FastString -import Outputable -import StaticFlags - -#if defined(__GLASGOW_HASKELL__) ---just for implementing a fast [0,61) -> Char function -import GHC.Exts (indexCharOffAddr#, Char(..)) -#else -import Data.Array -#endif -import Data.Char ( chr, ord ) -\end{code} - -%************************************************************************ -%* * -\subsection[Unique-type]{@Unique@ type and operations} -%* * -%************************************************************************ - -The @Chars@ are ``tag letters'' that identify the @UniqueSupply@. -Fast comparison is everything on @Uniques@: - -\begin{code} ---why not newtype Int? - --- | The type of unique identifiers that are used in many places in GHC --- for fast ordering and equality tests. You should generate these with --- the functions from the 'UniqSupply' module -data Unique = MkUnique FastInt -\end{code} - -Now come the functions which construct uniques from their pieces, and vice versa. -The stuff about unique *supplies* is handled further down this module. - -\begin{code} -mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces -unpkUnique :: Unique -> (Char, Int) -- The reverse - -mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply -getKey :: Unique -> Int -- for Var -getKeyFastInt :: Unique -> FastInt -- for Var - -incrUnique :: Unique -> Unique -deriveUnique :: Unique -> Int -> Unique -newTagUnique :: Unique -> Char -> Unique - -isTupleKey :: Unique -> Bool -\end{code} - - -\begin{code} -mkUniqueGrimily x = MkUnique (iUnbox x) - -{-# INLINE getKey #-} -getKey (MkUnique x) = iBox x -{-# INLINE getKeyFastInt #-} -getKeyFastInt (MkUnique x) = x - -incrUnique (MkUnique i) = MkUnique (i +# _ILIT(1)) - --- deriveUnique uses an 'X' tag so that it won't clash with --- any of the uniques produced any other way -deriveUnique (MkUnique i) delta = mkUnique 'X' (iBox i + delta) - --- newTagUnique changes the "domain" of a unique to a different char -newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u - --- pop the Char in the top 8 bits of the Unique(Supply) - --- No 64-bit bugs here, as long as we have at least 32 bits. --JSM - --- and as long as the Char fits in 8 bits, which we assume anyway! - -mkUnique c i - = MkUnique (tag `bitOrFastInt` bits) - where - !tag = fastOrd (cUnbox c) `shiftLFastInt` _ILIT(24) - !bits = iUnbox i `bitAndFastInt` _ILIT(16777215){-``0x00ffffff''-} - -unpkUnique (MkUnique u) - = let - -- as long as the Char may have its eighth bit set, we - -- really do need the logical right-shift here! - tag = cBox (fastChr (u `shiftRLFastInt` _ILIT(24))) - i = iBox (u `bitAndFastInt` _ILIT(16777215){-``0x00ffffff''-}) - in - (tag, i) -\end{code} - - - -%************************************************************************ -%* * -\subsection[Uniquable-class]{The @Uniquable@ class} -%* * -%************************************************************************ - -\begin{code} --- | Class of things that we can obtain a 'Unique' from -class Uniquable a where - getUnique :: a -> Unique - -hasKey :: Uniquable a => a -> Unique -> Bool -x `hasKey` k = getUnique x == k - -instance Uniquable FastString where - getUnique fs = mkUniqueGrimily (iBox (uniqueOfFS fs)) - -instance Uniquable Int where - getUnique i = mkUniqueGrimily i -\end{code} - - -%************************************************************************ -%* * -\subsection[Unique-instances]{Instance declarations for @Unique@} -%* * -%************************************************************************ - -And the whole point (besides uniqueness) is fast equality. We don't -use `deriving' because we want {\em precise} control of ordering -(equality on @Uniques@ is v common). - -\begin{code} -eqUnique, ltUnique, leUnique :: Unique -> Unique -> Bool -eqUnique (MkUnique u1) (MkUnique u2) = u1 ==# u2 -ltUnique (MkUnique u1) (MkUnique u2) = u1 <# u2 -leUnique (MkUnique u1) (MkUnique u2) = u1 <=# u2 - -cmpUnique :: Unique -> Unique -> Ordering -cmpUnique (MkUnique u1) (MkUnique u2) - = if u1 ==# u2 then EQ else if u1 <# u2 then LT else GT - -instance Eq Unique where - a == b = eqUnique a b - a /= b = not (eqUnique a b) - -instance Ord Unique where - a < b = ltUnique a b - a <= b = leUnique a b - a > b = not (leUnique a b) - a >= b = not (ltUnique a b) - compare a b = cmpUnique a b - ------------------ -instance Uniquable Unique where - getUnique u = u -\end{code} - -We do sometimes make strings with @Uniques@ in them: -\begin{code} -pprUnique :: Unique -> SDoc -pprUnique uniq - | opt_SuppressUniques - = empty -- Used exclusively to suppress uniques so you - | otherwise -- can compare output easily - = case unpkUnique uniq of - (tag, u) -> finish_ppr tag u (text (iToBase62 u)) - -#ifdef UNUSED -pprUnique10 :: Unique -> SDoc -pprUnique10 uniq -- in base-10, dudes - = case unpkUnique uniq of - (tag, u) -> finish_ppr tag u (int u) -#endif - -finish_ppr :: Char -> Int -> SDoc -> SDoc -finish_ppr 't' u _pp_u | u < 26 - = -- Special case to make v common tyvars, t1, t2, ... - -- come out as a, b, ... (shorter, easier to read) - char (chr (ord 'a' + u)) -finish_ppr tag _ pp_u = char tag <> pp_u - -instance Outputable Unique where - ppr u = pprUnique u - -instance Show Unique where - showsPrec p uniq = showsPrecSDoc p (pprUnique uniq) -\end{code} - -%************************************************************************ -%* * -\subsection[Utils-base62]{Base-62 numbers} -%* * -%************************************************************************ - -A character-stingy way to read/write numbers (notably Uniques). -The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints. -Code stolen from Lennart. - -\begin{code} -iToBase62 :: Int -> String -iToBase62 n_ - = ASSERT(n_ >= 0) go (iUnbox n_) "" - where - go n cs | n <# _ILIT(62) - = case chooseChar62 n of { c -> c `seq` (c : cs) } - | otherwise - = case (quotRem (iBox n) 62) of { (q_, r_) -> - case iUnbox q_ of { q -> case iUnbox r_ of { r -> - case (chooseChar62 r) of { c -> c `seq` - (go q (c : cs)) }}}} - - chooseChar62 :: FastInt -> Char - {-# INLINE chooseChar62 #-} -#if defined(__GLASGOW_HASKELL__) - --then FastInt == Int# - chooseChar62 n = C# (indexCharOffAddr# chars62 n) - !chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"# -#else - --Haskell98 arrays are portable - chooseChar62 n = (!) chars62 n - chars62 = listArray (0,61) "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" -#endif -\end{code} - -%************************************************************************ -%* * -\subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things} -%* * -%************************************************************************ - -Allocation of unique supply characters: - v,t,u : for renumbering value-, type- and usage- vars. - B: builtin - C-E: pseudo uniques (used in native-code generator) - X: uniques derived by deriveUnique - _: unifiable tyvars (above) - 0-9: prelude things below - (no numbers left any more..) - :: (prelude) parallel array data constructors - - other a-z: lower case chars for unique supplies. Used so far: - - d desugarer - f AbsC flattener - g SimplStg - n Native codegen - r Hsc name cache - s simplifier - -\begin{code} -mkAlphaTyVarUnique :: Int -> Unique -mkPreludeClassUnique :: Int -> Unique -mkPreludeTyConUnique :: Int -> Unique -mkTupleTyConUnique :: Boxity -> Int -> Unique -mkPreludeDataConUnique :: Int -> Unique -mkTupleDataConUnique :: Boxity -> Int -> Unique -mkPrimOpIdUnique :: Int -> Unique -mkPreludeMiscIdUnique :: Int -> Unique -mkPArrDataConUnique :: Int -> Unique - -mkAlphaTyVarUnique i = mkUnique '1' i - -mkPreludeClassUnique i = mkUnique '2' i - --- Prelude type constructors occupy *three* slots. --- The first is for the tycon itself; the latter two --- are for the generic to/from Ids. See TysWiredIn.mk_tc_gen_info. - -mkPreludeTyConUnique i = mkUnique '3' (3*i) -mkTupleTyConUnique Boxed a = mkUnique '4' (3*a) -mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a) - --- Data constructor keys occupy *two* slots. The first is used for the --- data constructor itself and its wrapper function (the function that --- evaluates arguments as necessary and calls the worker). The second is --- used for the worker function (the function that builds the constructor --- representation). - -mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic -mkTupleDataConUnique Boxed a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels) -mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a) - --- This one is used for a tiresome reason --- to improve a consistency-checking error check in the renamer -isTupleKey u = case unpkUnique u of - (tag,_) -> tag == '4' || tag == '5' || tag == '7' || tag == '8' - -mkPrimOpIdUnique op = mkUnique '9' op -mkPreludeMiscIdUnique i = mkUnique '0' i - --- No numbers left anymore, so I pick something different for the character --- tag -mkPArrDataConUnique a = mkUnique ':' (2*a) - --- The "tyvar uniques" print specially nicely: a, b, c, etc. --- See pprUnique for details - -initTyVarUnique :: Unique -initTyVarUnique = mkUnique 't' 0 - -mkPseudoUniqueC, mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH, - mkBuiltinUnique :: Int -> Unique - -mkBuiltinUnique i = mkUnique 'B' i -mkPseudoUniqueC i = mkUnique 'C' i -- used for getUnique on Regs -mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs -mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs -mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs -\end{code} - diff -ruN ghc-6.12.1/compiler/basicTypes/VarEnv.lhs ghc-6.13-20091231/compiler/basicTypes/VarEnv.lhs --- ghc-6.12.1/compiler/basicTypes/VarEnv.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/VarEnv.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,389 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -\begin{code} -module VarEnv ( - -- * Var, Id and TyVar environments (maps) - VarEnv, IdEnv, TyVarEnv, - - -- ** Manipulating these environments - emptyVarEnv, unitVarEnv, mkVarEnv, - elemVarEnv, varEnvElts, varEnvKeys, - extendVarEnv, extendVarEnv_C, extendVarEnvList, - plusVarEnv, plusVarEnv_C, - delVarEnvList, delVarEnv, - lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, - mapVarEnv, zipVarEnv, - modifyVarEnv, modifyVarEnv_Directly, - isEmptyVarEnv, foldVarEnv, - elemVarEnvByKey, lookupVarEnv_Directly, - filterVarEnv_Directly, restrictVarEnv, - - -- * The InScopeSet type - InScopeSet, - - -- ** Operations on InScopeSets - emptyInScopeSet, mkInScopeSet, delInScopeSet, - extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, - getInScopeVars, lookupInScope, elemInScopeSet, uniqAway, - - -- * The RnEnv2 type - RnEnv2, - - -- ** Operations on RnEnv2s - mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR, - rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, extendRnInScopeList, - rnInScope, rnInScopeSet, lookupRnInScope, - - -- * TidyEnv and its operation - TidyEnv, - emptyTidyEnv - ) where - -import OccName -import Var -import VarSet -import UniqFM -import Unique -import Util -import Maybes -import Outputable -import FastTypes -import StaticFlags -import FastString -\end{code} - - -%************************************************************************ -%* * - In-scope sets -%* * -%************************************************************************ - -\begin{code} --- | A set of variables that are in scope at some point -data InScopeSet = InScope (VarEnv Var) FastInt - -- The (VarEnv Var) is just a VarSet. But we write it like - -- this to remind ourselves that you can look up a Var in - -- the InScopeSet. Typically the InScopeSet contains the - -- canonical version of the variable (e.g. with an informative - -- unfolding), so this lookup is useful. - -- - -- INVARIANT: the VarEnv maps (the Unique of) a variable to - -- a variable with the same Uniqua. (This was not - -- the case in the past, when we had a grevious hack - -- mapping var1 to var2. - -- - -- The FastInt is a kind of hash-value used by uniqAway - -- For example, it might be the size of the set - -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway - -instance Outputable InScopeSet where - ppr (InScope s _) = ptext (sLit "InScope") <+> ppr s - -emptyInScopeSet :: InScopeSet -emptyInScopeSet = InScope emptyVarSet (_ILIT(1)) - -getInScopeVars :: InScopeSet -> VarEnv Var -getInScopeVars (InScope vs _) = vs - -mkInScopeSet :: VarEnv Var -> InScopeSet -mkInScopeSet in_scope = InScope in_scope (_ILIT(1)) - -extendInScopeSet :: InScopeSet -> Var -> InScopeSet -extendInScopeSet (InScope in_scope n) v = InScope (extendVarEnv in_scope v v) (n +# _ILIT(1)) - -extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet -extendInScopeSetList (InScope in_scope n) vs - = InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs) - (n +# iUnbox (length vs)) - -extendInScopeSetSet :: InScopeSet -> VarEnv Var -> InScopeSet -extendInScopeSetSet (InScope in_scope n) vs - = InScope (in_scope `plusVarEnv` vs) (n +# iUnbox (sizeUFM vs)) - -delInScopeSet :: InScopeSet -> Var -> InScopeSet -delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n - -elemInScopeSet :: Var -> InScopeSet -> Bool -elemInScopeSet v (InScope in_scope _) = v `elemVarEnv` in_scope - --- | Look up a variable the 'InScopeSet'. This lets you map from --- the variable's identity (unique) to its full value. -lookupInScope :: InScopeSet -> Var -> Maybe Var -lookupInScope (InScope in_scope _) v = lookupVarEnv in_scope v -\end{code} - -\begin{code} --- | @uniqAway in_scope v@ finds a unique that is not used in the --- in-scope set, and gives that to v. -uniqAway :: InScopeSet -> Var -> Var --- It starts with v's current unique, of course, in the hope that it won't --- have to change, and thereafter uses a combination of that and the hash-code --- found in the in-scope set -uniqAway in_scope var - | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one - | otherwise = var -- Nothing to do - -uniqAway' :: InScopeSet -> Var -> Var --- This one *always* makes up a new variable -uniqAway' (InScope set n) var - = try (_ILIT(1)) - where - orig_unique = getUnique var - try k - | debugIsOn && (k ># _ILIT(1000)) - = pprPanic "uniqAway loop:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) - | uniq `elemVarSetByKey` set = try (k +# _ILIT(1)) - | debugIsOn && opt_PprStyle_Debug && (k ># _ILIT(3)) - = pprTrace "uniqAway:" (ppr (iBox k) <+> text "tries" <+> ppr var <+> int (iBox n)) - setVarUnique var uniq - | otherwise = setVarUnique var uniq - where - uniq = deriveUnique orig_unique (iBox (n *# k)) -\end{code} - -%************************************************************************ -%* * - Dual renaming -%* * -%************************************************************************ - -\begin{code} --- | When we are comparing (or matching) types or terms, we are faced with --- \"going under\" corresponding binders. E.g. when comparing: --- --- > \x. e1 ~ \y. e2 --- --- Basically we want to rename [@x@ -> @y@] or [@y@ -> @x@], but there are lots of --- things we must be careful of. In particular, @x@ might be free in @e2@, or --- y in @e1@. So the idea is that we come up with a fresh binder that is free --- in neither, and rename @x@ and @y@ respectively. That means we must maintain: --- --- 1. A renaming for the left-hand expression --- --- 2. A renaming for the right-hand expressions --- --- 3. An in-scope set --- --- Furthermore, when matching, we want to be able to have an 'occurs check', --- to prevent: --- --- > \x. f ~ \y. y --- --- matching with [@f@ -> @y@]. So for each expression we want to know that set of --- locally-bound variables. That is precisely the domain of the mappings 1. --- and 2., but we must ensure that we always extend the mappings as we go in. --- --- All of this information is bundled up in the 'RnEnv2' -data RnEnv2 - = RV2 { envL :: VarEnv Var -- Renaming for Left term - , envR :: VarEnv Var -- Renaming for Right term - , in_scope :: InScopeSet } -- In scope in left or right terms - --- The renamings envL and envR are *guaranteed* to contain a binding --- for every variable bound as we go into the term, even if it is not --- renamed. That way we can ask what variables are locally bound --- (inRnEnvL, inRnEnvR) - -mkRnEnv2 :: InScopeSet -> RnEnv2 -mkRnEnv2 vars = RV2 { envL = emptyVarEnv - , envR = emptyVarEnv - , in_scope = vars } - -extendRnInScopeList :: RnEnv2 -> [Var] -> RnEnv2 -extendRnInScopeList env vs - = env { in_scope = extendInScopeSetList (in_scope env) vs } - -rnInScope :: Var -> RnEnv2 -> Bool -rnInScope x env = x `elemInScopeSet` in_scope env - -rnInScopeSet :: RnEnv2 -> InScopeSet -rnInScopeSet = in_scope - -rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2 --- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length -rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR - -rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2 --- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term, --- and binder @bR@ in the Right term. --- It finds a new binder, @new_b@, --- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@ -rnBndr2 (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR - = RV2 { envL = extendVarEnv envL bL new_b -- See Note - , envR = extendVarEnv envR bR new_b -- [Rebinding] - , in_scope = extendInScopeSet in_scope new_b } - where - -- Find a new binder not in scope in either term - new_b | not (bL `elemInScopeSet` in_scope) = bL - | not (bR `elemInScopeSet` in_scope) = bR - | otherwise = uniqAway' in_scope bL - - -- Note [Rebinding] - -- If the new var is the same as the old one, note that - -- the extendVarEnv *deletes* any current renaming - -- E.g. (\x. \x. ...) ~ (\y. \z. ...) - -- - -- Inside \x \y { [x->y], [y->y], {y} } - -- \x \z { [x->x], [y->y, z->x], {y,x} } - -rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndr2' but used when there's a binder on the left --- side only. Useful when eta-expanding -rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL - = (RV2 { envL = extendVarEnv envL bL new_b - , envR = extendVarEnv envR new_b new_b -- Note [rnBndrLR] - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - new_b = uniqAway in_scope bL - -rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var) --- ^ Similar to 'rnBndr2' but used when there's a binder on the right --- side only. Useful when eta-expanding -rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR - = (RV2 { envL = extendVarEnv envL new_b new_b -- Note [rnBndrLR] - , envR = extendVarEnv envR bR new_b - , in_scope = extendInScopeSet in_scope new_b }, new_b) - where - new_b = uniqAway in_scope bR - --- Note [rnBndrLR] --- ~~~~~~~~~~~~~~~ --- Notice that in rnBndrL, rnBndrR, we extend envR, envL respectively --- with a binding [new_b -> new_b], where new_b is the new binder. --- This is important when doing eta expansion; e.g. matching (\x.M) ~ N --- In effect we switch to (\x'.M) ~ (\x'.N x'), where x' is new_b --- So we must add x' to the env of both L and R. (x' is fresh, so it --- can't capture anything in N.) --- --- If we don't do this, we can get silly matches like --- forall a. \y.a ~ v --- succeeding with [x -> v y], which is bogus of course - -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 - -inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool --- ^ Tells whether a variable is locally bound -inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env -inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env - -lookupRnInScope :: RnEnv2 -> Var -> Var -lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v - -nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2 --- ^ Wipe the left or right side renaming -nukeRnEnvL env = env { envL = emptyVarEnv } -nukeRnEnvR env = env { envR = emptyVarEnv } -\end{code} - - -%************************************************************************ -%* * - Tidying -%* * -%************************************************************************ - -\begin{code} --- | When tidying up print names, we keep a mapping of in-scope occ-names --- (the 'TidyOccEnv') and a Var-to-Var of the current renamings -type TidyEnv = (TidyOccEnv, VarEnv Var) - -emptyTidyEnv :: TidyEnv -emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) -\end{code} - - -%************************************************************************ -%* * -\subsection{@VarEnv@s} -%* * -%************************************************************************ - -\begin{code} -type VarEnv elt = UniqFM elt -type IdEnv elt = VarEnv elt -type TyVarEnv elt = VarEnv elt - -emptyVarEnv :: VarEnv a -mkVarEnv :: [(Var, a)] -> VarEnv a -zipVarEnv :: [Var] -> [a] -> VarEnv a -unitVarEnv :: Var -> a -> VarEnv a -extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a -extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a -plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a -extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a - -lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a -filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a -restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a -delVarEnvList :: VarEnv a -> [Var] -> VarEnv a -delVarEnv :: VarEnv a -> Var -> VarEnv a -plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a -mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b -modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a -varEnvElts :: VarEnv a -> [a] -varEnvKeys :: VarEnv a -> [Unique] - -isEmptyVarEnv :: VarEnv a -> Bool -lookupVarEnv :: VarEnv a -> Var -> Maybe a -lookupVarEnv_NF :: VarEnv a -> Var -> a -lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a -elemVarEnv :: Var -> VarEnv a -> Bool -elemVarEnvByKey :: Unique -> VarEnv a -> Bool -foldVarEnv :: (a -> b -> b) -> b -> VarEnv a -> b -\end{code} - -\begin{code} -elemVarEnv = elemUFM -elemVarEnvByKey = elemUFM_Directly -extendVarEnv = addToUFM -extendVarEnv_C = addToUFM_C -extendVarEnvList = addListToUFM -plusVarEnv_C = plusUFM_C -delVarEnvList = delListFromUFM -delVarEnv = delFromUFM -plusVarEnv = plusUFM -lookupVarEnv = lookupUFM -lookupWithDefaultVarEnv = lookupWithDefaultUFM -mapVarEnv = mapUFM -mkVarEnv = listToUFM -emptyVarEnv = emptyUFM -varEnvElts = eltsUFM -varEnvKeys = keysUFM -unitVarEnv = unitUFM -isEmptyVarEnv = isNullUFM -foldVarEnv = foldUFM -lookupVarEnv_Directly = lookupUFM_Directly -filterVarEnv_Directly = filterUFM_Directly - -restrictVarEnv env vs = filterVarEnv_Directly keep env - where - keep u _ = u `elemVarSetByKey` vs - -zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) -lookupVarEnv_NF env id = case lookupVarEnv env id of - Just xx -> xx - Nothing -> panic "lookupVarEnv_NF: Nothing" -\end{code} - -@modifyVarEnv@: Look up a thing in the VarEnv, -then mash it with the modify function, and put it back. - -\begin{code} -modifyVarEnv mangle_fn env key - = case (lookupVarEnv env key) of - Nothing -> env - Just xx -> extendVarEnv env key (mangle_fn xx) - -modifyVarEnv_Directly :: (a -> a) -> UniqFM a -> Unique -> UniqFM a -modifyVarEnv_Directly mangle_fn env key - = case (lookupUFM_Directly env key) of - Nothing -> env - Just xx -> addToUFM_Directly env key (mangle_fn xx) -\end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/Var.lhs ghc-6.13-20091231/compiler/basicTypes/Var.lhs --- ghc-6.12.1/compiler/basicTypes/Var.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/Var.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,411 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section{@Vars@: Variables} - -\begin{code} --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'OccName.OccName': see "OccName#name_types" --- --- * 'RdrName.RdrName': see "RdrName#name_types" --- --- * 'Name.Name': see "Name#name_types" --- --- * '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. --- 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. -module Var ( - -- * The main data type - Var, - - -- ** Taking 'Var's apart - varName, varUnique, varType, - - -- ** Modifying 'Var's - setVarName, setVarUnique, setVarType, - - -- ** Constructing, taking apart, modifying 'Id's - mkGlobalVar, mkLocalVar, mkExportedLocalVar, - idInfo, idDetails, - lazySetIdInfo, setIdDetails, globaliseId, - setIdExported, setIdNotExported, - - -- ** Predicates - isCoVar, isId, isTyVar, isTcTyVar, - isLocalVar, isLocalId, - isGlobalId, isExportedId, - mustHaveLocalBinding, - - -- * Type variable data type - TyVar, - - -- ** Constructing 'TyVar's - mkTyVar, mkTcTyVar, mkWildCoVar, - - -- ** Taking 'TyVar's apart - tyVarName, tyVarKind, tcTyVarDetails, - - -- ** Modifying 'TyVar's - setTyVarName, setTyVarUnique, setTyVarKind, - - -- * Coercion variable data type - CoVar, - - -- ** Constructing 'CoVar's - mkCoVar, - - -- ** Taking 'CoVar's apart - coVarName, - - -- ** Modifying 'CoVar's - setCoVarUnique, setCoVarName, - - -- * 'Var' type synonyms - Id, DictId - ) where - -#include "HsVersions.h" - -import {-# SOURCE #-} TypeRep( Type, Kind ) -import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails ) -import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, pprIdDetails ) -import {-# SOURCE #-} TypeRep( isCoercionKind ) - -import Name hiding (varName) -import Unique -import FastTypes -import FastString -import Outputable -\end{code} - - -%************************************************************************ -%* * -\subsection{The main data type declarations} -%* * -%************************************************************************ - - -Every @Var@ has a @Unique@, to uniquify it and for fast comparison, a -@Type@, and an @IdInfo@ (non-essential info about it, e.g., -strictness). The essential info about different kinds of @Vars@ is -in its @VarDetails@. - -\begin{code} --- | Essentially a typed 'Name', that may also contain some additional information --- about the 'Var' and it's use sites. -data Var - = TyVar { - varName :: !Name, - 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 - } - - | TcTyVar { -- Used only during type inference - -- Used for kind variables during - -- inference, as well - varName :: !Name, - realUnique :: FastInt, - varType :: Kind, - tcTyVarDetails :: TcTyVarDetails } - - | Id { - varName :: !Name, - realUnique :: FastInt, - varType :: Type, - idScope :: IdScope, - id_details :: IdDetails, -- Stable, doesn't change - id_info :: IdInfo } -- Unstable, updated by simplifier - -data IdScope -- See Note [GlobalId/LocalId] - = GlobalId - | LocalId ExportFlag - -data ExportFlag - = NotExported -- ^ Not exported: may be discarded as dead code. - | Exported -- ^ Exported: kept alive -\end{code} - -Note [GlobalId/LocalId] -~~~~~~~~~~~~~~~~~~~~~~~ -A GlobalId is - * always a constant (top-level) - * imported, or data constructor, or primop, or record selector - * has a Unique that is globally unique across the whole - GHC invocation (a single invocation may compile multiple modules) - * never treated as a candidate by the free-variable finder; - it's a constant! - -A LocalId is - * bound within an expression (lambda, case, local let(rec)) - * or defined at top level in the module being compiled - * always treated as a candidate by the free-variable finder - -After CoreTidy, top-level LocalIds are turned into GlobalIds - -\begin{code} -instance Outputable Var where - ppr var = ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var)) - -ppr_debug :: Var -> SDoc -ppr_debug (TyVar {}) = ptext (sLit "tv") -ppr_debug (TcTyVar {tcTyVarDetails = d}) = pprTcTyVarDetails d -ppr_debug (Id { idScope = s, id_details = d }) = ppr_id_scope s <> pprIdDetails d - -ppr_id_scope :: IdScope -> SDoc -ppr_id_scope GlobalId = ptext (sLit "gid") -ppr_id_scope (LocalId Exported) = ptext (sLit "lidx") -ppr_id_scope (LocalId NotExported) = ptext (sLit "lid") - -instance Show Var where - showsPrec p var = showsPrecSDoc p (ppr var) - -instance NamedThing Var where - getName = varName - -instance Uniquable Var where - getUnique = varUnique - -instance Eq Var where - a == b = realUnique a ==# realUnique b - -instance Ord Var where - a <= b = realUnique a <=# realUnique b - a < b = realUnique a <# realUnique b - a >= b = realUnique a >=# realUnique b - a > b = realUnique a ># realUnique b - a `compare` b = varUnique a `compare` varUnique b -\end{code} - - -\begin{code} -varUnique :: Var -> Unique -varUnique var = mkUniqueGrimily (iBox (realUnique var)) - -setVarUnique :: Var -> Unique -> Var -setVarUnique var uniq - = var { realUnique = getKeyFastInt uniq, - varName = setNameUnique (varName var) uniq } - -setVarName :: Var -> Name -> Var -setVarName var new_name - = var { realUnique = getKeyFastInt (getUnique new_name), - varName = new_name } - -setVarType :: Id -> Type -> Id -setVarType id ty = id { varType = ty } -\end{code} - - -%************************************************************************ -%* * -\subsection{Type variables} -%* * -%************************************************************************ - -\begin{code} -type TyVar = Var - -tyVarName :: TyVar -> Name -tyVarName = varName - -tyVarKind :: TyVar -> Kind -tyVarKind = varType - -setTyVarUnique :: TyVar -> Unique -> TyVar -setTyVarUnique = setVarUnique - -setTyVarName :: TyVar -> Name -> TyVar -setTyVarName = setVarName - -setTyVarKind :: TyVar -> Kind -> TyVar -setTyVarKind tv k = tv {varType = k} -\end{code} - -\begin{code} -mkTyVar :: Name -> Kind -> TyVar -mkTyVar name kind = ASSERT( not (isCoercionKind kind ) ) - TyVar { varName = name - , realUnique = getKeyFastInt (nameUnique name) - , varType = kind - , isCoercionVar = False - } - -mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar -mkTcTyVar name kind details - = -- NB: 'kind' may be a coercion kind; cf, 'TcMType.newMetaCoVar' - TcTyVar { varName = name, - realUnique = getKeyFastInt (nameUnique name), - varType = kind, - tcTyVarDetails = details - } -\end{code} - -%************************************************************************ -%* * -\subsection{Coercion variables} -%* * -%************************************************************************ - -\begin{code} -type CoVar = TyVar -- A coercion variable is simply a type - -- variable of kind @ty1 ~ ty2@. Hence its - -- 'varType' is always @PredTy (EqPred t1 t2)@ - -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} -%* * -%************************************************************************ - -\begin{code} --- These synonyms are here and not in Id because otherwise we need a very --- large number of SOURCE imports of Id.hs :-( -type Id = Var -type DictId = Var - -idInfo :: Id -> IdInfo -idInfo (Id { id_info = info }) = info -idInfo other = pprPanic "idInfo" (ppr other) - -idDetails :: Id -> IdDetails -idDetails (Id { id_details = details }) = details -idDetails other = pprPanic "idDetails" (ppr other) - --- The next three have a 'Var' suffix even though they always build --- Ids, becuase Id.lhs uses 'mkGlobalId' etc with different types -mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id -mkGlobalVar details name ty info - = mk_id name ty GlobalId details info - -mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id -mkLocalVar details name ty info - = mk_id name ty (LocalId NotExported) details info - --- | Exported 'Var's will not be removed as dead code -mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id -mkExportedLocalVar details name ty info - = mk_id name ty (LocalId Exported) details info - -mk_id :: Name -> Type -> IdScope -> IdDetails -> IdInfo -> Id -mk_id name ty scope details info - = Id { varName = name, - realUnique = getKeyFastInt (nameUnique name), - varType = ty, - idScope = scope, - id_details = details, - id_info = info } - -------------------- -lazySetIdInfo :: Id -> IdInfo -> Var -lazySetIdInfo id info = id { id_info = info } - -setIdDetails :: Id -> IdDetails -> Id -setIdDetails id details = id { id_details = details } - -globaliseId :: Id -> Id --- ^ If it's a local, make it global -globaliseId id = id { idScope = GlobalId } - -setIdExported :: Id -> Id --- ^ Exports the given local 'Id'. Can also be called on global 'Id's, such as data constructors --- and class operations, which are born as global 'Id's and automatically exported -setIdExported id@(Id { idScope = LocalId {} }) = id { idScope = LocalId Exported } -setIdExported id@(Id { idScope = GlobalId }) = id -setIdExported tv = pprPanic "setIdExported" (ppr tv) - -setIdNotExported :: Id -> Id --- ^ We can only do this to LocalIds -setIdNotExported id = ASSERT( isLocalId id ) - id { idScope = LocalId NotExported } -\end{code} - -%************************************************************************ -%* * -\subsection{Predicates over variables} -%* * -%************************************************************************ - -\begin{code} -isTyVar :: Var -> Bool -isTyVar (TyVar {}) = True -isTyVar (TcTyVar {}) = True -isTyVar _ = False - -isTcTyVar :: Var -> Bool -isTcTyVar (TcTyVar {}) = True -isTcTyVar _ = False - -isId :: Var -> Bool -isId (Id {}) = True -isId _ = False - -isLocalId :: Var -> Bool -isLocalId (Id { idScope = LocalId _ }) = True -isLocalId _ = False - -isCoVar :: Var -> Bool -isCoVar (v@(TyVar {})) = isCoercionVar v -isCoVar (TcTyVar {varType = kind}) = isCoercionKind kind -- used during solving -isCoVar _ = False - --- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's --- These are the variables that we need to pay attention to when finding free --- variables, or doing dependency analysis. -isLocalVar :: Var -> Bool -isLocalVar v = not (isGlobalId v) - -isGlobalId :: Var -> Bool -isGlobalId (Id { idScope = GlobalId }) = True -isGlobalId _ = False - --- | 'mustHaveLocalBinding' returns @True@ of 'Id's and 'TyVar's --- that must have a binding in this module. The converse --- is not quite right: there are some global 'Id's that must have --- bindings, such as record selectors. But that doesn't matter, --- because it's only used for assertions -mustHaveLocalBinding :: Var -> Bool -mustHaveLocalBinding var = isLocalVar var - --- | 'isExportedIdVar' means \"don't throw this away\" -isExportedId :: Var -> Bool -isExportedId (Id { idScope = GlobalId }) = True -isExportedId (Id { idScope = LocalId Exported}) = True -isExportedId _ = False -\end{code} diff -ruN ghc-6.12.1/compiler/basicTypes/VarSet.lhs ghc-6.13-20091231/compiler/basicTypes/VarSet.lhs --- ghc-6.12.1/compiler/basicTypes/VarSet.lhs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/basicTypes/VarSet.lhs 1969-12-31 16:00:00.000000000 -0800 @@ -1,116 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -\begin{code} -module VarSet ( - -- * Var, Id and TyVar set types - VarSet, IdSet, TyVarSet, - - -- ** Manipulating these sets - emptyVarSet, unitVarSet, mkVarSet, - extendVarSet, extendVarSetList, extendVarSet_C, - elemVarSet, varSetElems, subVarSet, - unionVarSet, unionVarSets, - intersectVarSet, intersectsVarSet, disjointVarSet, - isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, - minusVarSet, foldVarSet, filterVarSet, fixVarSet, - lookupVarSet, mapVarSet, sizeVarSet, seqVarSet, - elemVarSetByKey - ) where - -#include "HsVersions.h" - -import Var ( Var, TyVar, Id ) -import Unique -import UniqSet -\end{code} - -%************************************************************************ -%* * -\subsection{@VarSet@s} -%* * -%************************************************************************ - -\begin{code} -type VarSet = UniqSet Var -type IdSet = UniqSet Id -type TyVarSet = UniqSet TyVar - -emptyVarSet :: VarSet -intersectVarSet :: VarSet -> VarSet -> VarSet -unionVarSet :: VarSet -> VarSet -> VarSet -unionVarSets :: [VarSet] -> VarSet -varSetElems :: VarSet -> [Var] -unitVarSet :: Var -> VarSet -extendVarSet :: VarSet -> Var -> VarSet -extendVarSetList:: VarSet -> [Var] -> VarSet -elemVarSet :: Var -> VarSet -> Bool -delVarSet :: VarSet -> Var -> VarSet -delVarSetList :: VarSet -> [Var] -> VarSet -minusVarSet :: VarSet -> VarSet -> VarSet -isEmptyVarSet :: VarSet -> Bool -mkVarSet :: [Var] -> VarSet -foldVarSet :: (Var -> a -> a) -> a -> VarSet -> a -lookupVarSet :: VarSet -> Var -> Maybe Var - -- Returns the set element, which may be - -- (==) to the argument, but not the same as -mapVarSet :: (Var -> Var) -> VarSet -> VarSet -sizeVarSet :: VarSet -> Int -filterVarSet :: (Var -> Bool) -> VarSet -> VarSet -extendVarSet_C :: (Var->Var->Var) -> VarSet -> Var -> VarSet - -delVarSetByKey :: VarSet -> Unique -> VarSet -elemVarSetByKey :: Unique -> VarSet -> Bool -fixVarSet :: (VarSet -> VarSet) -> VarSet -> VarSet - -emptyVarSet = emptyUniqSet -unitVarSet = unitUniqSet -extendVarSet = addOneToUniqSet -extendVarSetList= addListToUniqSet -intersectVarSet = intersectUniqSets - -intersectsVarSet:: VarSet -> VarSet -> Bool -- True if non-empty intersection -disjointVarSet :: VarSet -> VarSet -> Bool -- True if empty intersection -subVarSet :: VarSet -> VarSet -> Bool -- True if first arg is subset of second - -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty; - -- ditto disjointVarSet, subVarSet - -unionVarSet = unionUniqSets -unionVarSets = unionManyUniqSets -varSetElems = uniqSetToList -elemVarSet = elementOfUniqSet -minusVarSet = minusUniqSet -delVarSet = delOneFromUniqSet -delVarSetList = delListFromUniqSet -isEmptyVarSet = isEmptyUniqSet -mkVarSet = mkUniqSet -foldVarSet = foldUniqSet -lookupVarSet = lookupUniqSet -mapVarSet = mapUniqSet -sizeVarSet = sizeUniqSet -filterVarSet = filterUniqSet -extendVarSet_C = addOneToUniqSet_C -delVarSetByKey = delOneFromUniqSet_Directly -elemVarSetByKey = elemUniqSet_Directly -\end{code} - -\begin{code} --- See comments with type signatures -intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2) -disjointVarSet s1 s2 = isEmptyVarSet (s1 `intersectVarSet` s2) -subVarSet s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2) - --- Iterate f to a fixpoint -fixVarSet f s | new_s `subVarSet` s = s - | otherwise = fixVarSet f new_s - where - new_s = f s -\end{code} - -\begin{code} -seqVarSet :: VarSet -> () -seqVarSet s = sizeVarSet s `seq` () -\end{code} - diff -ruN ghc-6.12.1/compiler/cmm/BlockId.hs ghc-6.13-20091231/compiler/cmm/BlockId.hs --- ghc-6.12.1/compiler/cmm/BlockId.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/cmm/BlockId.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,159 +0,0 @@ -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 - , blockLbl, infoTblLbl, retPtLbl - ) where - -import CLabel -import IdInfo -import Maybes -import Name -import Outputable -import UniqFM -import Unique -import UniqSet - ----------------------------------------------------------------- ---- Block Ids, their environments, and their sets - -{- Note [Unique BlockId] -~~~~~~~~~~~~~~~~~~~~~~~~ -Although a 'BlockId' is a local label, for reasons of implementation, -'BlockId's must be unique within an entire compilation unit. The reason -is that each local label is mapped to an assembly-language label, and in -most assembly languages allow, a label is visible throughout the entire -compilation unit in which it appears. --} - -data BlockId = BlockId Unique - deriving (Eq,Ord) - -instance Uniquable BlockId where - getUnique (BlockId id) = id - -mkBlockId :: Unique -> BlockId -mkBlockId uniq = BlockId uniq - -instance Show BlockId where - show (BlockId u) = show u - -instance Outputable BlockId where - ppr (BlockId id) = ppr id - -retPtLbl :: BlockId -> CLabel -retPtLbl (BlockId id) = mkReturnPtLabel id - -blockLbl :: BlockId -> CLabel -blockLbl (BlockId id) = mkEntryLabel (mkFCallName id "block") NoCafRefs - -infoTblLbl :: BlockId -> CLabel -infoTblLbl (BlockId id) = mkInfoTableLabel (mkFCallName id "block") NoCafRefs - --- Block environments: Id blocks -newtype BlockEnv a = BlockEnv (UniqFM {- id -} 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 - -foldBlockEnv' :: (a -> b -> b) -> b -> BlockEnv a -> b -foldBlockEnv' f b (BlockEnv env) = foldUFM f b env - -plusBlockEnv :: BlockEnv elt -> BlockEnv elt -> BlockEnv elt -plusBlockEnv (BlockEnv x) (BlockEnv y) = BlockEnv (plusUFM x y) - -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 - - -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 diff -ruN ghc-6.12.1/compiler/cmm/CLabel.hs ghc-6.13-20091231/compiler/cmm/CLabel.hs --- ghc-6.12.1/compiler/cmm/CLabel.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/cmm/CLabel.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,1022 +0,0 @@ -{-# 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 - ------------------------------------------------------------------------------ --- --- Object-file symbols (called CLabel for histerical raisins). --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module CLabel ( - CLabel, -- abstract type - - mkClosureLabel, - mkSRTLabel, - mkInfoTableLabel, - mkEntryLabel, - mkSlowEntryLabel, - mkConEntryLabel, - mkStaticConEntryLabel, - mkRednCountsLabel, - mkConInfoTableLabel, - mkStaticInfoTableLabel, - mkLargeSRTLabel, - mkApEntryLabel, - mkApInfoTableLabel, - mkClosureTableLabel, - - mkLocalClosureLabel, - mkLocalInfoTableLabel, - mkLocalEntryLabel, - mkLocalConEntryLabel, - mkLocalStaticConEntryLabel, - mkLocalConInfoTableLabel, - mkLocalStaticInfoTableLabel, - mkLocalClosureTableLabel, - - mkReturnPtLabel, - mkReturnInfoLabel, - mkAltLabel, - mkDefaultLabel, - mkBitmapLabel, - mkStringLitLabel, - - mkAsmTempLabel, - - mkModuleInitLabel, - mkPlainModuleInitLabel, - mkModuleInitTableLabel, - - mkSplitMarkerLabel, - mkDirty_MUT_VAR_Label, - mkUpdInfoLabel, - mkIndStaticInfoLabel, - mkMainCapabilityLabel, - mkMAP_FROZEN_infoLabel, - mkMAP_DIRTY_infoLabel, - mkEMPTY_MVAR_infoLabel, - - mkTopTickyCtrLabel, - mkCAFBlackHoleInfoTableLabel, - mkRtsPrimOpLabel, - mkRtsSlowTickyCtrLabel, - - moduleRegdLabel, - moduleRegTableLabel, - - mkSelectorInfoLabel, - mkSelectorEntryLabel, - - mkRtsInfoLabel, - mkRtsEntryLabel, - mkRtsRetInfoLabel, - mkRtsRetLabel, - mkRtsCodeLabel, - mkRtsDataLabel, - mkRtsGcPtrLabel, - - mkRtsInfoLabelFS, - mkRtsEntryLabelFS, - mkRtsRetInfoLabelFS, - mkRtsRetLabelFS, - mkRtsCodeLabelFS, - mkRtsDataLabelFS, - - mkRtsApFastLabel, - - mkPrimCallLabel, - - mkForeignLabel, - addLabelSize, - foreignLabelStdcallInfo, - - mkCCLabel, mkCCSLabel, - - DynamicLinkerLabelInfo(..), - mkDynamicLinkerLabel, - dynamicLinkerLabelInfo, - - mkPicBaseLabel, - mkDeadStripPreventer, - - mkHpcTicksLabel, - mkHpcModuleNameLabel, - - hasCAF, - infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl, - needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel, - isMathFun, - isCFunctionLabel, isGcPtrLabel, labelDynamic, - - pprCLabel - ) where - -#include "HsVersions.h" - -import IdInfo -import StaticFlags -import BasicTypes -import Literal -import Packages -import DataCon -import PackageConfig -import Module -import Name -import Unique -import PrimOp -import Config -import CostCentre -import Outputable -import FastString -import DynFlags -import UniqSet - --- ----------------------------------------------------------------------------- --- The CLabel type - -{- -CLabel is an abstract type that supports the following operations: - - - Pretty printing - - - In a C file, does it need to be declared before use? (i.e. is it - guaranteed to be already in scope in the places we need to refer to it?) - - - If it needs to be declared, what type (code or data) should it be - declared to have? - - - Is it visible outside this object file or not? - - - Is it "dynamic" (see details below) - - - Eq and Ord, so that we can make sets of CLabels (currently only - used in outputting C as far as I can tell, to avoid generating - more than one declaration for any given label). - - - Converting an info table label into an entry label. --} - -data CLabel - = IdLabel -- A family of labels related to the - Name -- definition of a particular Id or Con - CafInfo - IdLabelInfo - - | CaseLabel -- A family of labels related to a particular - -- case expression. - {-# UNPACK #-} !Unique -- Unique says which case expression - CaseLabelInfo - - | AsmTempLabel - {-# UNPACK #-} !Unique - - | 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 - Module - - | ModuleRegdLabel - - | RtsLabel RtsLabelInfo - - | ForeignLabel FastString -- a 'C' (or otherwise foreign) label - (Maybe Int) -- possible '@n' suffix for stdcall functions - -- When generating C, the '@n' suffix is omitted, but when - -- generating assembler we must add it to the label. - Bool -- True <=> is dynamic - FunctionOrData - - | CC_Label CostCentre - | CCS_Label CostCentreStack - - -- Dynamic Linking in the NCG: - -- generated and used inside the NCG only, - -- see module PositionIndependentCode for details. - - | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel - -- special variants of a label used for dynamic linking - - | PicBaseLabel -- a label used as a base for PIC calculations - -- on some platforms. - -- It takes the form of a local numeric - -- assembler label '1'; it is pretty-printed - -- as 1b, referring to the previous definition - -- of 1: in the assembler source file. - - | DeadStripPreventer CLabel - -- label before an info table to prevent excessive dead-stripping on darwin - - | HpcTicksLabel Module -- Per-module table of tick locations - | HpcModuleNameLabel -- Per-module name of the module for Hpc - - | LargeSRTLabel -- Label of an StgLargeSRT - {-# UNPACK #-} !Unique - - | LargeBitmapLabel -- A bitmap (function or case return) - {-# UNPACK #-} !Unique - - deriving (Eq, Ord) - -data IdLabelInfo - = Closure -- Label for closure - | SRT -- Static reference table - | InfoTable -- 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 - - | ConEntry -- constructor entry point - | ConInfoTable -- corresponding info table - | StaticConEntry -- static constructor entry point - | StaticInfoTable -- corresponding info table - - | ClosureTable -- table of closures for Enum tycons - - deriving (Eq, Ord) - - -data CaseLabelInfo - = CaseReturnPt - | CaseReturnInfo - | CaseAlt ConTag - | CaseDefault - deriving (Eq, Ord) - - -data RtsLabelInfo - = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-} -- Selector thunks - | RtsSelectorEntry Bool{-updatable-} Int{-offset-} - - | RtsApInfoTable Bool{-updatable-} Int{-arity-} -- AP thunks - | RtsApEntry Bool{-updatable-} Int{-arity-} - - | RtsPrimOp PrimOp - - | RtsInfo LitString -- misc rts info tables - | RtsEntry LitString -- misc rts entry points - | RtsRetInfo LitString -- misc rts ret info tables - | RtsRet LitString -- misc rts return points - | RtsData LitString -- misc rts data bits - | RtsGcPtr LitString -- GcPtrs eg CHARLIKE_closure - | RtsCode LitString -- misc rts code - - | RtsInfoFS FastString -- misc rts info tables - | RtsEntryFS FastString -- misc rts entry points - | RtsRetInfoFS FastString -- misc rts ret info tables - | RtsRetFS FastString -- misc rts return points - | RtsDataFS FastString -- misc rts data bits, eg CHARLIKE_closure - | RtsCodeFS FastString -- misc rts code - - | RtsApFast LitString -- _fast versions of generic apply - - | RtsSlowTickyCtr String - - deriving (Eq, Ord) - -- NOTE: Eq on LitString compares the pointer only, so this isn't - -- a real equality. - -data DynamicLinkerLabelInfo - = CodeStub -- MachO: Lfoo$stub, ELF: foo@plt - | SymbolPtr -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo - | GotSymbolPtr -- ELF: foo@got - | GotSymbolOffset -- ELF: foo@gotoff - - deriving (Eq, Ord) - --- ----------------------------------------------------------------------------- --- Constructing CLabels - --- These are always local: -mkSRTLabel name c = IdLabel name c SRT -mkSlowEntryLabel name c = IdLabel name c Slow -mkRednCountsLabel name c = IdLabel name c RednCounts - --- These have local & (possibly) external variants: -mkLocalClosureLabel name c = IdLabel name c Closure -mkLocalInfoTableLabel name c = IdLabel name c InfoTable -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 -mkEntryLabel name c = IdLabel name c Entry -mkClosureTableLabel name c = IdLabel name c ClosureTable -mkLocalConInfoTableLabel c con = IdLabel con c ConInfoTable -mkLocalConEntryLabel c con = IdLabel con c ConEntry -mkLocalStaticInfoTableLabel c con = IdLabel con c StaticInfoTable -mkLocalStaticConEntryLabel c con = IdLabel con c StaticConEntry -mkConInfoTableLabel name c = IdLabel name c ConInfoTable -mkStaticInfoTableLabel name c = IdLabel name c StaticInfoTable - -mkConEntryLabel name c = IdLabel name c ConEntry -mkStaticConEntryLabel name c = IdLabel name c StaticConEntry - -mkLargeSRTLabel uniq = LargeSRTLabel uniq -mkBitmapLabel uniq = LargeBitmapLabel uniq - -mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt -mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo -mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag) -mkDefaultLabel uniq = CaseLabel uniq CaseDefault - -mkStringLitLabel = StringLitLabel -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 - - -- Some fixed runtime system labels - -mkSplitMarkerLabel = RtsLabel (RtsCode (sLit "__stg_split_marker")) -mkDirty_MUT_VAR_Label = RtsLabel (RtsCode (sLit "dirty_MUT_VAR")) -mkUpdInfoLabel = RtsLabel (RtsInfo (sLit "stg_upd_frame")) -mkIndStaticInfoLabel = RtsLabel (RtsInfo (sLit "stg_IND_STATIC")) -mkMainCapabilityLabel = RtsLabel (RtsData (sLit "MainCapability")) -mkMAP_FROZEN_infoLabel = RtsLabel (RtsInfo (sLit "stg_MUT_ARR_PTRS_FROZEN0")) -mkMAP_DIRTY_infoLabel = RtsLabel (RtsInfo (sLit "stg_MUT_ARR_PTRS_DIRTY")) -mkEMPTY_MVAR_infoLabel = RtsLabel (RtsInfo (sLit "stg_EMPTY_MVAR")) - -mkTopTickyCtrLabel = RtsLabel (RtsData (sLit "top_ct")) -mkCAFBlackHoleInfoTableLabel = RtsLabel (RtsInfo (sLit "stg_CAF_BLACKHOLE")) -mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) - -moduleRegdLabel = ModuleRegdLabel -moduleRegTableLabel = ModuleInitTableLabel - -mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTable upd off) -mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off) - -mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTable upd off) -mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) - - -- Primitive / cmm call labels - -mkPrimCallLabel :: PrimCall -> CLabel -mkPrimCallLabel (PrimCall str) = ForeignLabel str Nothing False IsFunction - - -- Foreign labels - -mkForeignLabel :: FastString -> Maybe Int -> Bool -> FunctionOrData -> CLabel -mkForeignLabel str mb_sz is_dynamic fod - = ForeignLabel str mb_sz is_dynamic fod - -addLabelSize :: CLabel -> Int -> CLabel -addLabelSize (ForeignLabel str _ is_dynamic fod) sz - = ForeignLabel str (Just sz) is_dynamic fod -addLabelSize label _ - = label - -foreignLabelStdcallInfo :: CLabel -> Maybe Int -foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info -foreignLabelStdcallInfo _lbl = Nothing - - -- Cost centres etc. - -mkCCLabel cc = CC_Label cc -mkCCSLabel ccs = CCS_Label ccs - -mkRtsInfoLabel str = RtsLabel (RtsInfo str) -mkRtsEntryLabel str = RtsLabel (RtsEntry str) -mkRtsRetInfoLabel str = RtsLabel (RtsRetInfo str) -mkRtsRetLabel str = RtsLabel (RtsRet str) -mkRtsCodeLabel str = RtsLabel (RtsCode str) -mkRtsDataLabel str = RtsLabel (RtsData str) -mkRtsGcPtrLabel str = RtsLabel (RtsGcPtr str) - -mkRtsInfoLabelFS str = RtsLabel (RtsInfoFS str) -mkRtsEntryLabelFS str = RtsLabel (RtsEntryFS str) -mkRtsRetInfoLabelFS str = RtsLabel (RtsRetInfoFS str) -mkRtsRetLabelFS str = RtsLabel (RtsRetFS str) -mkRtsCodeLabelFS str = RtsLabel (RtsCodeFS str) -mkRtsDataLabelFS str = RtsLabel (RtsDataFS str) - -mkRtsApFastLabel str = RtsLabel (RtsApFast str) - -mkRtsSlowTickyCtrLabel :: String -> CLabel -mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat) - - -- Coverage - -mkHpcTicksLabel = HpcTicksLabel -mkHpcModuleNameLabel = HpcModuleNameLabel - - -- Dynamic linking - -mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel -mkDynamicLinkerLabel = DynamicLinkerLabel - -dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel) -dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl) -dynamicLinkerLabelInfo _ = Nothing - - -- Position independent code - -mkPicBaseLabel :: CLabel -mkPicBaseLabel = PicBaseLabel - -mkDeadStripPreventer :: CLabel -> CLabel -mkDeadStripPreventer lbl = DeadStripPreventer lbl - --- ----------------------------------------------------------------------------- --- 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 (RtsLabel (RtsInfo s)) = RtsLabel (RtsEntry s) -infoLblToEntryLbl (RtsLabel (RtsRetInfo s)) = RtsLabel (RtsRet s) -infoLblToEntryLbl (RtsLabel (RtsInfoFS s)) = RtsLabel (RtsEntryFS s) -infoLblToEntryLbl (RtsLabel (RtsRetInfoFS s)) = RtsLabel (RtsRetFS s) -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 (RtsLabel (RtsEntry s)) = RtsLabel (RtsInfo s) -entryLblToInfoLbl (RtsLabel (RtsRet s)) = RtsLabel (RtsRetInfo s) -entryLblToInfoLbl (RtsLabel (RtsEntryFS s)) = RtsLabel (RtsInfoFS s) -entryLblToInfoLbl (RtsLabel (RtsRetFS s)) = RtsLabel (RtsRetInfoFS s) -entryLblToInfoLbl l = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l) - -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 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 -hasCAF (IdLabel _ MayHaveCafRefs _) = True -hasCAF _ = False - --- ----------------------------------------------------------------------------- --- Does a CLabel need declaring before use or not? --- --- See wiki:Commentary/Compiler/Backends/PprC#Prototypes - -needsCDecl :: CLabel -> Bool - -- False <=> it's pre-declared; don't bother - -- don't bother declaring SRT & Bitmap labels, we always make sure - -- they are defined before use. -needsCDecl (IdLabel _ _ SRT) = False -needsCDecl (LargeSRTLabel _) = False -needsCDecl (LargeBitmapLabel _) = False -needsCDecl (IdLabel _ _ _) = True -needsCDecl (CaseLabel _ _) = True -needsCDecl (ModuleInitLabel _ _) = True -needsCDecl (PlainModuleInitLabel _) = True -needsCDecl (ModuleInitTableLabel _) = True -needsCDecl ModuleRegdLabel = False - -needsCDecl (StringLitLabel _) = False -needsCDecl (AsmTempLabel _) = False -needsCDecl (RtsLabel _) = False -needsCDecl l@(ForeignLabel _ _ _ _) = not (isMathFun l) -needsCDecl (CC_Label _) = True -needsCDecl (CCS_Label _) = True -needsCDecl (HpcTicksLabel _) = True -needsCDecl HpcModuleNameLabel = False - --- Whether the label is an assembler temporary: - -isAsmTemp :: CLabel -> Bool -- is a local temporary for native code generation -isAsmTemp (AsmTempLabel _) = True -isAsmTemp _ = False - -maybeAsmTemp :: CLabel -> Maybe Unique -maybeAsmTemp (AsmTempLabel uq) = Just uq -maybeAsmTemp _ = Nothing - --- some labels have C prototypes in scope when compiling via C, because --- they are builtin to the C compiler. For these labels we avoid --- generating our own C prototypes. -isMathFun :: CLabel -> Bool -isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs -isMathFun _ = False - -math_funs = mkUniqSet [ - -- _ISOC99_SOURCE - (fsLit "acos"), (fsLit "acosf"), (fsLit "acosh"), - (fsLit "acoshf"), (fsLit "acoshl"), (fsLit "acosl"), - (fsLit "asin"), (fsLit "asinf"), (fsLit "asinl"), - (fsLit "asinh"), (fsLit "asinhf"), (fsLit "asinhl"), - (fsLit "atan"), (fsLit "atanf"), (fsLit "atanl"), - (fsLit "atan2"), (fsLit "atan2f"), (fsLit "atan2l"), - (fsLit "atanh"), (fsLit "atanhf"), (fsLit "atanhl"), - (fsLit "cbrt"), (fsLit "cbrtf"), (fsLit "cbrtl"), - (fsLit "ceil"), (fsLit "ceilf"), (fsLit "ceill"), - (fsLit "copysign"), (fsLit "copysignf"), (fsLit "copysignl"), - (fsLit "cos"), (fsLit "cosf"), (fsLit "cosl"), - (fsLit "cosh"), (fsLit "coshf"), (fsLit "coshl"), - (fsLit "erf"), (fsLit "erff"), (fsLit "erfl"), - (fsLit "erfc"), (fsLit "erfcf"), (fsLit "erfcl"), - (fsLit "exp"), (fsLit "expf"), (fsLit "expl"), - (fsLit "exp2"), (fsLit "exp2f"), (fsLit "exp2l"), - (fsLit "expm1"), (fsLit "expm1f"), (fsLit "expm1l"), - (fsLit "fabs"), (fsLit "fabsf"), (fsLit "fabsl"), - (fsLit "fdim"), (fsLit "fdimf"), (fsLit "fdiml"), - (fsLit "floor"), (fsLit "floorf"), (fsLit "floorl"), - (fsLit "fma"), (fsLit "fmaf"), (fsLit "fmal"), - (fsLit "fmax"), (fsLit "fmaxf"), (fsLit "fmaxl"), - (fsLit "fmin"), (fsLit "fminf"), (fsLit "fminl"), - (fsLit "fmod"), (fsLit "fmodf"), (fsLit "fmodl"), - (fsLit "frexp"), (fsLit "frexpf"), (fsLit "frexpl"), - (fsLit "hypot"), (fsLit "hypotf"), (fsLit "hypotl"), - (fsLit "ilogb"), (fsLit "ilogbf"), (fsLit "ilogbl"), - (fsLit "ldexp"), (fsLit "ldexpf"), (fsLit "ldexpl"), - (fsLit "lgamma"), (fsLit "lgammaf"), (fsLit "lgammal"), - (fsLit "llrint"), (fsLit "llrintf"), (fsLit "llrintl"), - (fsLit "llround"), (fsLit "llroundf"), (fsLit "llroundl"), - (fsLit "log"), (fsLit "logf"), (fsLit "logl"), - (fsLit "log10l"), (fsLit "log10"), (fsLit "log10f"), - (fsLit "log1pl"), (fsLit "log1p"), (fsLit "log1pf"), - (fsLit "log2"), (fsLit "log2f"), (fsLit "log2l"), - (fsLit "logb"), (fsLit "logbf"), (fsLit "logbl"), - (fsLit "lrint"), (fsLit "lrintf"), (fsLit "lrintl"), - (fsLit "lround"), (fsLit "lroundf"), (fsLit "lroundl"), - (fsLit "modf"), (fsLit "modff"), (fsLit "modfl"), - (fsLit "nan"), (fsLit "nanf"), (fsLit "nanl"), - (fsLit "nearbyint"), (fsLit "nearbyintf"), (fsLit "nearbyintl"), - (fsLit "nextafter"), (fsLit "nextafterf"), (fsLit "nextafterl"), - (fsLit "nexttoward"), (fsLit "nexttowardf"), (fsLit "nexttowardl"), - (fsLit "pow"), (fsLit "powf"), (fsLit "powl"), - (fsLit "remainder"), (fsLit "remainderf"), (fsLit "remainderl"), - (fsLit "remquo"), (fsLit "remquof"), (fsLit "remquol"), - (fsLit "rint"), (fsLit "rintf"), (fsLit "rintl"), - (fsLit "round"), (fsLit "roundf"), (fsLit "roundl"), - (fsLit "scalbln"), (fsLit "scalblnf"), (fsLit "scalblnl"), - (fsLit "scalbn"), (fsLit "scalbnf"), (fsLit "scalbnl"), - (fsLit "sin"), (fsLit "sinf"), (fsLit "sinl"), - (fsLit "sinh"), (fsLit "sinhf"), (fsLit "sinhl"), - (fsLit "sqrt"), (fsLit "sqrtf"), (fsLit "sqrtl"), - (fsLit "tan"), (fsLit "tanf"), (fsLit "tanl"), - (fsLit "tanh"), (fsLit "tanhf"), (fsLit "tanhl"), - (fsLit "tgamma"), (fsLit "tgammaf"), (fsLit "tgammal"), - (fsLit "trunc"), (fsLit "truncf"), (fsLit "truncl"), - -- ISO C 99 also defines these function-like macros in math.h: - -- fpclassify, isfinite, isinf, isnormal, signbit, isgreater, - -- isgreaterequal, isless, islessequal, islessgreater, isunordered - - -- additional symbols from _BSD_SOURCE - (fsLit "drem"), (fsLit "dremf"), (fsLit "dreml"), - (fsLit "finite"), (fsLit "finitef"), (fsLit "finitel"), - (fsLit "gamma"), (fsLit "gammaf"), (fsLit "gammal"), - (fsLit "isinf"), (fsLit "isinff"), (fsLit "isinfl"), - (fsLit "isnan"), (fsLit "isnanf"), (fsLit "isnanl"), - (fsLit "j0"), (fsLit "j0f"), (fsLit "j0l"), - (fsLit "j1"), (fsLit "j1f"), (fsLit "j1l"), - (fsLit "jn"), (fsLit "jnf"), (fsLit "jnl"), - (fsLit "lgamma_r"), (fsLit "lgammaf_r"), (fsLit "lgammal_r"), - (fsLit "scalb"), (fsLit "scalbf"), (fsLit "scalbl"), - (fsLit "significand"), (fsLit "significandf"), (fsLit "significandl"), - (fsLit "y0"), (fsLit "y0f"), (fsLit "y0l"), - (fsLit "y1"), (fsLit "y1f"), (fsLit "y1l"), - (fsLit "yn"), (fsLit "ynf"), (fsLit "ynl") - ] - --- ----------------------------------------------------------------------------- --- Is a CLabel visible outside this object file or not? - --- From the point of view of the code generator, a name is --- externally visible if it has to be declared as exported --- in the .o file's symbol table; that is, made non-static. - -externallyVisibleCLabel :: CLabel -> Bool -- not C "static" -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 (ForeignLabel _ _ _ _) = True -externallyVisibleCLabel (IdLabel name _ _) = isExternalName name -externallyVisibleCLabel (CC_Label _) = True -externallyVisibleCLabel (CCS_Label _) = True -externallyVisibleCLabel (DynamicLinkerLabel _ _) = False -externallyVisibleCLabel (HpcTicksLabel _) = True -externallyVisibleCLabel HpcModuleNameLabel = False -externallyVisibleCLabel (LargeBitmapLabel _) = False -externallyVisibleCLabel (LargeSRTLabel _) = False - --- ----------------------------------------------------------------------------- --- Finding the "type" of a CLabel - --- For generating correct types in label declarations: - -data CLabelType - = CodeLabel -- Address of some executable instructions - | DataLabel -- Address of data, not a GC ptr - | GcPtrLabel -- Address of a (presumably static) GC object - -isCFunctionLabel :: CLabel -> Bool -isCFunctionLabel lbl = case labelType lbl of - CodeLabel -> True - _other -> False - -isGcPtrLabel :: CLabel -> Bool -isGcPtrLabel lbl = case labelType lbl of - GcPtrLabel -> True - _other -> False - -labelType :: CLabel -> CLabelType -labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel -labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel -labelType (RtsLabel (RtsData _)) = DataLabel -labelType (RtsLabel (RtsGcPtr _)) = GcPtrLabel -labelType (RtsLabel (RtsCode _)) = CodeLabel -labelType (RtsLabel (RtsInfo _)) = DataLabel -labelType (RtsLabel (RtsEntry _)) = CodeLabel -labelType (RtsLabel (RtsRetInfo _)) = DataLabel -labelType (RtsLabel (RtsRet _)) = CodeLabel -labelType (RtsLabel (RtsDataFS _)) = DataLabel -labelType (RtsLabel (RtsCodeFS _)) = CodeLabel -labelType (RtsLabel (RtsInfoFS _)) = DataLabel -labelType (RtsLabel (RtsEntryFS _)) = CodeLabel -labelType (RtsLabel (RtsRetInfoFS _)) = DataLabel -labelType (RtsLabel (RtsRetFS _)) = CodeLabel -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 -labelType (IdLabel _ _ info) = idInfoLabelType info -labelType _ = DataLabel - -idInfoLabelType info = - case info of - InfoTable -> DataLabel - Closure -> GcPtrLabel - ConInfoTable -> DataLabel - StaticInfoTable -> DataLabel - ClosureTable -> DataLabel - RednCounts -> DataLabel - _ -> CodeLabel - - --- ----------------------------------------------------------------------------- --- Does a CLabel need dynamic linkage? - --- When referring to data in code, we need to know whether --- that data resides in a DLL or not. [Win32 only.] --- @labelDynamic@ returns @True@ if the label is located --- in a DLL, be it a data reference or not. - -labelDynamic :: PackageId -> CLabel -> Bool -labelDynamic this_pkg lbl = - case lbl of - RtsLabel _ -> not opt_Static && (this_pkg /= rtsPackageId) -- i.e., is the RTS in a DLL or not? - IdLabel n _ k -> isDllName this_pkg n -#if mingw32_TARGET_OS - ForeignLabel _ _ d _ -> d -#else - -- On Mac OS X and on ELF platforms, false positives are OK, - -- so we claim that all foreign imports come from dynamic libraries - ForeignLabel _ _ _ _ -> 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 - -{- -OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the -right places. It is used to detect when the abstractC statement of an -CCodeBlock actually contains the code for a slow entry point. -- HWL - -We need at least @Eq@ for @CLabels@, because we want to avoid -duplicate declarations in generating C (see @labelSeenTE@ in -@PprAbsC@). --} - ------------------------------------------------------------------------------ --- Printing out CLabels. - -{- -Convention: - - _ - -where is _ for external names and for -internal names. is one of the following: - - info Info table - srt Static reference table - srtd Static reference table descriptor - entry Entry code (function, closure) - slow Slow entry code (if any) - ret Direct return address - vtbl Vector table - _alt Case alternative (tag n) - dflt Default case alternative - btm Large bitmap vector - closure Static closure - con_entry Dynamic Constructor entry code - con_info Dynamic Constructor info table - static_entry Static Constructor entry code - static_info Static Constructor info table - sel_info Selector info table - sel_entry Selector entry code - cc Cost centre - ccs Cost centre stack - -Many of these distinctions are only for documentation reasons. For -example, _ret is only distinguished from _entry to make it easy to -tell whether a code fragment is a return point or a closure/function -entry. --} - -instance Outputable CLabel where - ppr = pprCLabel - -pprCLabel :: CLabel -> SDoc - -#if ! OMIT_NATIVE_CODEGEN -pprCLabel (AsmTempLabel u) - = getPprStyle $ \ sty -> - if asmStyle sty then - ptext asmTempLabelPrefix <> pprUnique u - else - char '_' <> pprUnique u - -pprCLabel (DynamicLinkerLabel info lbl) - = pprDynamicLinkerAsmLabel info lbl - -pprCLabel PicBaseLabel - = ptext (sLit "1b") - -pprCLabel (DeadStripPreventer lbl) - = 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 - -maybe_underscore doc - | underscorePrefix = pp_cSEP <> doc - | otherwise = doc - -#ifdef mingw32_TARGET_OS --- In asm mode, we need to put the suffix on a stdcall ForeignLabel. --- (The C compiler does this itself). -pprAsmCLbl (ForeignLabel fs (Just sz) _ _) - = ftext fs <> char '@' <> int sz -#endif -pprAsmCLbl lbl - = pprCLbl lbl - -pprCLbl (StringLitLabel u) - = pprUnique u <> ptext (sLit "_str") - -pprCLbl (CaseLabel u CaseReturnPt) - = hcat [pprUnique u, ptext (sLit "_ret")] -pprCLbl (CaseLabel u CaseReturnInfo) - = hcat [pprUnique u, ptext (sLit "_info")] -pprCLbl (CaseLabel u (CaseAlt tag)) - = hcat [pprUnique u, pp_cSEP, int tag, ptext (sLit "_alt")] -pprCLbl (CaseLabel u CaseDefault) - = hcat [pprUnique u, ptext (sLit "_dflt")] - -pprCLbl (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> ptext (sLit "srtd") -pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLit "btm") --- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7') --- until that gets resolved we'll just force them to start --- with a letter so the label will be legal assmbly code. - - -pprCLbl (RtsLabel (RtsCode str)) = ptext str -pprCLbl (RtsLabel (RtsData str)) = ptext str -pprCLbl (RtsLabel (RtsGcPtr str)) = ptext str -pprCLbl (RtsLabel (RtsCodeFS str)) = ftext str -pprCLbl (RtsLabel (RtsDataFS str)) = ftext str - -pprCLbl (RtsLabel (RtsApFast str)) = ptext str <> ptext (sLit "_fast") - -pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset)) - = hcat [ptext (sLit "stg_sel_"), text (show offset), - ptext (if upd_reqd - then (sLit "_upd_info") - else (sLit "_noupd_info")) - ] - -pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset)) - = hcat [ptext (sLit "stg_sel_"), text (show offset), - ptext (if upd_reqd - then (sLit "_upd_entry") - else (sLit "_noupd_entry")) - ] - -pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity)) - = hcat [ptext (sLit "stg_ap_"), text (show arity), - ptext (if upd_reqd - then (sLit "_upd_info") - else (sLit "_noupd_info")) - ] - -pprCLbl (RtsLabel (RtsApEntry upd_reqd arity)) - = hcat [ptext (sLit "stg_ap_"), text (show arity), - ptext (if upd_reqd - then (sLit "_upd_entry") - else (sLit "_noupd_entry")) - ] - -pprCLbl (RtsLabel (RtsInfo fs)) - = ptext fs <> ptext (sLit "_info") - -pprCLbl (RtsLabel (RtsEntry fs)) - = ptext fs <> ptext (sLit "_entry") - -pprCLbl (RtsLabel (RtsRetInfo fs)) - = ptext fs <> ptext (sLit "_info") - -pprCLbl (RtsLabel (RtsRet fs)) - = ptext fs <> ptext (sLit "_ret") - -pprCLbl (RtsLabel (RtsInfoFS fs)) - = ftext fs <> ptext (sLit "_info") - -pprCLbl (RtsLabel (RtsEntryFS fs)) - = ftext fs <> ptext (sLit "_entry") - -pprCLbl (RtsLabel (RtsRetInfoFS fs)) - = ftext fs <> ptext (sLit "_info") - -pprCLbl (RtsLabel (RtsRetFS fs)) - = ftext fs <> ptext (sLit "_ret") - -pprCLbl (RtsLabel (RtsPrimOp primop)) - = ptext (sLit "stg_") <> ppr primop - -pprCLbl (RtsLabel (RtsSlowTickyCtr pat)) - = ptext (sLit "SLOW_CALL_") <> text pat <> ptext (sLit "_ctr") - -pprCLbl ModuleRegdLabel - = ptext (sLit "_module_registered") - -pprCLbl (ForeignLabel str _ _ _) - = ftext str - -pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor - -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") - Entry -> ptext (sLit "entry") - Slow -> ptext (sLit "slow") - RednCounts -> ptext (sLit "ct") - ConEntry -> ptext (sLit "con_entry") - ConInfoTable -> ptext (sLit "con_info") - StaticConEntry -> ptext (sLit "static_entry") - StaticInfoTable -> ptext (sLit "static_info") - ClosureTable -> ptext (sLit "closure_tbl") - ) - - -pp_cSEP = char '_' - --- ----------------------------------------------------------------------------- --- Machine-dependent knowledge about labels. - -underscorePrefix :: Bool -- leading underscore on assembler labels? -underscorePrefix = (cLeadingUnderscore == "YES") - -asmTempLabelPrefix :: LitString -- for formatting labels -asmTempLabelPrefix = -#if alpha_TARGET_OS - {- The alpha assembler likes temporary labels to look like $L123 - instead of L123. (Don't toss the L, because then Lf28 - turns into $f28.) - -} - (sLit "$") -#elif darwin_TARGET_OS - (sLit "L") -#else - (sLit ".L") -#endif - -pprDynamicLinkerAsmLabel :: DynamicLinkerLabelInfo -> CLabel -> SDoc - -#if x86_64_TARGET_ARCH && darwin_TARGET_OS -pprDynamicLinkerAsmLabel CodeStub lbl - = char 'L' <> pprCLabel lbl <> text "$stub" -pprDynamicLinkerAsmLabel SymbolPtr lbl - = char 'L' <> pprCLabel lbl <> text "$non_lazy_ptr" -pprDynamicLinkerAsmLabel GotSymbolPtr lbl - = pprCLabel lbl <> text "@GOTPCREL" -pprDynamicLinkerAsmLabel GotSymbolOffset lbl - = pprCLabel lbl -pprDynamicLinkerAsmLabel _ _ - = panic "pprDynamicLinkerAsmLabel" -#elif darwin_TARGET_OS -pprDynamicLinkerAsmLabel CodeStub lbl - = char 'L' <> pprCLabel lbl <> text "$stub" -pprDynamicLinkerAsmLabel SymbolPtr lbl - = char 'L' <> pprCLabel lbl <> text "$non_lazy_ptr" -pprDynamicLinkerAsmLabel _ _ - = panic "pprDynamicLinkerAsmLabel" -#elif powerpc_TARGET_ARCH && linux_TARGET_OS -pprDynamicLinkerAsmLabel CodeStub lbl - = pprCLabel lbl <> text "@plt" -pprDynamicLinkerAsmLabel SymbolPtr lbl - = text ".LC_" <> pprCLabel lbl -pprDynamicLinkerAsmLabel _ _ - = panic "pprDynamicLinkerAsmLabel" -#elif x86_64_TARGET_ARCH && linux_TARGET_OS -pprDynamicLinkerAsmLabel CodeStub lbl - = pprCLabel lbl <> text "@plt" -pprDynamicLinkerAsmLabel GotSymbolPtr lbl - = pprCLabel lbl <> text "@gotpcrel" -pprDynamicLinkerAsmLabel GotSymbolOffset lbl - = pprCLabel lbl -pprDynamicLinkerAsmLabel SymbolPtr lbl - = text ".LC_" <> pprCLabel lbl -#elif linux_TARGET_OS -pprDynamicLinkerAsmLabel CodeStub lbl - = pprCLabel lbl <> text "@plt" -pprDynamicLinkerAsmLabel SymbolPtr lbl - = text ".LC_" <> pprCLabel lbl -pprDynamicLinkerAsmLabel GotSymbolPtr lbl - = pprCLabel lbl <> text "@got" -pprDynamicLinkerAsmLabel GotSymbolOffset lbl - = pprCLabel lbl <> text "@gotoff" -#elif mingw32_TARGET_OS -pprDynamicLinkerAsmLabel SymbolPtr lbl - = text "__imp_" <> pprCLabel lbl -pprDynamicLinkerAsmLabel _ _ - = panic "pprDynamicLinkerAsmLabel" -#else -pprDynamicLinkerAsmLabel _ _ - = panic "pprDynamicLinkerAsmLabel" -#endif diff -ruN ghc-6.12.1/compiler/cmm/CmmBrokenBlock.hs ghc-6.13-20091231/compiler/cmm/CmmBrokenBlock.hs --- ghc-6.12.1/compiler/cmm/CmmBrokenBlock.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/cmm/CmmBrokenBlock.hs 1969-12-31 16:00:00.000000000 -0800 @@ -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 -ruN ghc-6.12.1/compiler/cmm/CmmBuildInfoTables.hs ghc-6.13-20091231/compiler/cmm/CmmBuildInfoTables.hs --- ghc-6.12.1/compiler/cmm/CmmBuildInfoTables.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/cmm/CmmBuildInfoTables.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,540 +0,0 @@ -module CmmBuildInfoTables - ( CAFSet, CAFEnv, CmmTopForInfoTables(..), cafAnal, localCAFInfo, mkTopCAFInfo - , setInfoTableSRT, setInfoTableStackMap - , TopSRT, emptySRT, srtToData - , bundleCAFs - , finishInfoTables, lowerSafeForeignCalls, extendEnvsForSafeForeignCalls ) -where - -#include "HsVersions.h" - -import Constants -import Digraph -import qualified Prelude as P -import Prelude -import Util (sortLe) - -import BlockId -import Bitmap -import CLabel -import Cmm hiding (blockId) -import CmmInfo -import CmmProcPointZ -import CmmStackLayout -import CmmTx -import DFMonad -import FastString -import FiniteMap -import ForeignCall -import IdInfo -import Data.List -import Maybes -import MkZipCfg -import MkZipCfgCmm hiding (CmmAGraph, CmmBlock, CmmTopZ, CmmZ, CmmGraph) -import Control.Monad -import Name -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 - ----------------------------------------------------------------- --- Building InfoTables - - ------------------------------------------------------------------------ --- Stack Maps - --- Given a block ID, we return a representation of the layout of the stack, --- as suspended before entering that block. --- (For a return site to a function call, the layout does not include the --- parameter passing area (or the "return address" on the stack)). --- If the element is `Nothing`, then it represents a word of the stack that --- does not contain a live pointer. --- If the element is `Just` a register, then it represents a live spill slot --- for a pointer; we assume that a pointer is the size of a word. --- The head of the list represents the young end of the stack where the infotable --- pointer for the block `Bid` is stored. --- The infotable pointer itself is not included in the list. --- Call areas are also excluded from the list: besides the stuff in the update --- frame (and the return infotable), call areas should never be live across --- function calls. - --- RTS Invariant: All pointers must be word-aligned because each bit in the bitmap --- represents a word. Consequently, we have to be careful when we see a live slot --- on the stack: if we have packed multiple sub-word values into a word, --- we have to make sure that we only mark the entire word as a non-pointer. - --- Also, don't forget to stop at the old end of the stack (oldByte), --- which may differ depending on whether there is an update frame. -live_ptrs :: ByteOff -> BlockEnv SubAreaSet -> AreaMap -> BlockId -> [Maybe LocalReg] -live_ptrs oldByte slotEnv areaMap bid = - -- pprTrace "live_ptrs for" (ppr bid <+> ppr youngByte <+> ppr liveSlots) $ - reverse $ slotsToList youngByte liveSlots [] - where slotsToList n [] results | n == oldByte = results -- at old end of stack frame - slotsToList n (s : _) _ | n == oldByte = - pprPanic "slot left off live_ptrs" (ppr s <+> ppr oldByte <+> - ppr n <+> ppr liveSlots <+> ppr youngByte) - slotsToList n _ _ | n < oldByte = - panic "stack slots not allocated on word boundaries?" - slotsToList n l@((n', r, w) : rst) results = - if n == (n' + w) then -- slot's young byte is at n - ASSERT (not (isPtr r) || - (n `mod` wORD_SIZE == 0 && w == wORD_SIZE)) -- ptrs must be aligned - slotsToList next (dropWhile (non_ptr_younger_than next) rst) - (stack_rep : results) - else slotsToList next (dropWhile (non_ptr_younger_than next) l) - (Nothing : results) - where next = n - wORD_SIZE - stack_rep = if isPtr r then Just r else Nothing - slotsToList n [] results = slotsToList (n - wORD_SIZE) [] (Nothing : results) - non_ptr_younger_than next (n', r, w) = - n' + w > next && - ASSERT (not (isPtr r)) - True - isPtr = isGcPtrType . localRegType - liveSlots = sortBy (\ (off,_,_) (off',_,_) -> compare off' off) - (foldFM (\_ -> flip $ foldl add_slot) [] slots) - - add_slot rst (a@(RegSlot r@(LocalReg _ ty)), off, w) = - if off == w && widthInBytes (typeWidth ty) == w then - (expectJust "add_slot" (lookupFM areaMap a), r, w) : rst - else panic "live_ptrs: only part of a variable live at a proc point" - add_slot rst (CallArea Old, _, _) = - rst -- the update frame (or return infotable) should be live - -- would be nice to check that only that part of the callarea is live... - add_slot rst ((CallArea _), _, _) = - rst - -- JD: THIS ISN'T CURRENTLY A CORRECTNESS PROBLEM, BUT WE SHOULD REALLY - -- MAKE LIVENESS INFO AROUND CALLS MORE PRECISE -- FOR NOW, A 32-BIT - -- FLOAT PADS OUT TO 64 BITS, BUT WE ASSUME THE WHOLE PARAMETER-PASSING - -- AREA IS LIVE (WHICH IT ISN'T...). WE SHOULD JUST PUT THE LIVE AREAS - -- IN THE CALL NODES, WHICH SHOULD EVENTUALLY HAVE LIVE REGISTER AS WELL, - -- SO IT'S ALL GOING IN THE SAME DIRECTION. - -- pprPanic "CallAreas must not be live across function calls" (ppr bid <+> ppr c) - slots = expectJust "live_ptrs slots" $ lookupBlockEnv slotEnv bid - youngByte = expectJust "live_ptrs bid_pos" $ lookupFM areaMap (CallArea (Young bid)) - --- 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 -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) - - - ------------------------------------------------------------------------ --- SRTs - --- WE NEED AN EXAMPLE HERE. --- IN PARTICULAR, WE NEED TO POINT OUT THE DISTINCTION BETWEEN --- FUNCTIONS WITH STATIC CLOSURES AND THOSE THAT MUST BE CONSTRUCTED --- DYNAMICALLY (AND HENCE CAN'T BE REFERENCED IN AN SRT). --- IN THE LATTER CASE, WE HAVE TO TAKE ALL THE CAFs REFERENCED BY --- THE CLOSURE AND INLINE THEM INTO ANY SRT THAT MAY MENTION THE CLOSURE. --- (I.E. TAKE THE TRANSITIVE CLOSURE, but only for non-static closures). - - ------------------------------------------------------------------------ --- Finding the CAFs used by a procedure - -type CAFSet = FiniteMap CLabel () -type CAFEnv = BlockEnv CAFSet - --- First, an analysis to find live CAFs. -cafLattice :: DataflowLattice CAFSet -cafLattice = DataflowLattice "live cafs" emptyFM add False - where add new old = if sizeFM new' > sizeFM old then aTx new' else noTx new' - where new' = new `plusFM` old - -cafTransfers :: BackwardTransfers Middle Last CAFSet -cafTransfers = BackwardTransfers first middle last - where first _ live = live - middle m live = foldExpDeepMiddle addCaf m live - last l env = foldExpDeepLast addCaf l (joinOuts cafLattice env l) - addCaf e set = case e of - CmmLit (CmmLabel c) -> add c set - CmmLit (CmmLabelOff c _) -> add c set - CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set - _ -> set - add l s = if hasCAF l then addToFM s (cvtToClosureLbl l) () 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 - ------------------------------------------------------------------------ --- Building the SRTs - --- Description of the SRT for a given module. --- Note that this SRT may grow as we greedily add new CAFs to it. -data TopSRT = TopSRT { lbl :: CLabel - , next_elt :: Int -- the next entry in the table - , rev_elts :: [CLabel] - , elt_map :: FiniteMap CLabel Int } - -- map: CLabel -> its last entry in the table -instance Outputable TopSRT where - ppr (TopSRT lbl next elts eltmap) = - text "TopSRT:" <+> ppr lbl <+> ppr next <+> ppr elts <+> ppr eltmap - -emptySRT :: MonadUnique m => m TopSRT -emptySRT = - do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") NoCafRefs - return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = emptyFM } - -cafMember :: TopSRT -> CLabel -> Bool -cafMember srt lbl = elemFM lbl (elt_map srt) - -cafOffset :: TopSRT -> CLabel -> Maybe Int -cafOffset srt lbl = lookupFM (elt_map srt) lbl - -addCAF :: CLabel -> TopSRT -> TopSRT -addCAF caf srt = - srt { next_elt = last + 1 - , rev_elts = caf : rev_elts srt - , elt_map = addToFM (elt_map srt) caf last } - where last = next_elt srt - -srtToData :: TopSRT -> CmmZ -srtToData srt = Cmm [CmmData RelocatableReadOnlyData (CmmDataLabel (lbl srt) : tbl)] - where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt)) - --- Once we have found the CAFs, we need to do two things: --- 1. Build a table of all the CAFs used in the procedure. --- 2. Compute the C_SRT describing the subset of CAFs live at each procpoint. --- --- When building the local view of the SRT, we first make sure that all the CAFs are --- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap, --- 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 -> FiniteMap CLabel CAFSet -> CAFSet -> - FuelMonad (TopSRT, Maybe CmmTopZ, C_SRT) -buildSRTs topSRT topCAFMap cafs = - do let liftCAF lbl () z = -- get CAFs for functions without static closures - case lookupFM topCAFMap lbl of Just cafs -> z `plusFM` cafs - Nothing -> addToFM z lbl () - sub_srt topSRT localCafs = - let cafs = keysFM (foldFM liftCAF emptyFM localCafs) - mkSRT topSRT = - do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs - return (topSRT, localSRTs) - in if length cafs > maxBmpSize then - mkSRT (foldl add_if_missing topSRT cafs) - else -- make sure all the cafs are near the bottom of the srt - mkSRT (add_if_too_far topSRT cafs) - add_if_missing srt caf = - if cafMember srt caf then srt else addCAF caf srt - -- If a CAF is more than maxBmpSize entries from the young end of the - -- SRT, then we add it to the SRT again. - -- (Note: Not in the SRT => infinitely far.) - add_if_too_far srt@(TopSRT {elt_map = m}) cafs = - add srt (sortBy farthestFst cafs) - where - farthestFst x y = case (lookupFM m x, lookupFM m y) of - (Nothing, Nothing) -> EQ - (Nothing, Just _) -> LT - (Just _, Nothing) -> GT - (Just d, Just d') -> compare d' d - add srt [] = srt - add srt@(TopSRT {next_elt = next}) (caf : rst) = - case cafOffset srt caf of - Just ix -> if next - ix > maxBmpSize then - add (addCAF caf srt) rst - else srt - Nothing -> add (addCAF caf srt) rst - (topSRT, subSRTs) <- sub_srt topSRT cafs - let (sub_tbls, blockSRTs) = subSRTs - return (topSRT, sub_tbls, blockSRTs) - --- Construct an SRT bitmap. --- Adapted from simpleStg/SRT.lhs, which expects Id's. -procpointSRT :: CLabel -> FiniteMap CLabel Int -> [CLabel] -> - FuelMonad (Maybe CmmTopZ, C_SRT) -procpointSRT _ _ [] = - return (Nothing, NoC_SRT) -procpointSRT top_srt top_table entries = - do (top, srt) <- bitmap `seq` to_SRT top_srt offset len bitmap - return (top, srt) - where - ints = map (expectJust "constructSRT" . lookupFM top_table) entries - sorted_ints = sortLe (<=) ints - offset = head sorted_ints - bitmap_entries = map (subtract offset) sorted_ints - len = P.last bitmap_entries + 1 - bitmap = intsToBitmap len bitmap_entries - -maxBmpSize :: Int -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 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 - ( cmmLabelOffW top_srt off - : mkWordCLit (fromIntegral len) - : map mkWordCLit bmp) - return (Just tbl, C_SRT srt_desc_lbl 0 srt_escape) - | otherwise - = return (Nothing, C_SRT top_srt off (fromIntegral (head bmp))) - -- The fromIntegral converts to StgHalfWord - --- Gather CAF info for a procedure, but only if the procedure --- doesn't have a static closure. --- (If it has a static closure, it will already have an SRT to --- keep its CAFs live.) --- Any procedure referring to a non-static CAF c must keep live the --- any CAF that is reachable from c. -localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet) -localCAFInfo _ (CmmData _ _) = Nothing -localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (_, LGraph entry _)) = - case infoTbl of - CmmInfoTable False _ _ _ -> - Just (cvtToClosureLbl top_l, - expectJust "maybeBindCAFs" $ lookupBlockEnv cafEnv entry) - _ -> Nothing - --- Once we have the local CAF sets for some (possibly) mutually --- recursive functions, we can create an environment mapping --- each function to its set of CAFs. Note that a CAF may --- be a reference to a function. If that function f does not have --- a static closure, then we need to refer specifically --- to the set of CAFs used by f. Of course, the set of CAFs --- used by f must be included in the local CAF sets that are input to --- this function. To minimize lookup time later, we return --- the environment with every reference to f replaced by its set of CAFs. --- To do this replacement efficiently, we gather strongly connected --- components, then we sort the components in topological order. -mkTopCAFInfo :: [(CLabel, CAFSet)] -> FiniteMap CLabel CAFSet -mkTopCAFInfo localCAFs = foldl addToTop emptyFM g - where addToTop env (AcyclicSCC (l, cafset)) = - addToFM env l (flatten env cafset) - addToTop env (CyclicSCC nodes) = - let (lbls, cafsets) = unzip nodes - cafset = foldl plusFM emptyFM cafsets `delListFromFM` lbls - in foldl (\env l -> addToFM env l (flatten env cafset)) env lbls - flatten env cafset = foldFM (lookup env) emptyFM cafset - lookup env caf () cafset' = - case lookupFM env caf of Just cafs -> foldFM add cafset' cafs - Nothing -> add caf () cafset' - add caf () cafset' = addToFM cafset' caf () - g = stronglyConnCompFromEdgedVertices - (map (\n@(l, cafs) -> (n, l, keysFM cafs)) localCAFs) - -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 _) = (emptyFM, t) - --- Construct the SRTs for the given procedure. -setInfoTableSRT :: FiniteMap 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 _ _ _)) = - setSRT cafs topCAFMap topSRT t -setInfoTableSRT _ topSRT (_, t@(NoInfoTable _)) = return (topSRT, [t]) - -setSRT :: CAFSet -> FiniteMap CLabel CAFSet -> TopSRT -> - CmmTopForInfoTables -> FuelMonad (TopSRT, [CmmTopForInfoTables]) -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]) - 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') - 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 - --- 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. -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? --- Because we need this code to appear without interrruption: you can't rely on the --- value of the stack pointer between the call and resetting the thread state; --- you need to have an infotable on the young end of the stack both when --- suspending the thread and making the foreign call. --- All of this is much easier if we insert the suspend and resume calls here. - --- At the same time, we prepare for the stages of the compiler that --- build the proc points. We have to do this at the same time because --- the safe foreign calls need special treatment with respect to infotables. --- A safe foreign call needs an infotable even though it isn't --- 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)) - - --- 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) - -- 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 - load_tso <- newTemp gcWord -- TODO FIXME NOW - let suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "suspendThread"))) - resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "resumeThread"))) - suspend = mkStore (CmmReg spReg) (CmmLit (CmmBlock infotable)) <*> - 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" diff -ruN ghc-6.12.1/compiler/cmm/CmmCallConv.hs ghc-6.13-20091231/compiler/cmm/CmmCallConv.hs --- ghc-6.12.1/compiler/cmm/CmmCallConv.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/cmm/CmmCallConv.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,183 +0,0 @@ -module CmmCallConv ( - ParamLocation(..), - ArgumentFormat, - assignArguments, - assignArgumentsPos, - argumentsSize, -) where - -#include "HsVersions.h" - -import Cmm -import SMRep -import ZipCfgCmmRep (Convention(..)) - -import Constants -import StaticFlags (opt_Unregisterised) -import Outputable - --- Calculate the 'GlobalReg' or stack locations for function call --- parameters as used by the Cmm calling convention. - -data ParamLocation a - = RegisterParam GlobalReg - | StackParam a - -instance (Outputable a) => Outputable (ParamLocation a) 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 f reps = assignments - where - availRegs = getRegsWithNode - (sizes, assignments) = unzip $ assignArguments' reps (negate (sum sizes)) availRegs - assignArguments' [] _ _ = [] - assignArguments' (r:rs) offset availRegs = - (size,(r,assignment)):assignArguments' rs new_offset remaining - where - (assignment, new_offset, size, remaining) = - assign_reg assign_slot_neg (f r) offset availRegs - --- | 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 conv arg_ty reps = map cvt assignments - where -- The calling conventions (CgCallConv.hs) are complicated, to say the least - regs = case (reps, conv) of - (_, NativeNodeCall) -> getRegsWithNode - (_, NativeDirectCall) -> getRegsWithoutNode - ([_], NativeReturn) -> allRegs - (_, NativeReturn) -> getRegsWithNode - (_, GC) -> getRegsWithNode - (_, PrimOpCall) -> allRegs - ([_], PrimOpReturn) -> allRegs - (_, PrimOpReturn) -> getRegsWithNode - (_, Slow) -> noRegs - _ -> pprPanic "Unknown calling convention" (ppr conv) - (sizes, assignments) = unzip $ assignArguments' reps (sum sizes) regs - assignArguments' [] _ _ = [] - assignArguments' (r:rs) offset avails = - (size, (r,assignment)):assignArguments' rs new_offset remaining - where - (assignment, new_offset, size, remaining) = - assign_reg assign_slot_pos (arg_ty r) offset avails - cvt (l, RegisterParam r) = (l, RegisterParam r) - cvt (l, StackParam off) = (l, StackParam $ off * wORD_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 - -type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs. - , [GlobalReg] -- floats - , [GlobalReg] -- doubles - , [GlobalReg] -- longs (int64 and word64) - ) - --- Vanilla registers can contain pointers, Ints, Chars. --- Floats and doubles have separate register supplies. --- --- We take these register supplies from the *real* registers, i.e. those --- that are guaranteed to map to machine registers. - -vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: [Int] -vanillaRegNos | opt_Unregisterised = [] - | otherwise = regList mAX_Real_Vanilla_REG -floatRegNos | opt_Unregisterised = [] - | otherwise = regList mAX_Real_Float_REG -doubleRegNos | opt_Unregisterised = [] - | otherwise = regList mAX_Real_Double_REG -longRegNos | opt_Unregisterised = [] - | otherwise = regList mAX_Real_Long_REG - --- -getRegsWithoutNode, getRegsWithNode :: AvailRegs -getRegsWithoutNode = - (filter (\r -> r VGcPtr /= node) intRegs, - map FloatReg floatRegNos, map DoubleReg doubleRegNos, map LongReg longRegNos) - where intRegs = map VanillaReg vanillaRegNos -getRegsWithNode = - (intRegs, map FloatReg floatRegNos, map DoubleReg doubleRegNos, map LongReg longRegNos) - where intRegs = map VanillaReg vanillaRegNos - -allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos :: [Int] -allVanillaRegNos = regList mAX_Vanilla_REG -allFloatRegNos = regList mAX_Float_REG -allDoubleRegNos = regList mAX_Double_REG -allLongRegNos = regList mAX_Long_REG - -regList :: Int -> [Int] -regList n = [1 .. n] - -allRegs :: AvailRegs -allRegs = (map VanillaReg allVanillaRegNos, map FloatReg allFloatRegNos, - map DoubleReg allDoubleRegNos, map LongReg allLongRegNos) - -noRegs :: AvailRegs -noRegs = ([], [], [], []) - --- Round the size of a local register up to the nearest word. -{- -UNUSED 2008-12-29 - -slot_size :: LocalReg -> Int -slot_size reg = slot_size' (typeWidth (localRegType reg)) --} - -slot_size' :: Width -> Int -slot_size' reg = ((widthInBytes reg - 1) `div` wORD_SIZE) + 1 - -type Assignment = (ParamLocation WordOff, WordOff, WordOff, AvailRegs) -type SlotAssigner = Width -> Int -> AvailRegs -> Assignment - -assign_reg :: SlotAssigner -> CmmType -> WordOff -> AvailRegs -> Assignment -assign_reg slot ty off avails - | isFloatType ty = assign_float_reg slot width off avails - | otherwise = assign_bits_reg slot width off gcp avails - where - width = typeWidth ty - gcp | isGcPtrType ty = VGcPtr - | otherwise = VNonGcPtr - --- Assigning a slot using negative offsets from the stack pointer. --- JD: I don't know why this convention stops using all the registers --- after running out of one class of registers. -assign_slot_neg :: SlotAssigner -assign_slot_neg width off _regs = - (StackParam $ off, off + size, size, ([], [], [], [])) where size = slot_size' width - --- Assigning a slot using positive offsets into a CallArea. -assign_slot_pos :: SlotAssigner -assign_slot_pos width off _regs = - (StackParam $ off, off - size, size, ([], [], [], [])) - where size = slot_size' width - --- On calls in the native convention, `node` is used to hold the environment --- for the closure, so we can't pass arguments in that register. -assign_bits_reg :: SlotAssigner -> Width -> WordOff -> VGcPtr -> AvailRegs -> Assignment -assign_bits_reg _ W128 _ _ _ = panic "W128 is not a supported register type" -assign_bits_reg _ w off gcp (v:vs, fs, ds, ls) - | widthInBits w <= widthInBits wordWidth = - (RegisterParam (v gcp), off, 0, (vs, fs, ds, ls)) -assign_bits_reg _ w off _ (vs, fs, ds, l:ls) - | widthInBits w > widthInBits wordWidth = - (RegisterParam l, off, 0, (vs, fs, ds, ls)) -assign_bits_reg assign_slot w off _ regs@(_, _, _, _) = assign_slot w off regs - -assign_float_reg :: SlotAssigner -> Width -> WordOff -> AvailRegs -> Assignment -assign_float_reg _ W32 off (vs, f:fs, ds, ls) = (RegisterParam $ f, off, 0, (vs, fs, ds, ls)) -assign_float_reg _ W64 off (vs, fs, d:ds, ls) = (RegisterParam $ d, off, 0, (vs, fs, ds, ls)) -assign_float_reg _ W80 _ _ = panic "F80 is not a supported register type" -assign_float_reg assign_slot width off r = assign_slot width off r diff -ruN ghc-6.12.1/compiler/cmm/CmmCommonBlockElimZ.hs ghc-6.13-20091231/compiler/cmm/CmmCommonBlockElimZ.hs --- ghc-6.12.1/compiler/cmm/CmmCommonBlockElimZ.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/cmm/CmmCommonBlockElimZ.hs 1969-12-31 16:00:00.000000000 -0800 @@ -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 -ruN ghc-6.12.1/compiler/cmm/CmmContFlowOpt.hs ghc-6.13-20091231/compiler/cmm/CmmContFlowOpt.hs --- ghc-6.12.1/compiler/cmm/CmmContFlowOpt.hs 2009-12-10 10:11:32.000000000 -0800 +++ ghc-6.13-20091231/compiler/cmm/CmmContFlowOpt.hs 1969-12-31 16:00:00.000000000 -0800 @@ -1,224 +0,0 @@ - -module CmmContFlowOpt - ( runCmmOpts, cmmCfgOpts, cmmCfgOptsZ - , branchChainElimZ, removeUnreachableBlocksZ, predMap - , replaceLabelsZ, replaceBranches, runCmmContFlowOptsZs - ) -where - -import BlockId -import Cmm -import CmmTx -import qualified ZipCfg as G -import ZipCfg -import ZipCfgCmmRep - -import Maybes -import Control.Monad -import Outputable -import Prelude hiding (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 - -- Here branchChainElim can ultimately be replaced - -- with a more exciting combination of optimisations - -runCmmOpts :: Tx g -> Tx (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) - ------------------------------------- -mapProcs :: Tx (GenCmmTop d h s) -> Tx (GenCmm d h s) -mapProcs f (Cmm tops) = fmap Cmm (mapTx f tops) - ----------------------------------------------------------------- -branchChainElim :: Tx (ListGraph 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) - | null lone_branch_blocks -- No blocks to remove - = noTx (ListGraph blocks) - | otherwise - = aTx (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 - - lookup id = lookupBlockEnv env id `orElse` id ----------------------------------------------------------------- -branchChainElimZ :: Tx 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' --- is the entry block. You don't want to set the successor --- of a function call to the entry block because there is no good way --- to store both the infotables for the call and from the callee, --- while putting the stack pointer in a consistent place. --- --- 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 _) - | null lone_branch_blocks -- No blocks to remove - = noTx g - | otherwise - = aTx $ replaceLabelsZ env $ G.of_block_list eid (self_branches ++ others) - where - blocks = G.to_block_list g - (lone_branch_blocks, others) = partitionWith isLoneBranchZ blocks - env = mkClosureBlockEnvZ lone_branch_blocks - self_branches = - let loop_to (id, _) = - if lookup id == id then - Just (G.Block id (G.ZLast (G.mkBranchNode id))) - else - Nothing - in mapMaybe loop_to lone_branch_blocks - lookup id = lookupBlockEnv env id `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 - -- An infinite loop is not a link in a branch chain! - -maybeReplaceLabels :: (Last -> Bool) -> BlockEnv BlockId -> CmmGraph -> CmmGraph -maybeReplaceLabels lpred env = - replace_eid . G.map_nodes 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 - -replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph -replaceBranches env g = map_nodes 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 - ----------------------------------------------------------------- --- 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 ----------------------------------------------------------------- --- 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). --- --- 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')) -> - if canConcatWith b' then - (True, extendBlockEnv blocks' bid $ splice blocks' h b', - extendBlockEnv concatMap b' bid) - else unchanged - _ -> unchanged - num_preds bid = liftM sizeBlockSet (lookupBlockEnv backEdge