Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge master into profiling

  • Loading branch information...
commit 0a6c42dd535ce774cc11452b5c794783cde4ffb5 2 parents d423c5c + 415598b
@scpmw authored
Showing with 9,069 additions and 7,048 deletions.
  1. +1 −0  .gitignore
  2. +40 −66 aclocal.m4
  3. +2 −2 bindisttest/Makefile
  4. +2 −2 bindisttest/ghc.mk
  5. +2 −11 compiler/HsVersions.h
  6. +12 −32 compiler/basicTypes/BasicTypes.lhs
  7. +11 −7 compiler/basicTypes/DataCon.lhs
  8. +0 −3  compiler/basicTypes/Demand.lhs
  9. +13 −8 compiler/basicTypes/Id.lhs
  10. +11 −6 compiler/basicTypes/IdInfo.lhs
  11. +23 −42 compiler/basicTypes/Literal.lhs
  12. +28 −13 compiler/basicTypes/MkId.lhs
  13. +3 −0  compiler/basicTypes/MkId.lhs-boot
  14. +2 −2 compiler/basicTypes/Module.lhs
  15. +1 −1  compiler/basicTypes/Name.lhs
  16. +31 −1 compiler/basicTypes/NameEnv.lhs
  17. +4 −3 compiler/basicTypes/OccName.lhs
  18. +0 −6 compiler/basicTypes/RdrName.lhs
  19. +137 −138 compiler/basicTypes/SrcLoc.lhs
  20. +20 −24 compiler/basicTypes/UniqSupply.lhs
  21. +95 −111 compiler/basicTypes/Unique.lhs
  22. +0 −3  compiler/basicTypes/Var.lhs
  23. +1 −1  compiler/cmm/Bitmap.hs
  24. +6 −5 compiler/cmm/BlockId.hs
  25. +58 −59 compiler/cmm/CLabel.hs
  26. +19 −17 compiler/cmm/Cmm.hs
  27. +173 −308 compiler/cmm/CmmBuildInfoTables.hs
  28. +46 −37 compiler/cmm/CmmCallConv.hs
  29. +88 −55 compiler/cmm/CmmCommonBlockElim.hs
  30. +203 −154 compiler/cmm/CmmContFlowOpt.hs
  31. +10 −14 compiler/cmm/CmmCvt.hs
  32. +47 −81 compiler/cmm/CmmExpr.hs
  33. +91 −63 compiler/cmm/CmmInfo.hs
  34. +1,014 −0 compiler/cmm/CmmLayoutStack.hs
  35. +146 −122 compiler/cmm/CmmLint.hs
  36. +29 −28 compiler/cmm/CmmLive.hs
  37. +3 −6 compiler/cmm/CmmMachOp.hs
  38. +72 −77 compiler/cmm/CmmNode.hs
  39. +89 −78 compiler/cmm/CmmOpt.hs
  40. +61 −66 compiler/cmm/CmmParse.y
  41. +149 −156 compiler/cmm/CmmPipeline.hs
  42. +119 −252 compiler/cmm/CmmProcPoint.hs
  43. +31 −32 compiler/cmm/CmmRewriteAssignments.hs
  44. +500 −0 compiler/cmm/CmmSink.hs
  45. +0 −166 compiler/cmm/CmmSpillReload.hs
  46. +0 −591 compiler/cmm/CmmStackLayout.hs
  47. +57 −81 compiler/cmm/CmmUtils.hs
  48. +55 −55 compiler/cmm/Debug.hs
  49. +126 −0 compiler/cmm/Hoopl.hs
  50. +883 −0 compiler/cmm/Hoopl/Dataflow.hs
  51. +298 −320 compiler/cmm/MkGraph.hs
  52. +15 −32 compiler/cmm/OldCmm.hs
  53. +209 −0 compiler/cmm/OldCmmLint.hs
  54. +40 −77 compiler/cmm/OldPprCmm.hs
  55. +0 −141 compiler/cmm/OptimizationFuel.hs
  56. +164 −161 compiler/cmm/PprC.hs
  57. +66 −63 compiler/cmm/PprCmm.hs
  58. +43 −55 compiler/cmm/PprCmmDecl.hs
  59. +56 −70 compiler/cmm/PprCmmExpr.hs
  60. +76 −71 compiler/cmm/SMRep.lhs
  61. +0 −369 compiler/cmm/cmm-notes
  62. +51 −0 compiler/codeGen/CallerSaves.hs
  63. +12 −15 compiler/codeGen/CgBindery.lhs
  64. +49 −38 compiler/codeGen/CgCallConv.hs
  65. +10 −11 compiler/codeGen/CgCase.lhs
  66. +44 −32 compiler/codeGen/CgClosure.lhs
  67. +39 −35 compiler/codeGen/CgCon.lhs
  68. +14 −11 compiler/codeGen/CgExpr.lhs
  69. +5 −0 compiler/codeGen/CgExtCode.hs
  70. +31 −26 compiler/codeGen/CgForeignCall.hs
  71. +271 −266 compiler/codeGen/CgHeapery.lhs
  72. +69 −85 compiler/codeGen/CgInfoTbls.hs
  73. +19 −11 compiler/codeGen/CgMonad.lhs
  74. +32 −37 compiler/codeGen/CgParallel.hs
  75. +125 −40 compiler/codeGen/CgPrimOp.hs
  76. +31 −27 compiler/codeGen/CgProf.hs
  77. +10 −5 compiler/codeGen/CgStackery.lhs
  78. +17 −13 compiler/codeGen/CgTailCall.lhs
  79. +8 −7 compiler/codeGen/CgTicky.hs
  80. +16 −97 compiler/codeGen/CgUtils.hs
  81. +66 −58 compiler/codeGen/ClosureInfo.lhs
  82. +47 −34 compiler/codeGen/CodeGen.lhs
  83. +67 −91 compiler/codeGen/StgCmm.hs
  84. +127 −106 compiler/codeGen/StgCmmBind.hs
  85. +93 −85 compiler/codeGen/StgCmmClosure.hs
  86. +23 −22 compiler/codeGen/StgCmmCon.hs
  87. +10 −15 compiler/codeGen/StgCmmEnv.hs
  88. +259 −169 compiler/codeGen/StgCmmExpr.hs
  89. +163 −54 compiler/codeGen/StgCmmForeign.hs
  90. +25 −32 compiler/codeGen/StgCmmGran.hs
  91. +177 −101 compiler/codeGen/StgCmmHeap.hs
  92. +270 −130 compiler/codeGen/StgCmmLayout.hs
  93. +202 −35 compiler/codeGen/StgCmmMonad.hs
  94. +262 −67 compiler/codeGen/StgCmmPrim.hs
  95. +72 −57 compiler/codeGen/StgCmmProf.hs
  96. +12 −13 compiler/codeGen/StgCmmTicky.hs
  97. +123 −251 compiler/codeGen/StgCmmUtils.hs
  98. +7 −3 compiler/coreSyn/CoreArity.lhs
  99. +2 −2 compiler/coreSyn/CoreFVs.lhs
  100. +9 −31 compiler/coreSyn/CoreLint.lhs
  101. +238 −231 compiler/coreSyn/CorePrep.lhs
  102. +3 −2 compiler/coreSyn/CoreSubst.lhs
  103. +75 −13 compiler/coreSyn/CoreSyn.lhs
  104. +2 −2 compiler/coreSyn/CoreTidy.lhs
  105. +137 −156 compiler/coreSyn/CoreUnfold.lhs
  106. +122 −60 compiler/coreSyn/CoreUtils.lhs
  107. +3 −1 compiler/coreSyn/ExternalCore.lhs
  108. +28 −40 compiler/coreSyn/MkCore.lhs
  109. +111 −87 compiler/coreSyn/MkExternalCore.lhs
Sorry, we could not display the entire diff because too many files (488) changed.
View
1  .gitignore
@@ -74,6 +74,7 @@ _darcs/
/libraries/stm/
/libraries/template-haskell/
/libraries/terminfo/
+/libraries/transformers
/libraries/unix/
/libraries/utf8-string/
/libraries/vector/
View
106 aclocal.m4
@@ -171,7 +171,7 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
;;
arm)
GET_ARM_ISA()
- test -z "[$]2" || eval "[$]2=\"ArchARM {armISA = \$ARM_ISA, armISAExt = \$ARM_ISA_EXT}\""
+ test -z "[$]2" || eval "[$]2=\"ArchARM {armISA = \$ARM_ISA, armISAExt = \$ARM_ISA_EXT, armABI = \$ARM_ABI}\""
;;
alpha|mips|mipseb|mipsel|hppa|hppa1_1|ia64|m68k|rs6000|s390|s390x|sparc64|vax)
test -z "[$]2" || eval "[$]2=ArchUnknown"
@@ -363,22 +363,15 @@ AC_DEFUN([FP_SETTINGS],
[
if test "$windows" = YES
then
- if test "$HostArch" = "x86_64"
- then
- mingw_bin_prefix=x86_64-w64-mingw32-
- else
- mingw_bin_prefix=
- fi
- SettingsCCompilerCommand="\$topdir/../mingw/bin/${mingw_bin_prefix}gcc.exe"
- SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 $CONF_GCC_LINKER_OPTS_STAGE2"
- SettingsArCommand="\$topdir/../mingw/bin/${mingw_bin_prefix}ar.exe"
+ mingw_bin_prefix=mingw/bin/
+ SettingsCCompilerCommand="\$topdir/../${mingw_bin_prefix}gcc.exe"
+ SettingsArCommand="\$topdir/../${mingw_bin_prefix}ar.exe"
SettingsPerlCommand='$topdir/../perl/perl.exe'
- SettingsDllWrapCommand="\$topdir/../mingw/bin/${mingw_bin_prefix}dllwrap.exe"
- SettingsWindresCommand="\$topdir/../mingw/bin/${mingw_bin_prefix}windres.exe"
+ SettingsDllWrapCommand="\$topdir/../${mingw_bin_prefix}dllwrap.exe"
+ SettingsWindresCommand="\$topdir/../${mingw_bin_prefix}windres.exe"
SettingsTouchCommand='$topdir/touchy.exe'
else
SettingsCCompilerCommand="$WhatGccIsCalled"
- SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 $CONF_GCC_LINKER_OPTS_STAGE2"
SettingsArCommand="$ArCmd"
SettingsPerlCommand="$PerlCmd"
SettingsDllWrapCommand="/bin/false"
@@ -397,8 +390,11 @@ AC_DEFUN([FP_SETTINGS],
SettingsOptCommand="$OptCmd"
fi
fi
+ SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 $CONF_GCC_LINKER_OPTS_STAGE2"
+ SettingsLdFlags="$CONF_LD_LINKER_OPTS_STAGE2"
AC_SUBST(SettingsCCompilerCommand)
AC_SUBST(SettingsCCompilerFlags)
+ AC_SUBST(SettingsLdFlags)
AC_SUBST(SettingsArCommand)
AC_SUBST(SettingsPerlCommand)
AC_SUBST(SettingsDllWrapCommand)
@@ -475,6 +471,21 @@ AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS],
])
+AC_DEFUN([FP_PATH_PROG],[
+ AC_PATH_PROG($1,$2,$3,$4,$5,$6)
+ # If we have a cygwin path for something, and we try to run it
+ # from cabal or python, then it'll fail. So we convert to a
+ # native path.
+ if test "$HostOS" = "mingw32" && \
+ test "${OSTYPE}" != "msys" && \
+ test "${$1}" != ""
+ then
+ # Canonicalise to <drive>:/path/to/gcc
+ $1=`cygpath -m "${$1}"`
+ fi
+])
+
+
# FP_VISIBILITY_HIDDEN
# ----------------------------------
# Is the visibility hidden attribute supported?
@@ -781,16 +792,7 @@ 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 "$HostOS" = "mingw32" && \
- test "${OSTYPE}" != "msys" && \
- test "${HappyCmd}" != ""
-then
- # Canonicalise to <drive>:/path/to/gcc
- HappyCmd=`cygpath -m "${HappyCmd}"`
- AC_MSG_NOTICE([normalized happy command to $HappyCmd])
-fi
+[FP_PATH_PROG(HappyCmd,happy,)
AC_CACHE_CHECK([for version of happy], fptools_cv_happy_version,
changequote(, )dnl
@@ -817,15 +819,7 @@ 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 "$HostOS" = "mingw32" && \
- test "${OSTYPE}" != "msys" && \
- test "${AlexCmd}" != ""
-then
- # Canonicalise to <drive>:/path/to/gcc
- AlexCmd=`cygpath -m "${AlexCmd}"`
-fi
+FP_PATH_PROG(AlexCmd,alex,)
AC_CACHE_CHECK([for version of alex], fptools_cv_alex_version,
changequote(, )dnl
@@ -869,17 +863,6 @@ $2=$fp_cv_$2
])# FP_PROG_LD_FLAG
-# 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],
-[
-FP_PROG_LD_FLAG([-x],[LdXFlag])
-AC_SUBST([LdXFlag])
-])# FP_PROG_LD_X
-
-
# FP_PROG_LD_HashSize31
# ------------
# Sets the output variable LdHashSize31 to --hash-size=31 if ld supports
@@ -969,21 +952,12 @@ AC_SUBST([LdHasNoCompactUnwind])
# 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
+# Sets fp_prog_ar to a (non-Cygwin) path to ar. 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
+[FP_PATH_PROG([fp_prog_ar], [ar])
+if test -z "$fp_prog_ar"; 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
@@ -992,8 +966,8 @@ esac
# 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
+AC_CACHE_CHECK([whether $fp_prog_ar is GNU ar], [fp_cv_prog_ar_is_gnu],
+[if "$fp_prog_ar" --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
@@ -1010,14 +984,14 @@ AC_SUBST([ArIsGNUAr], [`echo $fp_prog_ar_is_gnu | tr 'a-z' 'A-Z'`])
AC_DEFUN([FP_PROG_AR_SUPPORTS_ATFILE],
[AC_REQUIRE([FP_PROG_AR])
AC_REQUIRE([FP_PROG_AR_ARGS])
-AC_CACHE_CHECK([whether $fp_prog_ar_raw supports @file], [fp_cv_prog_ar_supports_atfile],
+AC_CACHE_CHECK([whether $fp_prog_ar supports @file], [fp_cv_prog_ar_supports_atfile],
[
rm -f conftest*
touch conftest.file
echo conftest.file > conftest.atfile
echo conftest.file >> conftest.atfile
-"$fp_prog_ar_raw" $fp_prog_ar_args conftest.a @conftest.atfile > /dev/null 2>&1
-fp_prog_ar_supports_atfile_tmp=`"$fp_prog_ar_raw" t conftest.a 2> /dev/null | grep -c conftest.file`
+"$fp_prog_ar" $fp_prog_ar_args conftest.a @conftest.atfile > /dev/null 2>&1
+fp_prog_ar_supports_atfile_tmp=`"$fp_prog_ar" t conftest.a 2> /dev/null | grep -c conftest.file`
rm -f conftest*
if test "$fp_prog_ar_supports_atfile_tmp" -eq 2
then
@@ -1046,14 +1020,14 @@ 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
+ if "$fp_prog_ar" $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])
+ AC_MSG_ERROR([cannot figure out how to use your $fp_prog_ar])
fi
fi])
fp_prog_ar_args=$fp_cv_prog_ar_args
@@ -1354,7 +1328,7 @@ EOF
# 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])
+[FP_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
@@ -1366,7 +1340,7 @@ fi
# 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])
+[FP_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
@@ -1402,7 +1376,7 @@ AC_SUBST([HAVE_DOCBOOK_XSL])
# 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])
+[FP_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
@@ -1808,7 +1782,7 @@ AC_MSG_NOTICE(Building in-tree ghc-pwd)
dnl except we don't want to have to know what make is called. Sigh.
rm -rf utils/ghc-pwd/dist-boot
mkdir utils/ghc-pwd/dist-boot
- if ! "$WithGhc" -v0 -no-user-package-conf -hidir utils/ghc-pwd/dist-boot -odir utils/ghc-pwd/dist-boot -stubdir utils/ghc-pwd/dist-boot --make utils/ghc-pwd/Main.hs -o utils/ghc-pwd/dist-boot/ghc-pwd
+ if ! "$WithGhc" -v0 -no-user-$GHC_PACKAGE_DB_FLAG -hidir utils/ghc-pwd/dist-boot -odir utils/ghc-pwd/dist-boot -stubdir utils/ghc-pwd/dist-boot --make utils/ghc-pwd/Main.hs -o utils/ghc-pwd/dist-boot/ghc-pwd
then
AC_MSG_ERROR([Building ghc-pwd failed])
fi
View
4 bindisttest/Makefile
@@ -48,8 +48,8 @@ endif
$(BIN_DIST_INST_DIR)/bin/ghc --make HelloWorld
./HelloWorld > output
$(CONTEXT_DIFF) output expected_output
-# Without --no-user-package-conf we might pick up random packages from ~/.ghc
- $(BIN_DIST_INST_DIR)/bin/ghc-pkg check --no-user-package-conf
+# Without --no-user-package-db we might pick up random packages from ~/.ghc
+ $(BIN_DIST_INST_DIR)/bin/ghc-pkg check --no-user-package-db
clean distclean:
"$(RM)" $(RM_OPTS_REC) $(BIN_DIST_INST_SUBDIR)
View
4 bindisttest/ghc.mk
@@ -48,8 +48,8 @@ endif
$(BIN_DIST_INST_DIR)/bin/ghc --make bindisttest/HelloWorld
bindisttest/HelloWorld > bindisttest/output
$(CONTEXT_DIFF) bindisttest/output bindisttest/expected_output
-# Without --no-user-package-conf we might pick up random packages from ~/.ghc
- $(BIN_DIST_INST_DIR)/bin/ghc-pkg check --no-user-package-conf
+# Without --no-user-package-db we might pick up random packages from ~/.ghc
+ $(BIN_DIST_INST_DIR)/bin/ghc-pkg check --no-user-package-db
$(eval $(call clean-target,bindisttest,all,$(BIN_DIST_INST_DIR) $(wildcard bindisttest/a/b/c/*) bindisttest/HelloWorld bindisttest/HelloWorld.o bindisttest/HelloWorld.hi bindisttest/output))
View
13 compiler/HsVersions.h
@@ -46,18 +46,9 @@ name :: IORef (ty); \
name = Util.globalM (value);
#endif
-#ifdef DEBUG
-#define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else
-#define ASSERT2(e,msg) if (not (e)) then (assertPprPanic __FILE__ __LINE__ (msg)) else
+#define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else
+#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else
#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $
-#else
--- We have to actually use all the variables we are given or we may get
--- unused variable warnings when DEBUG is off.
-#define ASSERT(e) if False && (not (e)) then panic "ASSERT" else
-#define ASSERT2(e,msg) if False && (const False (e,msg)) then pprPanic "ASSERT2" (msg) else
-#define WARN(e,msg) if False && (e) then pprPanic "WARN" (msg) else
--- Here we deliberately don't use when as Control.Monad might not be imported
-#endif
-- Examples: Assuming flagSet :: String -> m Bool
--
View
44 compiler/basicTypes/BasicTypes.lhs
@@ -26,7 +26,7 @@ types that
module BasicTypes(
Version, bumpVersion, initialVersion,
- Arity,
+ Arity, RepArity,
Alignment,
@@ -39,8 +39,6 @@ module BasicTypes(
negateFixity, funTyFixity,
compareFixity,
- IPName(..), ipNameName, mapIPName,
-
RecFlag(..), isRec, isNonRec, boolToRecFlag,
RuleName,
@@ -101,7 +99,18 @@ import Data.Function (on)
%************************************************************************
\begin{code}
+-- | The number of value arguments that can be applied to a value before it does
+-- "real work". So:
+-- fib 100 has arity 0
+-- \x -> fib x has arity 1
type Arity = Int
+
+-- | The number of represented arguments that can be applied to a value before it does
+-- "real work". So:
+-- fib 100 has representation arity 0
+-- \x -> fib x has representation arity 1
+-- \(# x, y #) -> fib (x + y) has representation arity 2
+type RepArity = Int
\end{code}
%************************************************************************
@@ -167,32 +176,6 @@ instance Outputable WarningTxt where
%************************************************************************
%* *
-\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, Data, Typeable )
-
-instance Functor IPName where
- fmap = mapIPName
-
-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
%* *
%************************************************************************
@@ -561,9 +544,6 @@ instance Outputable OccInfo where
| otherwise = char '*'
pp_args | int_cxt = char '!'
| otherwise = empty
-
-instance Show OccInfo where
- showsPrec p occ = showsPrecSDoc p (ppr occ)
\end{code}
%************************************************************************
View
18 compiler/basicTypes/DataCon.lhs
@@ -31,7 +31,7 @@ module DataCon (
dataConInstOrigArgTys, dataConRepArgTys,
dataConFieldLabels, dataConFieldType,
dataConStrictMarks, dataConExStricts,
- dataConSourceArity, dataConRepArity,
+ dataConSourceArity, dataConRepArity, dataConRepRepArity,
dataConIsInfix,
dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
dataConRepStrictness,
@@ -470,9 +470,6 @@ instance NamedThing DataCon where
instance Outputable DataCon where
ppr con = ppr (dataConName con)
-instance Show DataCon where
- showsPrec p con = showsPrecSDoc p (ppr con)
-
instance Data.Data DataCon where
-- don't traverse?
toConstr _ = abstractConstr "DataCon"
@@ -692,9 +689,14 @@ 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 :: DataCon -> Arity
dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys
+-- | The number of fields in the /representation/ of the constructor
+-- AFTER taking into account the unpacking of any unboxed tuple fields
+dataConRepRepArity :: DataCon -> RepArity
+dataConRepRepArity dc = typeRepArity (dataConRepArity dc) (dataConRepType dc)
+
-- | Return whether there are any argument types for this 'DataCon's original source type
isNullarySrcDataCon :: DataCon -> Bool
isNullarySrcDataCon dc = null (dcOrigArgTys dc)
@@ -989,7 +991,7 @@ buildPromotedTyCon tc
buildPromotedDataCon :: DataCon -> TyCon
buildPromotedDataCon dc
= ASSERT ( isPromotableType ty )
- mkPromotedDataTyCon dc (getName dc) (getUnique dc) kind arity
+ mkPromotedDataCon dc (getName dc) (getUnique dc) kind arity
where
ty = dataConUserType dc
kind = promoteType ty
@@ -1029,7 +1031,9 @@ isPromotableType ty
-- If tc's kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ]
isPromotableTyCon :: TyCon -> Maybe Int
isPromotableTyCon tc
- | all isLiftedTypeKind (res:args) = Just $ length args
+ | isDataTyCon tc -- Only *data* types can be promoted, not newtypes
+ -- not synonyms, not type families
+ , all isLiftedTypeKind (res:args) = Just $ length args
| otherwise = Nothing
where
(args, res) = splitKindFunTys (tyConKind tc)
View
3  compiler/basicTypes/Demand.lhs
@@ -305,9 +305,6 @@ newtype StrictSig = StrictSig DmdType
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
View
21 compiler/basicTypes/Id.lhs
@@ -41,8 +41,8 @@ module Id (
mkWorkerId, mkWiredInIdName,
-- ** Taking an Id apart
- idName, idType, idUnique, idInfo, idDetails,
- idPrimRep, recordSelectorFieldLabel,
+ idName, idType, idUnique, idInfo, idDetails, idRepArity,
+ recordSelectorFieldLabel,
-- ** Modifying an Id
setIdName, setIdUnique, Id.setIdType,
@@ -65,7 +65,7 @@ module Id (
hasNoBinding,
-- ** Evidence variables
- DictId, isDictId, isEvVar,
+ DictId, isDictId, dfunNSilent, isEvVar,
-- ** Inline pragma stuff
idInlinePragma, setInlinePragma, modifyInlinePragma,
@@ -118,7 +118,7 @@ import Demand
import Name
import Module
import Class
-import PrimOp
+import {-# SOURCE #-} PrimOp (PrimOp)
import ForeignCall
import Maybes
import SrcLoc
@@ -126,7 +126,7 @@ import Outputable
import Unique
import UniqSupply
import FastString
-import Util( count )
+import Util
import StaticFlags
-- infixl so you can say (id `set` a `set` b)
@@ -158,9 +158,6 @@ idUnique = Var.varUnique
idType :: Id -> Kind
idType = Var.varType
-idPrimRep :: Id -> PrimRep
-idPrimRep id = typePrimRep (idType id)
-
setIdName :: Id -> Name -> Id
setIdName = Var.setVarName
@@ -345,6 +342,11 @@ isDFunId id = case Var.idDetails id of
DFunId {} -> True
_ -> False
+dfunNSilent :: Id -> Int
+dfunNSilent id = case Var.idDetails id of
+ DFunId ns _ -> ns
+ _ -> pprPanic "dfunSilent: not a dfun:" (ppr id)
+
isPrimOpId_maybe id = case Var.idDetails id of
PrimOpId op -> Just op
_ -> Nothing
@@ -462,6 +464,9 @@ idArity id = arityInfo (idInfo id)
setIdArity :: Id -> Arity -> Id
setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
+idRepArity :: Id -> RepArity
+idRepArity x = typeRepArity (idArity x) (idType x)
+
-- | Returns true if an application to n args would diverge
isBottomingId :: Id -> Bool
isBottomingId id = isBottomingSig (idStrictness id)
View
17 compiler/basicTypes/IdInfo.lhs
@@ -73,7 +73,7 @@ module IdInfo (
import CoreSyn
import Class
-import PrimOp
+import {-# SOURCE #-} PrimOp (PrimOp)
import Name
import VarSet
import BasicTypes
@@ -131,7 +131,14 @@ data IdDetails
| PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator
| FCallId ForeignCall -- ^ The 'Id' is for a foreign call
- | DFunId Bool -- ^ A dictionary function.
+ | DFunId Int Bool -- ^ A dictionary function.
+ -- Int = the number of "silent" arguments to the dfun
+ -- e.g. class D a => C a where ...
+ -- instance C a => C [a]
+ -- has is_silent = 1, because the dfun
+ -- has type dfun :: (D a, C a) => C [a]
+ -- See the DFun Superclass Invariant in TcInstDcls
+ --
-- Bool = True <=> the class has only one method, so may be
-- implemented with a newtype, so it might be bad
-- to be strict on this dictionary
@@ -152,7 +159,8 @@ pprIdDetails other = brackets (pp other)
pp (ClassOpId {}) = ptext (sLit "ClassOp")
pp (PrimOpId _) = ptext (sLit "PrimOp")
pp (FCallId _) = ptext (sLit "ForeignCall")
- pp (DFunId nt) = ptext (sLit "DFunId")
+ pp (DFunId ns nt) = ptext (sLit "DFunId")
+ <> ppWhen (ns /= 0) (brackets (int ns))
<> ppWhen nt (ptext (sLit "(nt)"))
pp (RecSelId { sel_naughty = is_naughty })
= brackets $ ptext (sLit "RecSel")
@@ -490,9 +498,6 @@ pprLBVarInfo IsOneShotLambda = ptext (sLit "OneShot")
instance Outputable LBVarInfo where
ppr = pprLBVarInfo
-
-instance Show LBVarInfo where
- showsPrec p c = showsPrecSDoc p (ppr c)
\end{code}
View
65 compiler/basicTypes/Literal.lhs
@@ -7,13 +7,6 @@
\begin{code}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
module Literal
(
-- * Main data type
@@ -52,9 +45,7 @@ module Literal
import TysPrim
import PrelNames
import Type
-import TypeRep
import TyCon
-import Var
import Outputable
import FastTypes
import FastString
@@ -62,6 +53,8 @@ import BasicTypes
import Binary
import Constants
import UniqFM
+import Util
+
import Data.Int
import Data.Ratio
import Data.Word
@@ -91,7 +84,7 @@ data Literal
-- First the primitive guys
MachChar Char -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar'
- | MachStr FastString -- ^ A string-literal: stored and emitted
+ | MachStr FastBytes -- ^ 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'
@@ -120,32 +113,27 @@ data Literal
-- @stdcall@ labels. @Just x@ => @\<x\>@ will
-- be appended to label name when emitting assembly.
- | LitInteger Integer Id -- ^ Integer literals
- -- See Note [Integer literals]
+ | LitInteger Integer Type -- ^ Integer literals
+ -- See Note [Integer literals]
deriving (Data, Typeable)
\end{code}
Note [Integer literals]
~~~~~~~~~~~~~~~~~~~~~~~
An Integer literal is represented using, well, an Integer, to make it
-easier to write RULEs for them.
-
- * The Id is for mkInteger, which we use when finally creating the core.
+easier to write RULEs for them. They also contain the Integer type, so
+that e.g. literalType can return the right Type for them.
- * They only get converted into real Core,
- mkInteger [c1, c2, .., cn]
- during the CorePrep phase.
+They only get converted into real Core,
+ mkInteger [c1, c2, .., cn]
+during the CorePrep phase, although TidyPgm looks ahead at what the
+core will be, so that it can see whether it involves CAFs.
- * When we initally build an Integer literal, notably when
- deserialising it from an interface file (see the Binary instance
- below), we don't have convenient access to the mkInteger Id. So we
- just use an error thunk, and fill in the real Id when we do tcIfaceLit
- in TcIface.
-
- * When looking for CAF-hood (in TidyPgm), we must take account of the
- CAF-hood of the mk_integer field in LitInteger; see TidyPgm.cafRefsL.
- Indeed this is the only reason we put the mk_integer field in the
- literal -- otherwise we could just look it up in CorePrep.
+When we initally build an Integer literal, notably when
+deserialising it from an interface file (see the Binary instance
+below), we don't have convenient access to the mkInteger Id. So we
+just use an error thunk, and fill in the real Id when we do tcIfaceLit
+in TcIface.
Binary instance
@@ -203,17 +191,14 @@ instance Binary Literal where
return (MachLabel aj mb fod)
_ -> do
i <- get bh
+ -- See Note [Integer literals]
return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger")
- -- See Note [Integer literals] in Literal
\end{code}
\begin{code}
instance Outputable Literal where
ppr lit = pprLiteral (\d -> d) 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 }
@@ -263,9 +248,10 @@ 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
+-- stored UTF-8 encoded
+mkMachString s = MachStr (fastStringToFastBytes $ mkFastString s)
-mkLitInteger :: Integer -> Id -> Literal
+mkLitInteger :: Integer -> Type -> Literal
mkLitInteger = LitInteger
inIntRange, inWordRange :: Integer -> Bool
@@ -389,12 +375,7 @@ literalType (MachWord64 _) = word64PrimTy
literalType (MachFloat _) = floatPrimTy
literalType (MachDouble _) = doublePrimTy
literalType (MachLabel _ _ _) = addrPrimTy
-literalType (LitInteger _ mk_integer_id)
- -- We really mean idType, rather than varType, but importing Id
- -- causes a module import loop
- = case varType mk_integer_id of
- FunTy _ (FunTy _ integerTy) -> integerTy
- _ -> panic "literalType: mkIntegerId has the wrong type"
+literalType (LitInteger _ t) = t
absentLiteralOf :: TyCon -> Maybe Literal
-- Return a literal of the appropriate primtive
@@ -456,7 +437,7 @@ pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc
-- to wrap parens around literals that occur in
-- a context requiring an atomic thing
pprLiteral _ (MachChar ch) = pprHsChar ch
-pprLiteral _ (MachStr s) = pprHsString s
+pprLiteral _ (MachStr s) = pprHsBytes s
pprLiteral _ (MachInt i) = pprIntVal i
pprLiteral _ (MachDouble d) = double (fromRat d)
pprLiteral _ (MachNullAddr) = ptext (sLit "__NULL")
@@ -489,7 +470,7 @@ Hash values should be zero or a positive integer. No negatives please.
\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 (MachStr s) = hashFB s
hashLiteral (MachNullAddr) = 0
hashLiteral (MachInt i) = hashInteger i
hashLiteral (MachInt64 i) = hashInteger i
View
41 compiler/basicTypes/MkId.lhs
@@ -69,9 +69,12 @@ import PrelNames
import BasicTypes hiding ( SuccessFlag(..) )
import Util
import Pair
+import DynFlags
import Outputable
import FastString
import ListSetOps
+
+import Data.Maybe ( maybeToList )
\end{code}
%************************************************************************
@@ -503,13 +506,13 @@ mkDictSelId no_unf name clas
-- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g }
dictSelRule :: Int -> Arity
- -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
+ -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
-- Tries to persuade the argument to look like a constructor
-- application, using exprIsConApp_maybe, and then selects
-- from it
-- sel_i t1..tk (D t1..tk op1 ... opm) = opi
--
-dictSelRule val_index n_ty_args id_unf args
+dictSelRule val_index n_ty_args _ id_unf args
| (dict_arg : _) <- drop n_ty_args args
, Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
= Just (con_args !! val_index)
@@ -748,7 +751,7 @@ mkPrimOpId prim_op
id = mkGlobalId (PrimOpId prim_op) name ty info
info = noCafIdInfo
- `setSpecInfo` mkSpecInfo (primOpRules prim_op name)
+ `setSpecInfo` mkSpecInfo (maybeToList $ primOpRules name prim_op)
`setArityInfo` arity
`setStrictnessInfo` Just strict_sig
@@ -761,14 +764,14 @@ mkPrimOpId prim_op
-- 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
+mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id
+mkFCallId dflags 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))
+ occ_str = showSDoc dflags (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!
@@ -825,17 +828,29 @@ mkDictFunId :: Name -- Name to use for the dict fun;
-- Implements the DFun Superclass Invariant (see TcInstDcls)
mkDictFunId dfun_name tvs theta clas tys
- = mkExportedLocalVar (DFunId is_nt)
+ = mkExportedLocalVar (DFunId n_silent is_nt)
dfun_name
dfun_ty
vanillaIdInfo
where
is_nt = isNewTyCon (classTyCon clas)
- dfun_ty = mkDictFunTy tvs theta clas tys
+ (n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys
-mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type
+mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> (Int, Type)
mkDictFunTy tvs theta clas tys
- = mkSigmaTy tvs theta (mkClassPred clas tys)
+ = (length silent_theta, dfun_ty)
+ where
+ dfun_ty = mkSigmaTy tvs (silent_theta ++ theta) (mkClassPred clas tys)
+ silent_theta
+ | null tvs, null theta
+ = []
+ | otherwise
+ = filterOut discard $
+ substTheta (zipTopTvSubst (classTyVars clas) tys)
+ (classSCTheta clas)
+ -- See Note [Silent Superclass Arguments]
+ discard pred = any (`eqPred` pred) theta
+ -- See the DFun Superclass Invariant in TcInstDcls
\end{code}
@@ -920,12 +935,12 @@ seqId = pcMiscPrelId seqName ty info
, ru_try = match_seq_of_cast
}
-match_seq_of_cast :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
+match_seq_of_cast :: Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
-- See Note [Built-in RULES for seq]
-match_seq_of_cast _ [Type _, Type res_ty, Cast scrut co, expr]
+match_seq_of_cast _ _ [Type _, Type res_ty, Cast scrut co, expr]
= Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty,
scrut, expr])
-match_seq_of_cast _ _ = Nothing
+match_seq_of_cast _ _ _ = Nothing
------------------------------------------------
lazyId :: Id -- See Note [lazyId magic]
View
3  compiler/basicTypes/MkId.lhs-boot
@@ -2,8 +2,11 @@
module MkId where
import Name( Name )
import DataCon( DataCon, DataConIds )
+import {-# SOURCE #-} PrimOp( PrimOp )
+import Id( Id )
mkDataConIds :: Name -> Name -> DataCon -> DataConIds
+mkPrimOpId :: PrimOp -> Id
\end{code}
View
4 compiler/basicTypes/Module.lhs
@@ -191,7 +191,7 @@ pprModuleName :: ModuleName -> SDoc
pprModuleName (ModuleName nm) =
getPprStyle $ \ sty ->
if codeStyle sty
- then ftext (zEncodeFS nm)
+ then ztext (zEncodeFS nm)
else ftext nm
moduleNameFS :: ModuleName -> FastString
@@ -271,7 +271,7 @@ pprPackagePrefix p mod = getPprStyle doc
| codeStyle sty =
if p == mainPackageId
then empty -- never qualify the main package in code
- else ftext (zEncodeFS (packageIdFS p)) <> char '_'
+ else ztext (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
View
2  compiler/basicTypes/Name.lhs
@@ -514,7 +514,7 @@ ppr_occ_name occ = ftext (occNameFS occ)
-- 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))
+ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ))
-- Prints (if mod information is available) "Defined at <loc>" or
-- "Defined in <mod>" information for a Name.
View
32 compiler/basicTypes/NameEnv.lhs
@@ -24,11 +24,15 @@ module NameEnv (
foldNameEnv, filterNameEnv,
plusNameEnv, plusNameEnv_C, alterNameEnv,
lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv,
- elemNameEnv, mapNameEnv
+ elemNameEnv, mapNameEnv,
+
+ -- ** Dependency analysis
+ depAnal
) where
#include "HsVersions.h"
+import Digraph
import Name
import Unique
import UniqFM
@@ -42,6 +46,32 @@ import Maybes
%************************************************************************
\begin{code}
+depAnal :: (node -> [Name]) -- Defs
+ -> (node -> [Name]) -- Uses
+ -> [node]
+ -> [SCC node]
+-- Peform dependency analysis on a group of definitions,
+-- where each definition may define more than one Name
+--
+-- The get_defs and get_uses functions are called only once per node
+depAnal get_defs get_uses nodes
+ = stronglyConnCompFromEdgedVertices (map mk_node keyed_nodes)
+ where
+ keyed_nodes = nodes `zip` [(1::Int)..]
+ mk_node (node, key) = (node, key, mapCatMaybes (lookupNameEnv key_map) (get_uses node))
+
+ key_map :: NameEnv Int -- Maps a Name to the key of the decl that defines it
+ key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node]
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Name environment}
+%* *
+%************************************************************************
+
+\begin{code}
type NameEnv a = UniqFM a -- Domain is Name
emptyNameEnv :: NameEnv a
View
7 compiler/basicTypes/OccName.lhs
@@ -63,7 +63,7 @@ module OccName (
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
mkClassDataConOcc, mkDictOcc, mkIPOcc,
mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
- mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS,
+ mkGenD, mkGenR, mkGen1R, mkGenRCo, mkGenC, mkGenS,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
mkInstTyCoOcc, mkEqPredCoOcc,
@@ -269,7 +269,7 @@ pprOccName :: OccName -> SDoc
pprOccName (OccName sp occ _)
= getPprStyle $ \ sty ->
if codeStyle sty
- then ftext (zEncodeFS occ)
+ then ztext (zEncodeFS occ)
else pp_occ <> pp_debug sty
where
pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp)
@@ -583,7 +583,7 @@ isDerivedOccName occ =
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
mkDerivedTyConOcc, mkClassDataConOcc, mkDictOcc,
mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
- mkGenD, mkGenR, mkGenRCo,
+ mkGenD, mkGenR, mkGen1R, mkGenRCo,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc
@@ -626,6 +626,7 @@ mkGenS occ m n = mk_deriv tcName ("S1_" ++ show m ++ "_" ++ show n)
(occNameString occ)
mkGenR = mk_simple_deriv tcName "Rep_"
+mkGen1R = mk_simple_deriv tcName "Rep1_"
mkGenRCo = mk_simple_deriv tcName "CoRep_"
-- data T = MkT ... deriving( Data ) needs defintions for
View
6 compiler/basicTypes/RdrName.lhs
@@ -44,9 +44,6 @@ module RdrName (
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, inLocalRdrEnvScope,
@@ -282,9 +279,6 @@ instance OutputableBndr RdrName where
pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
pprPrefixOcc rdr = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
-showRdrName :: RdrName -> String
-showRdrName r = showSDoc (ppr r)
-
instance Eq RdrName where
(Exact n1) == (Exact n2) = n1==n2
-- Convert exact to orig
View
275 compiler/basicTypes/SrcLoc.lhs
@@ -8,56 +8,49 @@
-- When the earliest compiler we want to boostrap with is
-- GHC 7.2, we can make RealSrcLoc properly abstract
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
-
-- | 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
- RealSrcLoc, -- Abstract
- SrcLoc(..),
+ -- * SrcLoc
+ RealSrcLoc, -- Abstract
+ SrcLoc(..),
-- ** Constructing SrcLoc
- mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc,
+ mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc,
- noSrcLoc, -- "I'm sorry, I haven't a clue"
- generatedSrcLoc, -- Code generated within the compiler
- interactiveSrcLoc, -- Code from an interactive session
+ 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
-
+ -- ** 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
+
-- * SrcSpan
- RealSrcSpan, -- Abstract
- SrcSpan(..),
- pprUserRealSpan, pprUserSpan,
+ RealSrcSpan, -- Abstract
+ SrcSpan(..),
-- ** Constructing SrcSpan
- mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,
- noSrcSpan,
- wiredInSrcSpan, -- Something wired into the compiler
- srcLocSpan, realSrcLocSpan,
- combineSrcSpans,
-
- -- ** Deconstructing SrcSpan
- srcSpanStart, srcSpanEnd,
- realSrcSpanStart, realSrcSpanEnd,
- srcSpanFileName_maybe,
-
- -- ** Deconstructing RealSrcSpan
- srcSpanFile,
- srcSpanStartLine, srcSpanEndLine,
+ mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,
+ noSrcSpan,
+ wiredInSrcSpan, -- Something wired into the compiler
+ srcLocSpan, realSrcLocSpan,
+ combineSrcSpans,
+
+ -- ** Deconstructing SrcSpan
+ srcSpanStart, srcSpanEnd,
+ realSrcSpanStart, realSrcSpanEnd,
+ srcSpanFileName_maybe,
+ showUserSpan, showUserRealSpan,
+
+ -- ** Unsafely deconstructing SrcSpan
+ -- These are dubious exports, because they crash on some inputs
+ srcSpanFile,
+ srcSpanStartLine, srcSpanEndLine,
srcSpanStartCol, srcSpanEndCol,
-- ** Predicates on SrcSpan
@@ -65,21 +58,21 @@ module SrcLoc (
containsSpan,
-- * Located
- Located,
- RealLocated,
- GenLocated(..),
-
- -- ** Constructing Located
- noLoc,
+ Located,
+ RealLocated,
+ GenLocated(..),
+
+ -- ** Constructing Located
+ noLoc,
mkGeneralLocated,
-
- -- ** Deconstructing Located
- getLoc, unLoc,
-
- -- ** Combining and comparing Located values
- eqLocated, cmpLocated, combineLocs, addCLoc,
- leftmost_smallest, leftmost_largest, rightmost,
- spans, isSubspanOf
+
+ -- ** Deconstructing Located
+ getLoc, unLoc,
+
+ -- ** Combining and comparing Located values
+ eqLocated, cmpLocated, combineLocs, addCLoc,
+ leftmost_smallest, leftmost_largest, rightmost,
+ spans, isSubspanOf, sortLocated
) where
#include "Typeable.h"
@@ -90,12 +83,15 @@ import FastString
import Data.Bits
import Data.Data
+import Data.List
+import Data.Ord
+import System.FilePath
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[SrcLoc-SrcLocations]{Source-location information}
-%* *
+%* *
%************************************************************************
We keep information about the {\em definition} point for each entity;
@@ -103,20 +99,20 @@ this is the obvious stuff:
\begin{code}
-- | Represents a single point within a file
data RealSrcLoc
- = SrcLoc FastString -- A precise location (file name)
- {-# UNPACK #-} !Int -- line number, begins at 1
- {-# UNPACK #-} !Int -- column number, begins at 1
+ = SrcLoc FastString -- A precise location (file name)
+ {-# UNPACK #-} !Int -- line number, begins at 1
+ {-# UNPACK #-} !Int -- column number, begins at 1
deriving Show
data SrcLoc
= RealSrcLoc {-# UNPACK #-}!RealSrcLoc
- | UnhelpfulLoc FastString -- Just a general indication
+ | UnhelpfulLoc FastString -- Just a general indication
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[SrcLoc-access-fns]{Access functions}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -128,13 +124,13 @@ mkRealSrcLoc x line col = SrcLoc x line col
-- | Built-in "bad" 'SrcLoc' values for particular locations
noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc
-noSrcLoc = UnhelpfulLoc (fsLit "<no location info>")
+noSrcLoc = UnhelpfulLoc (fsLit "<no location info>")
generatedSrcLoc = UnhelpfulLoc (fsLit "<compiler-generated code>")
interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive session>")
-- | Creates a "bad" 'SrcLoc' that has no detailed information about its location
mkGeneralSrcLoc :: FastString -> SrcLoc
-mkGeneralSrcLoc = UnhelpfulLoc
+mkGeneralSrcLoc = UnhelpfulLoc
-- | Gives the filename of the 'RealSrcLoc'
srcLocFile :: RealSrcLoc -> FastString
@@ -159,9 +155,9 @@ advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1)
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[SrcLoc-instances]{Instance declarations for various names}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -182,6 +178,9 @@ instance Ord SrcLoc where
instance Ord RealSrcLoc where
compare = cmpRealSrcLoc
+sortLocated :: [Located a] -> [Located a]
+sortLocated things = sortBy (comparing getLoc) things
+
cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering
cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2
cmpSrcLoc (UnhelpfulLoc _) (RealSrcLoc _) = GT
@@ -196,7 +195,7 @@ instance Outputable RealSrcLoc where
ppr (SrcLoc src_path src_line src_col)
= getPprStyle $ \ sty ->
if userStyle sty || debugStyle sty then
- hcat [ pprFastFilePath src_path, char ':',
+ hcat [ pprFastFilePath src_path, char ':',
int src_line,
char ':', int src_col
]
@@ -222,9 +221,9 @@ instance Data SrcSpan where
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[SrcSpan]{Source Spans}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -239,33 +238,33 @@ 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 RealSrcSpan
- = SrcSpanOneLine -- a common case: a single line
- { srcSpanFile :: !FastString,
- srcSpanLine :: {-# UNPACK #-} !Int,
- srcSpanSCol :: {-# UNPACK #-} !Int,
- srcSpanECol :: {-# UNPACK #-} !Int
- }
+ = 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
- }
+ { srcSpanFile :: !FastString,
+ srcSpanSLine :: {-# UNPACK #-} !Int,
+ srcSpanSCol :: {-# UNPACK #-} !Int,
+ srcSpanELine :: {-# UNPACK #-} !Int,
+ srcSpanECol :: {-# UNPACK #-} !Int
+ }
| SrcSpanPoint
- { srcSpanFile :: !FastString,
- srcSpanLine :: {-# UNPACK #-} !Int,
- srcSpanCol :: {-# UNPACK #-} !Int
- }
+ { srcSpanFile :: !FastString,
+ srcSpanLine :: {-# UNPACK #-} !Int,
+ srcSpanCol :: {-# UNPACK #-} !Int
+ }
deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, becuase we
-- derive Show for Token
data SrcSpan =
RealSrcSpan !RealSrcSpan
- | UnhelpfulSpan !FastString -- Just a general indication
- -- also used to indicate an empty span
+ | UnhelpfulSpan !FastString -- Just a general indication
+ -- also used to indicate an empty span
deriving (Eq, Ord, Typeable, Show) -- Show is used by Lexer.x, becuase we
-- derive Show for Token
@@ -291,15 +290,15 @@ realSrcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col
mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan loc1 loc2
| line1 == line2 = if col1 == col2
- then SrcSpanPoint file line1 col1
- else SrcSpanOneLine file line1 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
+ line1 = srcLocLine loc1
+ line2 = srcLocLine loc2
+ col1 = srcLocCol loc1
+ col2 = srcLocCol loc2
+ file = srcLocFile loc1
-- | Create a 'SrcSpan' between two points in a file
mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
@@ -310,33 +309,33 @@ mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2)
-- | Combines two 'SrcSpan' into one that spans at least all the characters
-- within both spans. Assumes the "file" part is the same in both inputs
-combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
-combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful
-combineSrcSpans l (UnhelpfulSpan _) = l
-combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)
+combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
+combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful
+combineSrcSpans l (UnhelpfulSpan _) = l
+combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)
= RealSrcSpan (combineRealSrcSpans span1 span2)
-- | Combines two 'SrcSpan' into one that spans at least all the characters
-- within both spans. Assumes the "file" part is the same in both inputs
combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan
combineRealSrcSpans span1 span2
- = if line_start == line_end
+ = if line_start == line_end
then if col_start == col_end
then SrcSpanPoint file line_start col_start
else SrcSpanOneLine file line_start col_start col_end
else SrcSpanMultiLine file line_start col_start line_end col_end
where
(line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1)
- (srcSpanStartLine span2, srcSpanStartCol span2)
+ (srcSpanStartLine span2, srcSpanStartCol span2)
(line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1)
- (srcSpanEndLine span2, srcSpanEndCol span2)
+ (srcSpanEndLine span2, srcSpanEndCol span2)
file = srcSpanFile span1
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[SrcSpan-predicates]{Predicates}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -365,9 +364,9 @@ containsSpan s1 s2
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -396,9 +395,9 @@ srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[SrcSpan-access-fns]{Access functions}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -431,9 +430,9 @@ srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[SrcSpan-instances]{Instances}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -448,7 +447,7 @@ instance Outputable RealSrcSpan where
ppr span
= getPprStyle $ \ sty ->
if userStyle sty || debugStyle sty then
- pprUserRealSpan True span
+ text (showUserRealSpan True span)
else
hcat [text "{-# LINE ", int (srcSpanStartLine span), space,
char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"]
@@ -465,36 +464,36 @@ instance Outputable SrcSpan where
pprUserSpan :: Bool -> SrcSpan -> SDoc
pprUserSpan _ (UnhelpfulSpan s) = ftext s
-pprUserSpan show_path (RealSrcSpan s) = pprUserRealSpan show_path s
-
-pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc
-pprUserRealSpan show_path (SrcSpanOneLine src_path line start_col end_col)
- = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
- , int line, char ':', int start_col
- , ppUnless (end_col - start_col <= 1)
- (char '-' <> int (end_col-1))
- -- For single-character or point spans, we just
- -- output the starting column number
- ]
-
-
-pprUserRealSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol)
- = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
- , parens (int sline <> char ',' <> int scol)
- , char '-'
- , parens (int eline <> char ',' <>
- if ecol == 0 then int ecol else int (ecol-1))
- ]
-
-pprUserRealSpan show_path (SrcSpanPoint src_path line col)
- = hcat [ ppWhen show_path $ (pprFastFilePath src_path <> colon)
- , int line, char ':', int col ]
+pprUserSpan show_path (RealSrcSpan s) = text (showUserRealSpan show_path s)
+
+showUserSpan :: Bool -> SrcSpan -> String
+showUserSpan _ (UnhelpfulSpan s) = unpackFS s
+showUserSpan show_path (RealSrcSpan s) = showUserRealSpan show_path s
+
+showUserRealSpan :: Bool -> RealSrcSpan -> String
+showUserRealSpan show_path (SrcSpanOneLine src_path line start_col end_col)
+ = (if show_path then normalise (unpackFS src_path) ++ ":" else "")
+ ++ show line ++ ":" ++ show start_col
+ ++ (if end_col - start_col <= 1 then "" else '-' : show (end_col - 1))
+ -- For single-character or point spans, we just
+ -- output the starting column number
+
+showUserRealSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol)
+ = (if show_path then normalise (unpackFS src_path) ++ ":" else "")
+ ++ "(" ++ show sline ++ "," ++ show scol ++ ")"
+ ++ "-"
+ ++ "(" ++ show eline ++ "," ++ show ecol' ++ ")"
+ where ecol' = if ecol == 0 then ecol else ecol - 1
+
+showUserRealSpan show_path (SrcSpanPoint src_path line col)
+ = (if show_path then normalise (unpackFS src_path) ++ ":" else "")
+ ++ show line ++ ":" ++ show col
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[Located]{Attaching SrcSpans to things}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -549,16 +548,16 @@ instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
\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_smallest = compare
leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b)
`thenCmp`
(srcSpanEnd b `compare` srcSpanEnd a)
@@ -573,7 +572,7 @@ spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcS
isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other
-> SrcSpan -- ^ The span it may be enclosed by
-> Bool
-isSubspanOf src parent
+isSubspanOf src parent
| srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False
| otherwise = srcSpanStart parent <= srcSpanStart src &&
srcSpanEnd parent >= srcSpanEnd src
View
44 compiler/basicTypes/UniqSupply.lhs
@@ -23,7 +23,7 @@ module UniqSupply (
lazyThenUs, lazyMapUs,
-- ** Deprecated operations on 'UniqSM'
- getUniqueUs, getUs, returnUs, thenUs, mapUs
+ getUniqueUs, getUs,
) where
import Unique
@@ -109,7 +109,7 @@ takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily (iBox n), s1)
\begin{code}
-- | A monad which just gives the ability to obtain 'Unique's
-newtype UniqSM result = USM { unUSM :: UniqSupply -> (result, UniqSupply) }
+newtype UniqSM result = USM { unUSM :: UniqSupply -> (# result, UniqSupply #) }
instance Monad UniqSM where
return = returnUs
@@ -118,21 +118,21 @@ instance Monad UniqSM where
instance Functor UniqSM where
fmap f (USM x) = USM (\us -> case x us of
- (r, us') -> (f r, us'))
+ (# 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'')
+ (# 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) }
+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 }
+initUs_ init_us m = case unUSM m init_us of { (# r, _ #) -> r }
{-# INLINE thenUs #-}
{-# INLINE lazyThenUs #-}
@@ -142,27 +142,30 @@ initUs_ init_us m = case unUSM m init_us of { (r, _) -> r }
@thenUs@ is where we split the @UniqSupply@.
\begin{code}
+liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply)
+liftUSM (USM m) us = case m us of (# a, us' #) -> (a, us')
+
instance MonadFix UniqSM where
- mfix m = USM (\us -> let (r,us') = unUSM (m r) us in (r,us'))
+ mfix m = USM (\us -> let (r,us') = liftUSM (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')
+ (# 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')
+lazyThenUs expr cont
+ = USM (\us -> let (result, us') = liftUSM 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' })
+ = USM (\us -> case (expr us) of { (# _, us' #) -> cont us' })
returnUs :: a -> UniqSM a
-returnUs result = USM (\us -> (result, us))
+returnUs result = USM (\us -> (# result, us #))
getUs :: UniqSM UniqSupply
-getUs = USM (\us -> splitUniqSupply us)
+getUs = USM (\us -> case splitUniqSupply us of (us1,us2) -> (# us1, us2 #))
-- | A monad for generating unique identifiers
class Monad m => MonadUnique m where
@@ -177,24 +180,17 @@ class Monad m => MonadUnique m where
getUniquesM = liftM uniqsFromSupply getUniqueSupplyM
instance MonadUnique UniqSM where
- getUniqueSupplyM = USM (\us -> splitUniqSupply us)
+ getUniqueSupplyM = getUs
getUniqueM = getUniqueUs
getUniquesM = getUniquesUs
getUniqueUs :: UniqSM Unique
getUniqueUs = USM (\us -> case splitUniqSupply us of
- (us1,us2) -> (uniqFromSupply us1, us2))
+ (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)
+ (us1,us2) -> (# uniqsFromSupply us1, us2 #))
\end{code}
\begin{code}
View
206 compiler/basicTypes/Unique.lhs
@@ -18,50 +18,43 @@ Haskell).
\begin{code}
{-# LANGUAGE BangPatterns #-}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
module Unique (
-- * Main data types
- Unique, Uniquable(..),
-
- -- ** Constructors, desctructors and operations on 'Unique's
- hasKey,
+ Unique, Uniquable(..),
+
+ -- ** Constructors, desctructors and operations on 'Unique's
+ hasKey,
- pprUnique,
+ pprUnique,
- mkUniqueGrimily, -- Used in UniqSupply only!
- getKey, getKeyFastInt, -- Used in Var, UniqFM, Name only!
+ mkUniqueGrimily, -- Used in UniqSupply only!
+ getKey, getKeyFastInt, -- Used in Var, UniqFM, Name only!
mkUnique, unpkUnique, -- Used in BinIface only
- incrUnique, -- Used for renumbering
- deriveUnique, -- Ditto
- newTagUnique, -- Used in CgCase
- initTyVarUnique,
+ incrUnique, -- Used for renumbering
+ deriveUnique, -- Ditto
+ newTagUnique, -- Used in CgCase
+ initTyVarUnique,
- -- ** Making built-in uniques
+ -- ** 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,
+ -- 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,
mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,
mkCostCentreUnique,
- mkBuiltinUnique,
+ mkBuiltinUnique,
mkPseudoUniqueD,
- mkPseudoUniqueE,
- mkPseudoUniqueH
+ mkPseudoUniqueE,
+ mkPseudoUniqueH
) where
#include "HsVersions.h"
@@ -71,6 +64,7 @@ import FastTypes
import FastString
import Outputable
-- import StaticFlags
+import Util
#if defined(__GLASGOW_HASKELL__)
--just for implementing a fast [0,61) -> Char function
@@ -78,13 +72,13 @@ import GHC.Exts (indexCharOffAddr#, Char(..))
#else
import Data.Array
#endif
-import Data.Char ( chr, ord )
+import Data.Char ( chr, ord )
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[Unique-type]{@Unique@ type and operations}
-%* *
+%* *
%************************************************************************
The @Chars@ are ``tag letters'' that identify the @UniqueSupply@.
@@ -103,15 +97,15 @@ 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}
-unpkUnique :: Unique -> (Char, Int) -- The reverse
+unpkUnique :: Unique -> (Char, Int) -- The reverse
-mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply
-getKey :: Unique -> Int -- for Var
-getKeyFastInt :: Unique -> FastInt -- for Var
+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
+incrUnique :: Unique -> Unique
+deriveUnique :: Unique -> Int -> Unique
+newTagUnique :: Unique -> Char -> Unique
\end{code}
@@ -138,8 +132,8 @@ newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u
-- and as long as the Char fits in 8 bits, which we assume anyway!
-mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces
--- NOT EXPORTED, so that we can see all the Chars that
+mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces
+-- NOT EXPORTED, so that we can see all the Chars that
-- are used in this one module
mkUnique c i
= MkUnique (tag `bitOrFastInt` bits)
@@ -149,10 +143,10 @@ mkUnique c i
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''-})
+ -- 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}
@@ -160,9 +154,9 @@ unpkUnique (MkUnique u)
%************************************************************************
-%* *
+%* *
\subsection[Uniquable-class]{The @Uniquable@ class}
-%* *
+%* *
%************************************************************************
\begin{code}
@@ -170,24 +164,21 @@ unpkUnique (MkUnique u)
class Uniquable a where
getUnique :: a -> Unique
-hasKey :: Uniquable a => a -> Unique -> Bool
-x `hasKey` k = getUnique x == k
+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
-
-instance Uniquable n => Uniquable (IPName n) where
- getUnique (IPName n) = getUnique n
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[Unique-instances]{Instance declarations for @Unique@}
-%* *
+%* *
%************************************************************************
And the whole point (besides uniqueness) is fast equality. We don't
@@ -222,39 +213,32 @@ instance Uniquable Unique where
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
+showUnique :: Unique -> String
+showUnique uniq
= case unpkUnique uniq of
- (tag, u) -> finish_ppr tag u (text (iToBase62 u))
+ (tag, u) -> finish_show tag u (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_show :: Char -> Int -> String -> String
+finish_show 't' u _pp_u | u < 26
+ = -- Special case to make v common tyvars, t1, t2, ...
+ -- come out as a, b, ... (shorter, easier to read)
+ [chr (ord 'a' + u)]
+finish_show tag _ pp_u = tag : pp_u
-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
+pprUnique :: Unique -> SDoc
+pprUnique u = text (showUnique u)
instance Outputable Unique where
- ppr u = pprUnique u
+ ppr = pprUnique
instance Show Unique where
- showsPrec p uniq = showsPrecSDoc p (pprUnique uniq)
+ show uniq = showUnique uniq
\end{code}
%************************************************************************
-%* *
+%* *
\subsection[Utils-base62]{Base-62 numbers}
-%* *
+%* *
%************************************************************************
A character-stingy way to read/write numbers (notably Uniques).
@@ -267,12 +251,12 @@ 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 chooseChar62 n of { c -> c `seq` (c : cs) }