diff options
350 files changed, 21142 insertions, 15834 deletions
diff --git a/.gitignore b/.gitignore index 829f19a742..7fe74cd4f4 100644 --- a/.gitignore +++ b/.gitignore @@ -43,6 +43,7 @@ _darcs/ # sub-repositories /ghc-tarballs/ +/libffi-tarballs/ /libraries/array/ /libraries/base/ /libraries/deepseq/ @@ -159,7 +160,6 @@ _darcs/ /mk/install.mk /mk/project.mk /mk/project.mk.old -/mk/stamp-h /mk/validate.mk /rts/package.conf.inplace /rts/package.conf.inplace.raw diff --git a/.gitmodules b/.gitmodules index 72303a8e97..2ad08541be 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,42 +1,42 @@ [submodule "libraries/binary"] path = libraries/binary - url = http://darcs.haskell.org/libraries/binary.git/ + url = http://git.haskell.org/packages/binary.git [submodule "libraries/bytestring"] path = libraries/bytestring - url = http://darcs.haskell.org/libraries/bytestring.git/ + url = http://git.haskell.org/packages/bytestring.git [submodule "libraries/Cabal"] path = libraries/Cabal - url = http://darcs.haskell.org/libraries/Cabal.git/ + url = http://git.haskell.org/packages/Cabal.git [submodule "libraries/containers"] path = libraries/containers - url = http://darcs.haskell.org/libraries/containers.git/ + url = http://git.haskell.org/packages/containers.git [submodule "libraries/haskeline"] path = libraries/haskeline - url = http://darcs.haskell.org/libraries/haskeline.git/ + url = http://git.haskell.org/packages/haskeline.git [submodule "libraries/pretty"] path = libraries/pretty - url = http://darcs.haskell.org/libraries/pretty.git/ + url = http://git.haskell.org/packages/pretty.git [submodule "libraries/terminfo"] path = libraries/terminfo - url = http://darcs.haskell.org/libraries/terminfo.git/ + url = http://git.haskell.org/packages/terminfo.git [submodule "libraries/transformers"] path = libraries/transformers - url = http://darcs.haskell.org/libraries/transformers.git/ + url = http://git.haskell.org/packages/transformers.git [submodule "libraries/xhtml"] path = libraries/xhtml - url = http://darcs.haskell.org/libraries/xhtml.git/ + url = http://git.haskell.org/packages/xhtml.git [submodule "libraries/Win32"] path = libraries/Win32 - url = http://darcs.haskell.org/libraries/Win32.git/ + url = http://git.haskell.org/packages/Win32.git [submodule "libraries/primitive"] path = libraries/primitive - url = http://darcs.haskell.org/libraries/primitive.git/ + url = http://git.haskell.org/packages/primitive.git [submodule "libraries/vector"] path = libraries/vector - url = http://darcs.haskell.org/libraries/vector.git/ + url = http://git.haskell.org/packages/vector.git [submodule "libraries/time"] path = libraries/time - url = http://darcs.haskell.org/libraries/time.git/ + url = http://git.haskell.org/packages/time.git [submodule "libraries/random"] path = libraries/random - url = http://darcs.haskell.org/libraries/random.git/ + url = http://git.haskell.org/packages/random.git diff --git a/HACKING.md b/HACKING.md index c88669761a..4fe4d2c921 100644 --- a/HACKING.md +++ b/HACKING.md @@ -132,7 +132,7 @@ lost. But if the change is small and self contained, feel free to attach it to your email, and send it to `ghc-devs`. Furthermore, if you're a developer (or want to become one!) you're -undoubtly also interested in the other mailing lists: +undoubtedly also interested in the other mailing lists: * [glasgow-haskell-users](http://www.haskell.org/mailman/listinfo/glasgow-haskell-users) is where developers/users meet. @@ -45,7 +45,7 @@ endif include mk/custom-settings.mk # No need to update makefiles for these targets: -REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show help test fulltest,$(MAKECMDGOALS)) +REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show echo help test fulltest,$(MAKECMDGOALS)) # configure touches certain files even if they haven't changed. This # can mean a lot of unnecessary recompilation after a re-configure, so @@ -80,7 +80,6 @@ endif binary-dist-prep: ifeq "$(mingw32_TARGET_OS)" "1" $(MAKE) -r --no-print-directory -f ghc.mk windows-binary-dist-prep - $(MAKE) -r --no-print-directory -f ghc.mk windows-installer else rm -f bindist-list $(MAKE) -r --no-print-directory -f ghc.mk bindist BINDIST=YES @@ -94,7 +93,7 @@ clean distclean maintainer-clean: $(filter clean_%, $(MAKECMDGOALS)) : clean_% : $(MAKE) -r --no-print-directory -f ghc.mk $@ CLEANING=YES -bootstrapping-files show: +bootstrapping-files show echo: $(MAKE) -r --no-print-directory -f ghc.mk $@ ifeq "$(darwin_TARGET_OS)" "1" @@ -1,12 +1,12 @@ The Glasgow Haskell Compiler ============================ -This is the source tree for [GHC] [1], a compiler and interactive +This is the source tree for [GHC][1], a compiler and interactive environment for the Haskell functional programming language. -For more information, visit [GHC's web site] [1]. +For more information, visit [GHC's web site][1]. -Information for developers of GHC can be found on the [GHC Trac] [2]. +Information for developers of GHC can be found on the [GHC Trac][2]. Getting the Source diff --git a/aclocal.m4 b/aclocal.m4 index 94f34b36d6..d604cc08e0 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -4,6 +4,34 @@ # ensure we don't clash with any pre-supplied autoconf ones. +AC_DEFUN([GHC_SELECT_FILE_EXTENSIONS], +[ + $2='' + $3='.so' + case $1 in + *-unknown-cygwin32) + AC_MSG_WARN([GHC does not support the Cygwin target at the moment]) + AC_MSG_WARN([I'm assuming you wanted to build for i386-unknown-mingw32]) + exit 1 + ;; + *-unknown-mingw32) + windows=YES + $2='.exe' + $3='.dll' + ;; + i386-apple-darwin|powerpc-apple-darwin) + $3='.dylib' + ;; + x86_64-apple-darwin) + $3='.dylib' + ;; + arm-apple-darwin10) + $2='.a' + $3='.dylib' + ;; + esac +]) + # FPTOOLS_SET_PLATFORM_VARS # ---------------------------------- # Set the platform variables @@ -86,25 +114,12 @@ AC_DEFUN([FPTOOLS_SET_PLATFORM_VARS], GHC_CONVERT_OS([$target_os], [$TargetArch], [TargetOS]) fi + GHC_SELECT_FILE_EXTENSIONS([$host], [exeext_host], [soext_host]) + GHC_SELECT_FILE_EXTENSIONS([$target], [exeext_target], [soext_target]) windows=NO - exeext='' - soext='.so' case $host in - *-unknown-cygwin32) - AC_MSG_WARN([GHC does not support the Cygwin target at the moment]) - AC_MSG_WARN([I'm assuming you wanted to build for i386-unknown-mingw32]) - exit 1 - ;; *-unknown-mingw32) windows=YES - exeext='.exe' - soext='.dll' - ;; - i386-apple-darwin|powerpc-apple-darwin) - soext='.dylib' - ;; - x86_64-apple-darwin) - soext='.dylib' ;; esac @@ -149,8 +164,10 @@ AC_DEFUN([FPTOOLS_SET_PLATFORM_VARS], AC_SUBST(BuildVendor_CPP) AC_SUBST(TargetVendor_CPP) - AC_SUBST(exeext) - AC_SUBST(soext) + AC_SUBST(exeext_host) + AC_SUBST(exeext_target) + AC_SUBST(soext_host) + AC_SUBST(soext_target) ]) @@ -491,6 +508,13 @@ AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS], [ AC_MSG_CHECKING([Setting up $2, $3, $4 and $5]) case $$1 in + i386-*) + # Workaround for #7799 + $2="$$2 -U__i686" + ;; + esac + + case $$1 in i386-apple-darwin) $2="$$2 -m32" $3="$$3 -m32" @@ -528,18 +552,6 @@ AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS], $2="$$2 -fno-stack-protector" fi - # Reduce memory usage when linking. See trac #5240. - if test -n "$LdHashSize31" - then - $3="$$3 -Wl,$LdHashSize31" - $4="$$4 $LdHashSize31" - fi - if test -n "$LdReduceMemoryOverheads" - then - $3="$$3 -Wl,$LdReduceMemoryOverheads" - $4="$$4 $LdReduceMemoryOverheads" - fi - rm -f conftest.c conftest.o AC_MSG_RESULT([done]) ]) @@ -686,8 +698,6 @@ AC_ARG_WITH($2, # 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 @@ -916,27 +926,6 @@ $2=$fp_cv_$2 ])# FP_PROG_LD_FLAG -# FP_PROG_LD_HashSize31 -# ------------ -# Sets the output variable LdHashSize31 to --hash-size=31 if ld supports -# this flag. Otherwise the variable's value is empty. -AC_DEFUN([FP_PROG_LD_HashSize31], -[ -FP_PROG_LD_FLAG([--hash-size=31],[LdHashSize31]) -])# FP_PROG_LD_HashSize31 - - -# FP_PROG_LD_ReduceMemoryOverheads -# ------------ -# Sets the output variable LdReduceMemoryOverheads to -# --reduce-memory-overheads if ld supports this flag. -# Otherwise the variable's value is empty. -AC_DEFUN([FP_PROG_LD_ReduceMemoryOverheads], -[ -FP_PROG_LD_FLAG([--reduce-memory-overheads],[LdReduceMemoryOverheads]) -])# FP_PROG_LD_ReduceMemoryOverheads - - # FP_PROG_LD_BUILD_ID # ------------ @@ -1124,30 +1113,42 @@ AC_SUBST([ArArgs], ["$fp_prog_ar_args"]) # FP_PROG_AR_NEEDS_RANLIB # ----------------------- -# Sets the output variable RANLIB to "ranlib" if it is needed and found, -# to "true" 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="true" - AC_SUBST([RANLIB]) -fi +# Sets the output variable RANLIB_CMD to "ranlib" if it is needed and +# found, to "true" otherwise. Sets REAL_RANLIB_CMD to the ranlib program, +# even if we don't need ranlib (libffi might still need it). +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_PROG_RANLIB + + if test $fp_prog_ar_is_gnu = yes + then + fp_cv_prog_ar_needs_ranlib=no + elif test "$TargetOS_CPP" = "darwin" + 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 + else + case $fp_prog_ar_args in + *s*) + fp_cv_prog_ar_needs_ranlib=no;; + *) + fp_cv_prog_ar_needs_ranlib=yes;; + esac + fi + + REAL_RANLIB_CMD="$RANLIB" + if test $fp_cv_prog_ar_needs_ranlib = yes + then + RANLIB_CMD="$RANLIB" + else + RANLIB_CMD="true" + fi + AC_SUBST([REAL_RANLIB_CMD]) + AC_SUBST([RANLIB_CMD]) ])# FP_PROG_AR_NEEDS_RANLIB @@ -1546,6 +1547,15 @@ if test "$RELEASE" = "NO"; then AC_MSG_RESULT(given $PACKAGE_VERSION) else AC_MSG_WARN([cannot determine snapshot version: no .git directory and no VERSION file]) + dnl We'd really rather this case didn't happen, but it might + dnl do (in particular, people using lndir trees may find that + dnl the build system can't find any other date). If it does + dnl happen, then we use the current date. + dnl This way we get some idea about how recent a build is. + dnl It also means that packages built for 2 different builds + dnl will probably use different version numbers, so things are + dnl less likely to go wrong. + PACKAGE_VERSION=${PACKAGE_VERSION}.`date +%Y%m%d` fi fi @@ -2008,7 +2018,7 @@ AC_DEFUN([FIND_LLVM_PROG],[ for p in ${PATH}; do if test -d "${p}"; then $1=`${FindCmd} "${p}" -type f -perm +111 -maxdepth 1 -regex '.*/$3-[[0-9]]\.[[0-9]]' -or -type l -perm +111 -maxdepth 1 -regex '.*/$3-[[0-9]]\.[[0-9]]' | ${SortCmd} -n | tail -1` - if test -n "$1"; then + if test -n "$$1"; then break fi fi diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs index 758a10412b..e22527c57a 100644 --- a/compiler/basicTypes/Avail.hs +++ b/compiler/basicTypes/Avail.hs @@ -2,13 +2,6 @@ -- (c) The University of Glasgow -- -{-# 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 Avail ( Avails, AvailInfo(..), @@ -25,6 +18,7 @@ import NameEnv import NameSet import RdrName +import Binary import Outputable import Util @@ -32,24 +26,24 @@ import Util -- The AvailInfo type -- | Records what things are "available", i.e. in scope -data AvailInfo = Avail Name -- ^ An ordinary identifier in scope - | AvailTC Name - [Name] -- ^ A type or class in scope. Parameters: - -- - -- 1) The name of the type or class - -- 2) The available pieces of type or class. - -- - -- The AvailTC Invariant: +data AvailInfo = Avail Name -- ^ An ordinary identifier in scope + | AvailTC Name + [Name] -- ^ A type or class in scope. Parameters: + -- + -- 1) The name of the type or class + -- 2) The available pieces of type or class. + -- + -- The AvailTC Invariant: -- * If the type or class is itself - -- to be in scope, it must be - -- *first* in this list. Thus, + -- to be in scope, it must be + -- *first* in this list. Thus, -- typically: @AvailTC Eq [Eq, ==, \/=]@ - deriving( Eq ) + deriving( Eq ) -- Equality used when deciding if the -- interface has changed -- | A collection of 'AvailInfo' - several things that are \"available\" -type Avails = [AvailInfo] +type Avails = [AvailInfo] -- | Compare lexicographically stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering @@ -111,4 +105,20 @@ pprAvail :: AvailInfo -> SDoc pprAvail (Avail n) = ppr n pprAvail (AvailTC n ns) = ppr n <> braces (hsep (punctuate comma (map ppr ns))) +instance Binary AvailInfo where + put_ bh (Avail aa) = do + putByte bh 0 + put_ bh aa + put_ bh (AvailTC ab ac) = do + putByte bh 1 + put_ bh ab + put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (Avail aa) + _ -> do ab <- get bh + ac <- get bh + return (AvailTC ab ac) diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index a4fb5590a2..838e368ea6 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -16,73 +16,66 @@ types that \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 BasicTypes( - Version, bumpVersion, initialVersion, + Version, bumpVersion, initialVersion, ConTag, fIRST_TAG, - Arity, RepArity, - - Alignment, + Arity, RepArity, + + Alignment, FunctionOrData(..), - - WarningTxt(..), - Fixity(..), FixityDirection(..), - defaultFixity, maxPrecedence, - negateFixity, funTyFixity, - compareFixity, + WarningTxt(..), + + Fixity(..), FixityDirection(..), + defaultFixity, maxPrecedence, minPrecedence, + negateFixity, funTyFixity, + compareFixity, - RecFlag(..), isRec, isNonRec, boolToRecFlag, + RecFlag(..), isRec, isNonRec, boolToRecFlag, - RuleName, + RuleName, - TopLevelFlag(..), isTopLevel, isNotTopLevel, + TopLevelFlag(..), isTopLevel, isNotTopLevel, - OverlapFlag(..), + OverlapFlag(..), - Boxity(..), isBoxed, + Boxity(..), isBoxed, TupleSort(..), tupleSortBoxity, boxityNormalTupleSort, tupleParens, - OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc, - isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isNoOcc, - strongLoopBreaker, weakLoopBreaker, + OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc, + isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isNoOcc, + strongLoopBreaker, weakLoopBreaker, - InsideLam, insideLam, notInsideLam, - OneBranch, oneBranch, notOneBranch, - InterestingCxt, + InsideLam, insideLam, notInsideLam, + OneBranch, oneBranch, notOneBranch, + InterestingCxt, EP(..), - DefMethSpec(..), + DefMethSpec(..), SwapFlag(..), flipSwap, unSwap, CompilerPhase(..), PhaseNum, Activation(..), isActive, isActiveIn, isNeverActive, isAlwaysActive, isEarlyActive, - RuleMatchInfo(..), isConLike, isFunLike, + RuleMatchInfo(..), isConLike, isFunLike, InlineSpec(..), isEmptyInlineSpec, - InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, - neverInlinePragma, dfunInlinePragma, - isDefaultInlinePragma, + InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, + neverInlinePragma, dfunInlinePragma, + isDefaultInlinePragma, isInlinePragma, isInlinablePragma, isAnyInlinePragma, inlinePragmaSpec, inlinePragmaSat, inlinePragmaActivation, inlinePragmaRuleMatchInfo, setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, - SuccessFlag(..), succeeded, failed, successIf, - - FractionalLit(..), negateFractionalLit, integralFractionalLit + SuccessFlag(..), succeeded, failed, successIf, + + FractionalLit(..), negateFractionalLit, integralFractionalLit ) where import FastString @@ -93,9 +86,9 @@ import Data.Function (on) \end{code} %************************************************************************ -%* * +%* * \subsection[Arity]{Arity} -%* * +%* * %************************************************************************ \begin{code} @@ -114,9 +107,9 @@ type RepArity = Int \end{code} %************************************************************************ -%* * +%* * Constructor tags -%* * +%* * %************************************************************************ \begin{code} @@ -129,9 +122,9 @@ fIRST_TAG = 1 \end{code} %************************************************************************ -%* * +%* * \subsection[Alignment]{Alignment} -%* * +%* * %************************************************************************ \begin{code} @@ -139,14 +132,14 @@ type Alignment = Int -- align to next N-byte boundary (N must be a power of 2). \end{code} %************************************************************************ -%* * +%* * Swap flag -%* * +%* * %************************************************************************ \begin{code} -data SwapFlag - = NotSwapped -- Args are: actual, expected +data SwapFlag + = NotSwapped -- Args are: actual, expected | IsSwapped -- Args are: expected, actual instance Outputable SwapFlag where @@ -164,9 +157,9 @@ unSwap IsSwapped f a b = f b a %************************************************************************ -%* * +%* * \subsection[FunctionOrData]{FunctionOrData} -%* * +%* * %************************************************************************ \begin{code} @@ -180,15 +173,15 @@ instance Outputable FunctionOrData where %************************************************************************ -%* * +%* * \subsection[Version]{Module and identifier version numbers} -%* * +%* * %************************************************************************ \begin{code} type Version = Int -bumpVersion :: Version -> Version +bumpVersion :: Version -> Version bumpVersion v = v+1 initialVersion :: Version @@ -196,9 +189,9 @@ initialVersion = 1 \end{code} %************************************************************************ -%* * - Deprecations -%* * +%* * + Deprecations +%* * %************************************************************************ @@ -215,9 +208,9 @@ instance Outputable WarningTxt where \end{code} %************************************************************************ -%* * - Rules -%* * +%* * + Rules +%* * %************************************************************************ \begin{code} @@ -225,9 +218,9 @@ type RuleName = FastString \end{code} %************************************************************************ -%* * +%* * \subsection[Fixity]{Fixity info} -%* * +%* * %************************************************************************ \begin{code} @@ -238,12 +231,12 @@ 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 +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, Data, Typeable) +data FixityDirection = InfixL | InfixR | InfixN + deriving (Eq, Data, Typeable) instance Outputable FixityDirection where ppr InfixL = ptext (sLit "infixl") @@ -251,48 +244,50 @@ instance Outputable FixityDirection where ppr InfixN = ptext (sLit "infix") ------------------------ -maxPrecedence :: Int +maxPrecedence, minPrecedence :: Int maxPrecedence = 9 +minPrecedence = 0 + 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 '->' +negateFixity = Fixity 6 InfixL -- Fixity of unary negate +funTyFixity = Fixity 0 InfixR -- Fixity of '->' \end{code} Consider \begin{verbatim} - a `op1` b `op2` c + 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) + -> (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 + GT -> left + LT -> right + EQ -> case (dir1, dir2) of + (InfixR, InfixR) -> right + (InfixL, InfixL) -> left + _ -> error_please where - right = (False, True) + right = (False, True) left = (False, False) error_please = (True, False) \end{code} %************************************************************************ -%* * +%* * \subsection[Top-level/local]{Top-level/not-top level flag} -%* * +%* * %************************************************************************ \begin{code} @@ -305,7 +300,7 @@ isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool isNotTopLevel NotTopLevel = True isNotTopLevel TopLevel = False -isTopLevel TopLevel = True +isTopLevel TopLevel = True isTopLevel NotTopLevel = False instance Outputable TopLevelFlag where @@ -315,9 +310,9 @@ instance Outputable TopLevelFlag where %************************************************************************ -%* * - Boxity flag -%* * +%* * + Boxity flag +%* * %************************************************************************ \begin{code} @@ -333,15 +328,15 @@ isBoxed Unboxed = False %************************************************************************ -%* * - Recursive/Non-Recursive flag -%* * +%* * + Recursive/Non-Recursive flag +%* * %************************************************************************ \begin{code} -data RecFlag = Recursive - | NonRecursive - deriving( Eq, Data, Typeable ) +data RecFlag = Recursive + | NonRecursive + deriving( Eq, Data, Typeable ) isRec :: RecFlag -> Bool isRec Recursive = True @@ -361,38 +356,41 @@ instance Outputable RecFlag where \end{code} %************************************************************************ -%* * - Instance overlap flag -%* * +%* * + Instance overlap flag +%* * %************************************************************************ \begin{code} +-- | The semantics allowed for overlapping instances for a particular +-- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.lhs`) for a +-- explanation of the `isSafeOverlap` field. data OverlapFlag -- | This instance must not overlap another = NoOverlap { isSafeOverlap :: Bool } - -- | Silently ignore this instance if you find a + -- | 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 + -- instances (Foo [Int]) + -- (Foo [a]) OverlapOk -- Since the second instance has the OverlapOk flag, - -- the first instance will be chosen (otherwise + -- the first instance will be chosen (otherwise -- its ambiguous which to choose) | OverlapOk { isSafeOverlap :: Bool } - -- | Like OverlapOk, but also ignore this instance + -- | 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]) + -- instances (Foo [Int]) Incoherent + -- (Foo [a]) -- Without the Incoherent flag, we'd complain that - -- instantiating 'b' would change which instance + -- instantiating 'b' would change which instance -- was chosen | Incoherent { isSafeOverlap :: Bool } deriving (Eq, Data, Typeable) @@ -408,9 +406,9 @@ pprSafeOverlap False = empty \end{code} %************************************************************************ -%* * - Tuples -%* * +%* * + Tuples +%* * %************************************************************************ \begin{code} @@ -431,36 +429,36 @@ boxityNormalTupleSort Unboxed = UnboxedTuple tupleParens :: TupleSort -> SDoc -> SDoc tupleParens BoxedTuple p = parens p -tupleParens ConstraintTuple p = parens p -- The user can't write fact tuples +tupleParens ConstraintTuple p = parens p -- The user can't write fact tuples -- directly, we overload the (,,) syntax tupleParens UnboxedTuple p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") \end{code} %************************************************************************ -%* * +%* * \subsection[Generic]{Generic flag} -%* * +%* * %************************************************************************ -This is the "Embedding-Projection pair" datatype, it contains +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 +represents functions of type - from :: T -> Tring - to :: Tring -> T + from :: T -> Tring + to :: Tring -> T -And we should have +And we should have - to (from x) = x + 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 +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 +data EP a = EP { fromEP :: a, -- :: T -> Tring + toEP :: a } -- :: Tring -> T \end{code} Embedding-projection pairs are used in several places: @@ -468,15 +466,15 @@ 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, +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 @@ -486,21 +484,21 @@ defn of OccInfo here, safely at the bottom \begin{code} -- | Identifier occurrence information -data OccInfo - = NoOccInfo -- ^ There are many occurrences, or unknown occurences +data OccInfo + = NoOccInfo -- ^ There are many occurrences, or unknown occurences - | IAmDead -- ^ Marks unused variables. Sometimes useful for - -- lambda and case-bound variables. + | IAmDead -- ^ Marks unused variables. Sometimes useful for + -- lambda and case-bound variables. | OneOcc - !InsideLam - !OneBranch - !InterestingCxt -- ^ Occurs exactly once, not inside a rule + !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 + | IAmALoopBreaker -- Note [LoopBreaker OccInfo] + !RulesOnly type RulesOnly = Bool \end{code} @@ -508,7 +506,7 @@ type RulesOnly = Bool Note [LoopBreaker OccInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~ IAmALoopBreaker True <=> A "weak" or rules-only loop breaker - Do not preInlineUnconditionally + Do not preInlineUnconditionally IAmALoopBreaker False <=> A "strong" loop breaker Do not inline at all @@ -525,21 +523,21 @@ 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 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. +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 +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 @@ -572,29 +570,29 @@ zapFragileOcc occ = occ \begin{code} instance Outputable OccInfo where -- only used for debugging; never parsed. KSW 1999-07 - ppr NoOccInfo = empty + ppr NoOccInfo = empty ppr (IAmALoopBreaker ro) = ptext (sLit "LoopBreaker") <> if ro then char '!' else empty - ppr IAmDead = ptext (sLit "Dead") + 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 + = 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 \end{code} %************************************************************************ -%* * - Default method specfication -%* * +%* * + Default method specfication +%* * %************************************************************************ The DefMethSpec enumeration just indicates what sort of default method -is used for a class. It is generated from source code, and present in -interface files; it is converted to Class.DefMeth before begin put in a +is used for a class. It is generated from source code, and present in +interface files; it is converted to Class.DefMeth before begin put in a Class object. \begin{code} @@ -609,9 +607,9 @@ instance Outputable DefMethSpec where \end{code} %************************************************************************ -%* * +%* * \subsection{Success flag} -%* * +%* * %************************************************************************ \begin{code} @@ -635,9 +633,9 @@ failed Failed = True %************************************************************************ -%* * +%* * \subsection{Activation} -%* * +%* * %************************************************************************ When a rule or inlining is active @@ -656,26 +654,26 @@ instance Outputable CompilerPhase where ppr InitialPhase = ptext (sLit "InitialPhase") data Activation = NeverActive - | AlwaysActive + | AlwaysActive | ActiveBefore PhaseNum -- Active only *before* this phase | ActiveAfter PhaseNum -- Active in this phase and later - deriving( Eq, Data, Typeable ) -- Eq used in comparing rules in HsDecls + deriving( Eq, Data, Typeable ) -- Eq used in comparing rules in HsDecls -data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] +data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] | FunLike deriving( Eq, Data, Typeable, Show ) - -- Show needed for Lexer.x + -- Show needed for Lexer.x -data InlinePragma -- Note [InlinePragma] +data InlinePragma -- Note [InlinePragma] = InlinePragma { inl_inline :: InlineSpec - , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n - -- explicit (non-type, non-dictionary) args - -- That is, inl_sat describes the number of *source-code* - -- arguments the thing must be applied to. We add on the + , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n + -- explicit (non-type, non-dictionary) args + -- That is, inl_sat describes the number of *source-code* + -- arguments the thing must be applied to. We add on the -- number of implicit, dictionary arguments when making - -- the InlineRule, and don't look at inl_sat further + -- the InlineRule, and don't look at inl_sat further , inl_act :: Activation -- Says during which phases inlining is allowed @@ -686,14 +684,15 @@ data InlineSpec -- What the user's INLINE pragama looked like = Inline | Inlinable | NoInline - | EmptyInlineSpec + | EmptyInlineSpec -- Used in a place-holder InlinePragma in SpecPrag or IdInfo, + -- where there isn't any real inline pragma at all deriving( Eq, Data, Typeable, Show ) - -- Show needed for Lexer.x + -- Show needed for Lexer.x \end{code} Note [InlinePragma] ~~~~~~~~~~~~~~~~~~~ -This data type mirrors what you can write in an INLINE or NOINLINE pragma in +This data type mirrors what you can write in an INLINE or NOINLINE pragma in the source program. If you write nothing at all, you get defaultInlinePragma: @@ -701,7 +700,7 @@ If you write nothing at all, you get defaultInlinePragma: inl_act = AlwaysActive inl_rule = FunLike -It's not possible to get that combination by *writing* something, so +It's not possible to get that combination by *writing* something, so if an Id has defaultInlinePragma it means the user didn't specify anything. If inl_inline = True, then the Id should have an InlineRule unfolding. @@ -712,7 +711,7 @@ The ConLike constructor of a RuleMatchInfo is aimed at the following. Consider first {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-} g b bs = let x = b:bs in ..x...x...(r x)... -Now, the rule applies to the (r x) term, because GHC "looks through" +Now, the rule applies to the (r x) term, because GHC "looks through" the definition of 'x' to see that it is (b:bs). Now consider @@ -720,7 +719,7 @@ Now consider g v = let x = f v in ..x...x...(r x)... Normally the (r x) would *not* match the rule, because GHC would be scared about duplicating the redex (f v), so it does not "look -through" the bindings. +through" the bindings. However the CONLIKE modifier says to treat 'f' like a constructor in this situation, and "look through" the unfolding for x. So (r x) @@ -768,7 +767,7 @@ neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } inlinePragmaSpec :: InlinePragma -> InlineSpec inlinePragmaSpec = inl_inline --- A DFun has an always-active inline activation so that +-- A DFun has an always-active inline activation so that -- exprIsConApp_maybe can "see" its unfolding -- (However, its actual Unfolding is a DFunUnfolding, which is -- never inlined other than via exprIsConApp_maybe.) @@ -797,7 +796,7 @@ isAnyInlinePragma prag = case inl_inline prag of Inline -> True Inlinable -> True _ -> False - + inlinePragmaSat :: InlinePragma -> Maybe Arity inlinePragmaSat = inl_sat @@ -832,9 +831,9 @@ instance Outputable InlineSpec where instance Outputable InlinePragma where ppr (InlinePragma { inl_inline = inline, inl_act = activation , inl_rule = info, inl_sat = mb_arity }) - = ppr inline <> pp_act inline activation <+> pp_sat <+> pp_info + = ppr inline <> pp_act inline activation <+> pp_sat <+> pp_info where - pp_act Inline AlwaysActive = empty + pp_act Inline AlwaysActive = empty pp_act NoInline NeverActive = empty pp_act _ act = ppr act @@ -864,7 +863,7 @@ isAlwaysActive _ = False isEarlyActive AlwaysActive = True isEarlyActive (ActiveBefore {}) = True -isEarlyActive _ = False +isEarlyActive _ = False \end{code} diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 2b96d3f8d1..eba5c8b67d 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -529,6 +529,10 @@ instance NamedThing DataCon where instance Outputable DataCon where ppr con = ppr (dataConName con) +instance OutputableBndr DataCon where + pprInfixOcc con = pprInfixName (dataConName con) + pprPrefixOcc con = pprPrefixName (dataConName con) + instance Data.Data DataCon where -- don't traverse? toConstr _ = abstractConstr "DataCon" @@ -646,11 +650,12 @@ mkDataCon name declared_infix | isJust (promotableTyCon_maybe rep_tycon) -- The TyCon is promotable only if all its datacons -- are, so the promoteType for prom_kind should succeed - = Just (mkPromotedDataCon con name (getUnique name) prom_kind arity) + = Just (mkPromotedDataCon con name (getUnique name) prom_kind roles) | otherwise = Nothing prom_kind = promoteType (dataConUserType con) - arity = dataConSourceArity con + roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++ + map (const Representational) orig_arg_tys eqSpecPreds :: [(TyVar,Type)] -> ThetaType eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ] @@ -884,9 +889,9 @@ dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality con -> [Type] dataConInstArgTys dc@(MkData {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 ) + = 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) (dataConRepArgTys dc) -- | Returns just the instantiated /value/ argument types of a 'DataCon', @@ -992,6 +997,7 @@ dataConCannotMatch tys con \begin{code} buildAlgTyCon :: Name -> [TyVar] -- ^ Kind variables and type variables + -> [Role] -> Maybe CType -> ThetaType -- ^ Stupid theta -> AlgTyConRhs @@ -1001,14 +1007,14 @@ buildAlgTyCon :: Name -> TyConParent -> TyCon -buildAlgTyCon tc_name ktvs cType stupid_theta rhs +buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs is_rec is_promotable gadt_syn parent = tc where kind = mkPiKinds ktvs liftedTypeKind -- tc and mb_promoted_tc are mutually recursive - tc = mkAlgTyCon tc_name kind ktvs cType stupid_theta + tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta rhs parent is_rec gadt_syn mb_promoted_tc diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index 25f3091fcf..3e8096a272 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -7,15 +7,18 @@ \begin{code} module Demand ( - StrDmd, strBot, strTop, strStr, strProd, strCall, - AbsDmd, absBot, absTop, absProd, + StrDmd, UseDmd(..), Count(..), + countOnce, countMany, -- cardinality - Demand, JointDmd, mkProdDmd, - absDmd, topDmd, botDmd, + Demand, CleanDemand, + mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd, + getUsage, toCleanDmd, + absDmd, topDmd, botDmd, seqDmd, lubDmd, bothDmd, isTopDmd, isBotDmd, isAbsDmd, isSeqDmd, + peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd, - DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType, + DmdType(..), dmdTypeDepth, lubDmdType, bothDmdEnv, bothDmdType, topDmdType, botDmdType, mkDmdType, mkTopDmdType, DmdEnv, emptyDmdEnv, @@ -28,28 +31,32 @@ module Demand ( StrictSig(..), mkStrictSig, topSig, botSig, cprProdSig, isTopSig, splitStrictSig, increaseStrictSigArity, - seqStrDmd, seqStrDmdList, seqAbsDmd, seqAbsDmdList, seqDemand, seqDemandList, seqDmdType, seqStrictSig, - evalDmd, vanillaCall, isStrictDmd, splitCallDmd, splitDmdTy, - someCompUsed, isUsed, isUsedDmd, - defer, deferType, deferEnv, modifyEnv, - isProdDmd, splitProdDmd, splitProdDmd_maybe, peelCallDmd, mkCallDmd, - dmdTransformSig, dmdTransformDataConSig, + evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd, + splitDmdTy, splitFVs, + deferDmd, deferType, deferAndUse, deferEnv, modifyEnv, + + splitProdDmd, splitProdDmd_maybe, peelCallDmd, mkCallDmd, + dmdTransformSig, dmdTransformDataConSig, argOneShots, argsOneShots, + + isSingleUsed, useType, useEnv, zapDemand, zapStrictSig, worthSplittingFun, worthSplittingThunk + ) where #include "HsVersions.h" import StaticFlags +import DynFlags import Outputable import VarEnv import UniqFM import Util import BasicTypes import Binary -import Maybes ( isJust, expectJust ) +import Maybes ( isJust, expectJust ) \end{code} %************************************************************************ @@ -60,13 +67,14 @@ import Maybes ( isJust, expectJust ) Lazy | - Str + HeadStr / \ SCall SProd \ / HyperStr \begin{code} + -- Vanilla strictness domain data StrDmd = HyperStr -- Hyper-strict @@ -75,99 +83,115 @@ data StrDmd | SCall StrDmd -- Call demand -- Used only for values of function type - | SProd [StrDmd] -- Product + | SProd [MaybeStr] -- Product -- Used only for values of product type -- Invariant: not all components are HyperStr (use HyperStr) - -- not all components are Lazy (use Str) + -- not all components are Lazy (use HeadStr) - | Str -- Head-Strict + | HeadStr -- Head-Strict -- A polymorphic demand: used for values of all types, -- including a type variable - | Lazy -- Lazy - -- Top of the lattice + deriving ( Eq, Show ) + +data MaybeStr = Lazy -- Lazy + -- Top of the lattice + | Str StrDmd deriving ( Eq, Show ) -- Well-formedness preserving constructors for the Strictness domain -strBot, strTop, strStr :: StrDmd -strBot = HyperStr -strTop = Lazy -strStr = Str - -strCall :: StrDmd -> StrDmd -strCall Lazy = Lazy -strCall HyperStr = HyperStr -strCall s = SCall s - -strProd :: [StrDmd] -> StrDmd -strProd sx - | any (== HyperStr) sx = strBot - | all (== Lazy) sx = strStr - | otherwise = SProd sx +strBot, strTop :: MaybeStr +strBot = Str HyperStr +strTop = Lazy + +mkSCall :: StrDmd -> StrDmd +mkSCall HyperStr = HyperStr +mkSCall s = SCall s + +mkSProd :: [MaybeStr] -> StrDmd +mkSProd sx + | any isHyperStr sx = HyperStr + | all isLazy sx = HeadStr + | otherwise = SProd sx + +isLazy :: MaybeStr -> Bool +isLazy Lazy = True +isLazy (Str _) = False + +isHyperStr :: MaybeStr -> Bool +isHyperStr (Str HyperStr) = True +isHyperStr _ = False -- Pretty-printing instance Outputable StrDmd where ppr HyperStr = char 'B' - ppr Lazy = char 'L' ppr (SCall s) = char 'C' <> parens (ppr s) - ppr Str = char 'S' + ppr HeadStr = char 'S' ppr (SProd sx) = char 'S' <> parens (hcat (map ppr sx)) +instance Outputable MaybeStr where + ppr (Str s) = ppr s + ppr Lazy = char 'L' + +lubMaybeStr :: MaybeStr -> MaybeStr -> MaybeStr +lubMaybeStr Lazy _ = Lazy +lubMaybeStr _ Lazy = Lazy +lubMaybeStr (Str s1) (Str s2) = Str (s1 `lubStr` s2) + lubStr :: StrDmd -> StrDmd -> StrDmd lubStr HyperStr s = s lubStr (SCall s1) HyperStr = SCall s1 -lubStr (SCall _) Lazy = Lazy -lubStr (SCall _) Str = Str +lubStr (SCall _) HeadStr = HeadStr lubStr (SCall s1) (SCall s2) = SCall (s1 `lubStr` s2) -lubStr (SCall _) (SProd _) = Str -lubStr (SProd _) HyperStr = HyperStr -lubStr (SProd _) Lazy = Lazy -lubStr (SProd _) Str = Str +lubStr (SCall _) (SProd _) = HeadStr +lubStr (SProd sx) HyperStr = SProd sx +lubStr (SProd _) HeadStr = HeadStr lubStr (SProd s1) (SProd s2) - | length s1 == length s2 = SProd (zipWith lubStr s1 s2) - | otherwise = Str -lubStr (SProd _) (SCall _) = Str -lubStr Str Lazy = Lazy -lubStr Str _ = Str -lubStr Lazy _ = Lazy + | length s1 == length s2 = mkSProd (zipWith lubMaybeStr s1 s2) + | otherwise = HeadStr +lubStr (SProd _) (SCall _) = HeadStr +lubStr HeadStr _ = HeadStr + +bothMaybeStr :: MaybeStr -> MaybeStr -> MaybeStr +bothMaybeStr Lazy s = s +bothMaybeStr s Lazy = s +bothMaybeStr (Str s1) (Str s2) = Str (s1 `bothStr` s2) bothStr :: StrDmd -> StrDmd -> StrDmd bothStr HyperStr _ = HyperStr -bothStr Lazy s = s -bothStr Str Lazy = Str -bothStr Str s = s +bothStr HeadStr s = s bothStr (SCall _) HyperStr = HyperStr -bothStr (SCall s1) Lazy = SCall s1 -bothStr (SCall s1) Str = SCall s1 +bothStr (SCall s1) HeadStr = SCall s1 bothStr (SCall s1) (SCall s2) = SCall (s1 `bothStr` s2) bothStr (SCall _) (SProd _) = HyperStr -- Weird bothStr (SProd _) HyperStr = HyperStr -bothStr (SProd s1) Lazy = SProd s1 -bothStr (SProd s1) Str = SProd s1 +bothStr (SProd s1) HeadStr = SProd s1 bothStr (SProd s1) (SProd s2) - | length s1 == length s2 = SProd (zipWith bothStr s1 s2) + | length s1 == length s2 = mkSProd (zipWith bothMaybeStr s1 s2) | otherwise = HyperStr -- Weird bothStr (SProd _) (SCall _) = HyperStr - -- utility functions to deal with memory leaks seqStrDmd :: StrDmd -> () seqStrDmd (SProd ds) = seqStrDmdList ds seqStrDmd (SCall s) = s `seq` () seqStrDmd _ = () -seqStrDmdList :: [StrDmd] -> () +seqStrDmdList :: [MaybeStr] -> () seqStrDmdList [] = () -seqStrDmdList (d:ds) = seqStrDmd d `seq` seqStrDmdList ds +seqStrDmdList (d:ds) = seqMaybeStr d `seq` seqStrDmdList ds + +seqMaybeStr :: MaybeStr -> () +seqMaybeStr Lazy = () +seqMaybeStr (Str s) = seqStrDmd s -- Splitting polymorphic demands -splitStrProdDmd :: Int -> StrDmd -> [StrDmd] -splitStrProdDmd n Lazy = replicate n Lazy -splitStrProdDmd n HyperStr = replicate n HyperStr -splitStrProdDmd n Str = replicate n Lazy +splitStrProdDmd :: Int -> StrDmd -> [MaybeStr] +splitStrProdDmd n HyperStr = replicate n strBot +splitStrProdDmd n HeadStr = replicate n strTop splitStrProdDmd n (SProd ds) = ASSERT( ds `lengthIs` n) ds -splitStrProdDmd n (SCall d) = ASSERT( n == 1 ) [d] +splitStrProdDmd _ d@(SCall {}) = pprPanic "attempt to prod-split strictness call demand" (ppr d) \end{code} %************************************************************************ @@ -176,30 +200,6 @@ splitStrProdDmd n (SCall d) = ASSERT( n == 1 ) [d] %* * %************************************************************************ -Note [Don't optimise UProd(Used) to Used] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -These two AbsDmds: - UProd [Used, Used] and Used -are semantically equivalent, but we do not turn the former into -the latter, for a regrettable-subtle reason. Suppose we did. -then - f (x,y) = (y,x) -would get - StrDmd = Str = SProd [Lazy, Lazy] - AbsDmd = Used = UProd [Used, Used] -But with the joint demand of <Str, Used> doesn't convey any clue -that there is a product involved, and so the worthSplittingFun -will not fire. (We'd need to use the type as well to make it fire.) -Moreover, consider - g h p@(_,_) = h p -This too would get <Str, Used>, but this time there really isn't any -point in w/w since the components of the pair are not used at all. - -So the solution is: don't collapse UProd [Used,Used] to Used; intead -leave it as-is. In effect we are using the AbsDmd to do a little bit -of boxity analysis. Not very nice. - - Used / \ UCall UProd @@ -209,93 +209,228 @@ of boxity analysis. Not very nice. Abs \begin{code} -data AbsDmd - = Abs -- Definitely unused - -- Bottom of the lattice - | UHead -- May be used; but its sub-components are - -- definitely *not* used. Roughly U(AAA) - -- Eg the usage of x in x `seq` e - -- A polymorphic demand: used for values of all types, - -- including a type variable - - | UCall AbsDmd -- Call demand for absence +-- Domain for genuine usage +data UseDmd + = UCall Count UseDmd -- Call demand for absence -- Used only for values of function type - | UProd [AbsDmd] -- Product + | UProd [MaybeUsed] -- Product -- Used only for values of product type -- See Note [Don't optimise UProd(Used) to Used] -- [Invariant] Not all components are Abs -- (in that case, use UHead) + | UHead -- May be used; but its sub-components are + -- definitely *not* used. Roughly U(AAA) + -- Eg the usage of x in x `seq` e + -- A polymorphic demand: used for values of all types, + -- including a type variable + -- Since (UCall _ Abs) is ill-typed, UHead doesn't + -- make sense for lambdas + | Used -- May be used; and its sub-components may be used -- Top of the lattice deriving ( Eq, Show ) +-- Extended usage demand for absence and counting +data MaybeUsed + = Abs -- Definitely unused + -- Bottom of the lattice + + | Use Count UseDmd -- May be used with some cardinality + deriving ( Eq, Show ) + +-- Abstract counting of usages +data Count = One | Many + deriving ( Eq, Show ) -- Pretty-printing -instance Outputable AbsDmd where - ppr Abs = char 'A' - ppr Used = char 'U' - ppr (UCall a) = char 'C' <> parens (ppr a) - ppr UHead = char 'H' - ppr (UProd as) = (char 'U') <> parens (hcat (map ppr as)) +instance Outputable MaybeUsed where + ppr Abs = char 'A' + ppr (Use Many a) = ppr a + ppr (Use One a) = char '1' <> char '*' <> ppr a + +instance Outputable UseDmd where + ppr Used = char 'U' + ppr (UCall c a) = char 'C' <> ppr c <> parens (ppr a) + ppr UHead = char 'H' + ppr (UProd as) = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as))) + +instance Outputable Count where + ppr One = char '1' + ppr Many = text "" -- Well-formedness preserving constructors for the Absence domain -absBot, absTop, absHead :: AbsDmd -absBot = Abs -absHead = UHead -absTop = Used - -absCall :: AbsDmd -> AbsDmd -absCall Used = Used -absCall Abs = Abs -absCall a = UCall a - -absProd :: [AbsDmd] -> AbsDmd -absProd ux --- | all (== Used) ux = Used +countOnce, countMany :: Count +countOnce = One +countMany = Many + +useBot, useTop :: MaybeUsed +useBot = Abs +useTop = Use Many Used + +mkUCall :: Count -> UseDmd -> UseDmd +--mkUCall c Used = Used c +mkUCall c a = UCall c a + +mkUProd :: [MaybeUsed] -> UseDmd +mkUProd ux | all (== Abs) ux = UHead | otherwise = UProd ux -lubAbs :: AbsDmd -> AbsDmd -> AbsDmd -lubAbs Abs x = x -lubAbs UHead Abs = UHead -lubAbs UHead x = x -lubAbs (UCall u1) Abs = UCall u1 -lubAbs (UCall u1) UHead = UCall u1 -lubAbs (UCall u1) (UCall u2) = UCall (u1 `lubAbs` u2) -lubAbs (UCall _) _ = Used -lubAbs (UProd u1) Abs = UProd u1 -lubAbs (UProd u1) UHead = UProd u1 -lubAbs (UProd u1) (UProd u2) - | length u1 == length u2 = UProd (zipWith lubAbs u1 u2) - | otherwise = Used -lubAbs (UProd _) (UCall _) = Used -lubAbs (UProd ds) Used = UProd (map (`lubAbs` Used) ds) -- Note [Don't optimise UProd(Used) to Used] -lubAbs Used (UProd ds) = UProd (map (`lubAbs` Used) ds) -- Note [Don't optimise UProd(Used) to Used] -lubAbs Used _ = Used - -bothAbs :: AbsDmd -> AbsDmd -> AbsDmd -bothAbs = lubAbs - --- utility functions -seqAbsDmd :: AbsDmd -> () -seqAbsDmd (UProd ds) = seqAbsDmdList ds -seqAbsDmd (UCall d) = seqAbsDmd d -seqAbsDmd _ = () - -seqAbsDmdList :: [AbsDmd] -> () -seqAbsDmdList [] = () -seqAbsDmdList (d:ds) = seqAbsDmd d `seq` seqAbsDmdList ds +lubCount :: Count -> Count -> Count +lubCount _ Many = Many +lubCount Many _ = Many +lubCount x _ = x + +lubMaybeUsed :: MaybeUsed -> MaybeUsed -> MaybeUsed +lubMaybeUsed Abs x = x +lubMaybeUsed x Abs = x +lubMaybeUsed (Use c1 a1) (Use c2 a2) = Use (lubCount c1 c2) (lubUse a1 a2) + +lubUse :: UseDmd -> UseDmd -> UseDmd +lubUse UHead u = u +lubUse (UCall c u) UHead = UCall c u +lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2) +lubUse (UCall _ _) _ = Used +lubUse (UProd ux) UHead = UProd ux +lubUse (UProd ux1) (UProd ux2) + | length ux1 == length ux2 = UProd $ zipWith lubMaybeUsed ux1 ux2 + | otherwise = Used +lubUse (UProd {}) (UCall {}) = Used +-- lubUse (UProd {}) Used = Used +lubUse (UProd ux) Used = UProd (map (`lubMaybeUsed` useTop) ux) +lubUse Used (UProd ux) = UProd (map (`lubMaybeUsed` useTop) ux) +lubUse Used _ = Used -- Note [Used should win] + +-- `both` is different from `lub` in its treatment of counting; if +-- `both` is computed for two used, the result always has +-- cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain). +-- Also, x `bothUse` x /= x (for anything but Abs). + +bothMaybeUsed :: MaybeUsed -> MaybeUsed -> MaybeUsed +bothMaybeUsed Abs x = x +bothMaybeUsed x Abs = x +bothMaybeUsed (Use _ a1) (Use _ a2) = Use Many (bothUse a1 a2) + + +bothUse :: UseDmd -> UseDmd -> UseDmd +bothUse UHead u = u +bothUse (UCall c u) UHead = UCall c u + +-- Exciting special treatment of inner demand for call demands: +-- use `lubUse` instead of `bothUse`! +bothUse (UCall _ u1) (UCall _ u2) = UCall Many (u1 `lubUse` u2) + +bothUse (UCall {}) _ = Used +bothUse (UProd ux) UHead = UProd ux +bothUse (UProd ux1) (UProd ux2) + | length ux1 == length ux2 = UProd $ zipWith bothMaybeUsed ux1 ux2 + | otherwise = Used +bothUse (UProd {}) (UCall {}) = Used +-- bothUse (UProd {}) Used = Used -- Note [Used should win] +bothUse Used (UProd ux) = UProd (map (`bothMaybeUsed` useTop) ux) +bothUse (UProd ux) Used = UProd (map (`bothMaybeUsed` useTop) ux) +bothUse Used _ = Used -- Note [Used should win] + +peelUseCall :: UseDmd -> Maybe (Count, UseDmd) +peelUseCall (UCall c u) = Just (c,u) +peelUseCall _ = Nothing +\end{code} --- Splitting polymorphic demands -splitAbsProdDmd :: Int -> AbsDmd -> [AbsDmd] -splitAbsProdDmd n Abs = replicate n Abs -splitAbsProdDmd n Used = replicate n Used -splitAbsProdDmd n UHead = replicate n Abs -splitAbsProdDmd n (UProd ds) = ASSERT( ds `lengthIs` n ) ds -splitAbsProdDmd n (UCall d) = ASSERT( n == 1 ) [d] +Note [Don't optimise UProd(Used) to Used] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These two UseDmds: + UProd [Used, Used] and Used +are semantically equivalent, but we do not turn the former into +the latter, for a regrettable-subtle reason. Suppose we did. +then + f (x,y) = (y,x) +would get + StrDmd = Str = SProd [Lazy, Lazy] + UseDmd = Used = UProd [Used, Used] +But with the joint demand of <Str, Used> doesn't convey any clue +that there is a product involved, and so the worthSplittingFun +will not fire. (We'd need to use the type as well to make it fire.) +Moreover, consider + g h p@(_,_) = h p +This too would get <Str, Used>, but this time there really isn't any +point in w/w since the components of the pair are not used at all. + +So the solution is: don't aggressively collapse UProd [Used,Used] to +Used; intead leave it as-is. In effect we are using the UseDmd to do a +little bit of boxity analysis. Not very nice. + +Note [Used should win] +~~~~~~~~~~~~~~~~~~~~~~ +Both in lubUse and bothUse we want (Used `both` UProd us) to be Used. +Why? Because Used carries the implication the whole thing is used, +box and all, so we don't want to w/w it. If we use it both boxed and +unboxed, then we are definitely using the box, and so we are quite +likely to pay a reboxing cost. So we make Used win here. + +Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer + +Baseline: (A) Not making Used win (UProd wins) +Compare with: (B) making Used win for lub and both + + Min -0.3% -5.6% -10.7% -11.0% -33.3% + Max +0.3% +45.6% +11.5% +11.5% +6.9% + Geometric Mean -0.0% +0.5% +0.3% +0.2% -0.8% + +Baseline: (B) Making Used win for both lub and both +Compare with: (C) making Used win for both, but UProd win for lub + + Min -0.1% -0.3% -7.9% -8.0% -6.5% + Max +0.1% +1.0% +21.0% +21.0% +0.5% + Geometric Mean +0.0% +0.0% -0.0% -0.1% -0.1% + + +\begin{code} +markAsUsedDmd :: MaybeUsed -> MaybeUsed +markAsUsedDmd Abs = Abs +markAsUsedDmd (Use _ a) = Use Many (markUsed a) + +markUsed :: UseDmd -> UseDmd +markUsed (UCall _ u) = UCall Many u -- No need to recurse here +markUsed (UProd ux) = UProd (map markAsUsedDmd ux) +markUsed u = u + +isUsedMU :: MaybeUsed -> Bool +-- True <=> markAsUsedDmd d = d +isUsedMU Abs = True +isUsedMU (Use One _) = False +isUsedMU (Use Many u) = isUsedU u + +isUsedU :: UseDmd -> Bool +-- True <=> markUsed d = d +isUsedU Used = True +isUsedU UHead = True +isUsedU (UProd us) = all isUsedMU us +isUsedU (UCall One _) = False +isUsedU (UCall Many _) = True -- No need to recurse + +-- Squashing usage demand demands +seqUseDmd :: UseDmd -> () +seqUseDmd (UProd ds) = seqMaybeUsedList ds +seqUseDmd (UCall c d) = c `seq` seqUseDmd d +seqUseDmd _ = () + +seqMaybeUsedList :: [MaybeUsed] -> () +seqMaybeUsedList [] = () +seqMaybeUsedList (d:ds) = seqMaybeUsed d `seq` seqMaybeUsedList ds + +seqMaybeUsed :: MaybeUsed -> () +seqMaybeUsed (Use c u) = c `seq` seqUseDmd u +seqMaybeUsed _ = () + +-- Splitting polymorphic Maybe-Used demands +splitUseProdDmd :: Int -> UseDmd -> [MaybeUsed] +splitUseProdDmd n Used = replicate n useTop +splitUseProdDmd n UHead = replicate n Abs +splitUseProdDmd n (UProd ds) = ASSERT( ds `lengthIs` n ) ds +splitUseProdDmd _ d@(UCall _ _) = pprPanic "attempt to prod-split usage call demand" (ppr d) \end{code} %************************************************************************ @@ -306,7 +441,7 @@ splitAbsProdDmd n (UCall d) = ASSERT( n == 1 ) [d] \begin{code} -data JointDmd = JD { strd :: StrDmd, absd :: AbsDmd } +data JointDmd = JD { strd :: MaybeStr, absd :: MaybeUsed } deriving ( Eq, Show ) -- Pretty-printing @@ -314,91 +449,95 @@ instance Outputable JointDmd where ppr (JD {strd = s, absd = a}) = angleBrackets (ppr s <> char ',' <> ppr a) -- Well-formedness preserving constructors for the joint domain -mkJointDmd :: StrDmd -> AbsDmd -> JointDmd +mkJointDmd :: MaybeStr -> MaybeUsed -> JointDmd mkJointDmd s a = JD { strd = s, absd = a } --- = case (s, a) of --- (HyperStr, UProd _) -> JD {strd = HyperStr, absd = Used} --- _ -> JD {strd = s, absd = a} -mkJointDmds :: [StrDmd] -> [AbsDmd] -> [JointDmd] +mkJointDmds :: [MaybeStr] -> [MaybeUsed] -> [JointDmd] mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as - -mkProdDmd :: [JointDmd] -> JointDmd -mkProdDmd dx - = mkJointDmd sp up - where - sp = strProd $ map strd dx - up = absProd $ map absd dx absDmd :: JointDmd -absDmd = mkJointDmd strTop absBot +absDmd = mkJointDmd Lazy Abs topDmd :: JointDmd -topDmd = mkJointDmd strTop absTop +topDmd = mkJointDmd Lazy useTop + +seqDmd :: JointDmd +seqDmd = mkJointDmd (Str HeadStr) (Use One UHead) botDmd :: JointDmd -botDmd = mkJointDmd strBot absBot +botDmd = mkJointDmd strBot useBot lubDmd :: JointDmd -> JointDmd -> JointDmd lubDmd (JD {strd = s1, absd = a1}) - (JD {strd = s2, absd = a2}) = mkJointDmd (lubStr s1 s2) (lubAbs a1 a2) + (JD {strd = s2, absd = a2}) = mkJointDmd (s1 `lubMaybeStr` s2) (a1 `lubMaybeUsed` a2) bothDmd :: JointDmd -> JointDmd -> JointDmd bothDmd (JD {strd = s1, absd = a1}) - (JD {strd = s2, absd = a2}) = mkJointDmd (bothStr s1 s2) (bothAbs a1 a2) + (JD {strd = s2, absd = a2}) = mkJointDmd (s1 `bothMaybeStr` s2) (a1 `bothMaybeUsed` a2) isTopDmd :: JointDmd -> Bool -isTopDmd (JD {strd = Lazy, absd = Used}) = True -isTopDmd _ = False +isTopDmd (JD {strd = Lazy, absd = Use Many Used}) = True +isTopDmd _ = False isBotDmd :: JointDmd -> Bool -isBotDmd (JD {strd = HyperStr, absd = Abs}) = True -isBotDmd _ = False +isBotDmd (JD {strd = Str HyperStr, absd = Abs}) = True +isBotDmd _ = False isAbsDmd :: JointDmd -> Bool isAbsDmd (JD {absd = Abs}) = True -- The strictness part can be HyperStr isAbsDmd _ = False -- for a bottom demand isSeqDmd :: JointDmd -> Bool -isSeqDmd (JD {strd=Str, absd=UHead}) = True -isSeqDmd _ = False +isSeqDmd (JD {strd=Str HeadStr, absd=Use _ UHead}) = True +isSeqDmd _ = False -- More utility functions for strictness seqDemand :: JointDmd -> () -seqDemand (JD {strd = x, absd = y}) = x `seq` y `seq` () +seqDemand (JD {strd = x, absd = y}) = seqMaybeStr x `seq` seqMaybeUsed y `seq` () seqDemandList :: [JointDmd] -> () seqDemandList [] = () seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds +deferDmd :: JointDmd -> JointDmd +deferDmd (JD {absd = a}) = mkJointDmd Lazy a + isStrictDmd :: Demand -> Bool -- See Note [Strict demands] isStrictDmd (JD {absd = Abs}) = False isStrictDmd (JD {strd = Lazy}) = False isStrictDmd _ = True +isWeakDmd :: Demand -> Bool +isWeakDmd (JD {strd = s, absd = a}) = isLazy s && isUsedMU a -isUsedDmd :: Demand -> Bool -isUsedDmd (JD {absd = x}) = isUsed x - -isUsed :: AbsDmd -> Bool -isUsed x = x /= absBot +useDmd :: JointDmd -> JointDmd +useDmd (JD {strd=d, absd=a}) = mkJointDmd d (markAsUsedDmd a) -someCompUsed :: AbsDmd -> Bool -someCompUsed Used = True -someCompUsed (UProd _) = True -someCompUsed _ = False +cleanUseDmd_maybe :: JointDmd -> Maybe UseDmd +cleanUseDmd_maybe (JD { absd = Use _ ud }) = Just ud +cleanUseDmd_maybe _ = Nothing -evalDmd :: JointDmd --- Evaluated strictly, and used arbitrarily deeply -evalDmd = mkJointDmd strStr absTop +splitFVs :: Bool -- Thunk + -> DmdEnv -> (DmdEnv, DmdEnv) +splitFVs is_thunk rhs_fvs + | is_thunk = foldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs + | otherwise = partitionVarEnv isWeakDmd rhs_fvs + where + add uniq dmd@(JD { strd = s, absd = u }) (lazy_fv, sig_fv) + | Lazy <- s = (addToUFM_Directly lazy_fv uniq dmd, sig_fv) + | otherwise = ( addToUFM_Directly lazy_fv uniq (JD { strd = Lazy, absd = u }) + , addToUFM_Directly sig_fv uniq (JD { strd = s, absd = Abs }) ) +\end{code} -defer :: Demand -> Demand -defer (JD {absd = a}) = mkJointDmd strTop a +%************************************************************************ +%* * +\subsection{Clean demand for Strictness and Usage} +%* * +%************************************************************************ --- use :: Demand -> Demand --- use (JD {strd = d}) = mkJointDmd d top -\end{code} +This domain differst from JointDemand in the sence that pure absence +is taken away, i.e., we deal *only* with non-absent demands. Note [Strict demands] ~~~~~~~~~~~~~~~~~~~~~ @@ -430,53 +569,97 @@ f g = (snd (g 3), True) should be: <L,C(U(AU))>m + \begin{code} -mkCallDmd :: JointDmd -> JointDmd -mkCallDmd (JD {strd = d, absd = a}) = mkJointDmd (strCall d) (absCall a) -peelCallDmd :: JointDmd -> Maybe JointDmd +data CleanDemand = CD { sd :: StrDmd, ud :: UseDmd } + deriving ( Eq, Show ) + +instance Outputable CleanDemand where + ppr (CD {sd = s, ud = a}) = angleBrackets (ppr s <> comma <> ppr a) + +mkCleanDmd :: StrDmd -> UseDmd -> CleanDemand +mkCleanDmd s a = CD { sd = s, ud = a } + +bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand +bothCleanDmd (CD { sd = s1, ud = a1}) (CD { sd = s2, ud = a2}) + = CD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 } + +mkHeadStrict :: CleanDemand -> CleanDemand +mkHeadStrict (CD { ud = a }) = mkCleanDmd HeadStr a + +oneifyDmd :: JointDmd -> JointDmd +oneifyDmd (JD { strd = s, absd = Use _ a }) = JD { strd = s, absd = Use One a } +oneifyDmd jd = jd + +mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> JointDmd +mkOnceUsedDmd (CD {sd = s,ud = a}) = mkJointDmd (Str s) (Use One a) +mkManyUsedDmd (CD {sd = s,ud = a}) = mkJointDmd (Str s) (Use Many a) + +getUsage :: CleanDemand -> UseDmd +getUsage = ud + +evalDmd :: JointDmd +-- Evaluated strictly, and used arbitrarily deeply +evalDmd = mkJointDmd (Str HeadStr) useTop + +mkProdDmd :: [JointDmd] -> CleanDemand +mkProdDmd dx + = mkCleanDmd sp up + where + sp = mkSProd $ map strd dx + up = mkUProd $ map absd dx + +mkCallDmd :: CleanDemand -> CleanDemand +mkCallDmd (CD {sd = d, ud = u}) + = mkCleanDmd (mkSCall d) (mkUCall One u) + +-- Returns result demand * strictness flag * one-shotness of the call +peelCallDmd :: CleanDemand + -> ( CleanDemand + , Bool -- True <=> had to strengthen from HeadStr + -- hence defer results + , Count) -- Call count + -- Exploiting the fact that -- on the strictness side C(B) = B -- and on the usage side C(U) = U -peelCallDmd (JD {strd = s, absd = u}) - | Just s' <- peel_s s - , Just u' <- peel_u u - = Just $ mkJointDmd s' u' - | otherwise - = Nothing +peelCallDmd (CD {sd = s, ud = u}) + = let (s', b) = peel_s s + (u', c) = peel_u u + in (mkCleanDmd s' u', b, c) + where + peel_s (SCall s) = (s, False) + peel_s HyperStr = (HyperStr, False) + peel_s _ = (HeadStr, True) + + peel_u (UCall c u) = (u, c) + peel_u _ = (Used, Many) + -- The last case includes UHead which seems a bit wrong + -- because the body isn't used at all! + +cleanEvalDmd :: CleanDemand +cleanEvalDmd = mkCleanDmd HeadStr Used + +cleanEvalProdDmd :: Arity -> CleanDemand +cleanEvalProdDmd n = mkCleanDmd HeadStr (UProd (replicate n useTop)) + +isSingleUsed :: JointDmd -> Bool +isSingleUsed (JD {absd=a}) = is_used_once a where - peel_s (SCall s) = Just s - peel_s HyperStr = Just HyperStr - peel_s _ = Nothing - - peel_u (UCall u) = Just u - peel_u Used = Just Used - peel_u Abs = Just Abs - peel_u UHead = Just Abs - peel_u _ = Nothing - -splitCallDmd :: JointDmd -> (Int, JointDmd) -splitCallDmd (JD {strd = SCall d, absd = UCall a}) - = case splitCallDmd (mkJointDmd d a) of - (n, r) -> (n + 1, r) --- Exploiting the fact that C(U) === U -splitCallDmd (JD {strd = SCall d, absd = Used}) - = case splitCallDmd (mkJointDmd d Used) of - (n, r) -> (n + 1, r) -splitCallDmd d = (0, d) - -vanillaCall :: Arity -> Demand -vanillaCall 0 = evalDmd -vanillaCall n = - -- generate S^n (S) - let strComp = (iterate strCall strStr) !! n - absComp = (iterate absCall absTop) !! n - in mkJointDmd strComp absComp + is_used_once Abs = True + is_used_once (Use One _) = True + is_used_once _ = False \end{code} +Note [Threshold demands] +~~~~~~~~~~~~~~~~~~~~~~~~ +Threshold usage demand is generated to figure out if +cardinality-instrumented demands of a binding's free variables should +be unleashed. See also [Aggregated demand for cardinality]. + Note [Replicating polymorphic demands] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Some demands can be considered as polymorphic. Generally, it is applicable to such beasts as tops, bottoms as well as Head-Used adn Head-stricts demands. For instance, @@ -488,32 +671,26 @@ can be expanded to saturate a callee's arity. \begin{code} -splitProdDmd :: Int -> Demand -> [Demand] --- Split a product demands into its components, --- regardless of whether it has juice in it --- The demand is not ncessarily strict -splitProdDmd n (JD {strd=x, absd=y}) - = mkJointDmds (splitStrProdDmd n x) (splitAbsProdDmd n y) - -splitProdDmd_maybe :: Demand -> Maybe [Demand] +splitProdDmd :: Arity -> JointDmd -> [JointDmd] +splitProdDmd n (JD {strd = s, absd = u}) + = mkJointDmds (split_str s) (split_abs u) + where + split_str Lazy = replicate n Lazy + split_str (Str s) = splitStrProdDmd n s + + split_abs Abs = replicate n Abs + split_abs (Use _ u) = splitUseProdDmd n u + +splitProdDmd_maybe :: JointDmd -> Maybe [JointDmd] -- Split a product into its components, iff there is any -- useful information to be extracted thereby -- The demand is not necessarily strict! -splitProdDmd_maybe JD {strd=SProd sx, absd=UProd ux} - = ASSERT( sx `lengthIs` length ux ) - Just (mkJointDmds sx ux) -splitProdDmd_maybe JD {strd=SProd sx, absd=u} - = Just (mkJointDmds sx (splitAbsProdDmd (length sx) u)) -splitProdDmd_maybe (JD {strd=s, absd=UProd ux}) - = Just (mkJointDmds (splitStrProdDmd (length ux) s) ux) -splitProdDmd_maybe _ = Nothing - --- Check whether is a product demand with *some* useful info inside --- The demand is not ncessarily strict -isProdDmd :: Demand -> Bool -isProdDmd (JD {strd = SProd _}) = True -isProdDmd (JD {absd = UProd _}) = True -isProdDmd _ = False +splitProdDmd_maybe (JD {strd = s, absd = u}) + = case (s,u) of + (Str (SProd sx), Use _ u) -> Just (mkJointDmds sx (splitUseProdDmd (length sx) u)) + (Str s, Use _ (UProd ux)) -> Just (mkJointDmds (splitStrProdDmd (length ux) s) ux) + (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux) + _ -> Nothing \end{code} %************************************************************************ @@ -545,7 +722,8 @@ lubCPR _ _ = NoCPR bothCPR :: CPRResult -> CPRResult -> CPRResult -- See Note [Asymmetry of 'both' for DmdType and DmdResult] -bothCPR r _ = r +bothCPR _ BotCPR = BotCPR -- If either diverges, we diverge +bothCPR r _ = r instance Outputable DmdResult where ppr RetProd = char 'm' @@ -580,7 +758,6 @@ cprProdRes :: DmdResult cprProdRes | opt_CprOff = topRes | otherwise = RetProd - isTopRes :: DmdResult -> Bool isTopRes NoCPR = True isTopRes _ = False @@ -601,7 +778,7 @@ returnsCPR_maybe (RetSum t) = Just t returnsCPR_maybe (RetProd) = Just fIRST_TAG returnsCPR_maybe _ = Nothing -resTypeArgDmd :: DmdResult -> Demand +resTypeArgDmd :: DmdResult -> JointDmd -- TopRes and BotRes are polymorphic, so that -- BotRes === Bot -> BotRes === ... -- TopRes === Top -> TopRes === ... @@ -617,35 +794,41 @@ resTypeArgDmd _ = topDmd %************************************************************************ \begin{code} -worthSplittingFun :: [Demand] -> DmdResult -> Bool +worthSplittingFun :: [JointDmd] -> DmdResult -> Bool -- True <=> the wrapper would not be an identity function worthSplittingFun ds res = any worth_it ds || returnsCPR res -- worthSplitting returns False for an empty list of demands, -- and hence do_strict_ww is False if arity is zero and there is no CPR where - worth_it (JD {absd=Abs}) = True -- Absent arg + worth_it (JD {absd=Abs}) = True -- Absent arg -- See Note [Worker-wrapper for bottoming functions] - worth_it (JD {strd=HyperStr, absd=UProd _}) = True + worth_it (JD {strd=Str HyperStr, absd=Use _ (UProd _)}) = True -- See Note [Worthy functions for Worker-Wrapper split] - worth_it (JD {strd=SProd _}) = True -- Product arg to evaluate - worth_it (JD {strd=Str, absd=UProd _}) = True -- Strictly used product arg - worth_it (JD {strd=Str, absd=UHead}) = True - worth_it _ = False + worth_it (JD {strd=Str (SProd {})}) = True -- Product arg to evaluate + worth_it (JD {strd=Str HeadStr, absd=Use _ (UProd _)}) = True -- Strictly used product arg + worth_it (JD {strd=Str HeadStr, absd=Use _ UHead}) = True + worth_it _ = False -worthSplittingThunk :: Demand -- Demand on the thunk +worthSplittingThunk :: JointDmd -- Demand on the thunk -> DmdResult -- CPR info for the thunk -> Bool worthSplittingThunk dmd res = worth_it dmd || returnsCPR res where -- Split if the thing is unpacked - worth_it (JD {strd=SProd _, absd=a}) = someCompUsed a - worth_it (JD {strd=Str, absd=UProd _}) = True + worth_it (JD {strd=Str (SProd {}), absd=Use _ a}) = some_comp_used a + worth_it (JD {strd=Str HeadStr, absd=Use _ UProd {}}) = True -- second component points out that at least some of - worth_it _ = False + worth_it _ = False + + some_comp_used Used = True + some_comp_used (UProd _ ) = True + some_comp_used _ = False + + \end{code} Note [Worthy functions for Worker-Wrapper split] @@ -823,6 +1006,8 @@ bothDmdType (DmdType fv1 ds1 r1) (DmdType fv2 _ r2) both_fv1 = modifyEnv (isBotRes r1) (`bothDmd` botDmd) fv2 fv1 both_fv both_fv2 = modifyEnv (isBotRes r2) (`bothDmd` botDmd) fv1 fv2 both_fv1 +bothDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv +bothDmdEnv = plusVarEnv_C bothDmd instance Outputable DmdType where ppr (DmdType fv ds res) @@ -846,8 +1031,8 @@ cprProdDmdType = DmdType emptyDmdEnv [] cprProdRes isTopDmdType :: DmdType -> Bool isTopDmdType (DmdType env [] res) - | isTopRes res && isEmptyVarEnv env = True -isTopDmdType _ = False + | isTopRes res && isEmptyVarEnv env = True +isTopDmdType _ = False mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType mkDmdType fv ds res = DmdType fv ds res @@ -869,11 +1054,29 @@ splitDmdTy :: DmdType -> (Demand, DmdType) splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) splitDmdTy ty@(DmdType _ [] res_ty) = (resTypeArgDmd res_ty, ty) +deferAndUse :: Bool -- Lazify (defer) the type + -> Count -- Many => manify the type + -> DmdType -> DmdType +deferAndUse True Many ty = deferType (useType ty) +deferAndUse False Many ty = useType ty +deferAndUse True One ty = deferType ty +deferAndUse False One ty = ty + deferType :: DmdType -> DmdType +-- deferType ty1 == ty1 `lubType` DT { v -> <L,A> } [] top } +-- Ie it might be used, or not deferType (DmdType fv _ _) = DmdType (deferEnv fv) [] topRes deferEnv :: DmdEnv -> DmdEnv -deferEnv fv = mapVarEnv defer fv +deferEnv fv = mapVarEnv deferDmd fv + +useType :: DmdType -> DmdType +-- useType ty1 == ty1 `bothType` ty1 +-- NB that bothType is assymetrical, so no-op on argument demands +useType (DmdType fv ds res_ty) = DmdType (useEnv fv) ds res_ty + +useEnv :: DmdEnv -> DmdEnv +useEnv fv = mapVarEnv useDmd fv modifyEnv :: Bool -- No-op if False -> (Demand -> Demand) -- The zapper @@ -889,8 +1092,73 @@ modifyEnv need_to_modify zapper env1 env2 env where current_val = expectJust "modifyEnv" (lookupUFM_Directly env uniq) +strictenDmd :: JointDmd -> CleanDemand +strictenDmd (JD {strd = s, absd = u}) + = CD { sd = poke_s s, ud = poke_u u } + where + poke_s Lazy = HeadStr + poke_s (Str s) = s + poke_u Abs = UHead + poke_u (Use _ u) = u + +toCleanDmd :: (CleanDemand -> e -> (DmdType, e)) + -> Demand + -> e -> (DmdType, e) +-- See Note [Analyzing with lazy demand and lambdas] +toCleanDmd anal (JD { strd = s, absd = u }) e + = case (s,u) of + (_, Abs) -> mf (const topDmdType) (anal (CD { sd = HeadStr, ud = Used }) e) + -- See Note [Always analyse in virgin pass] + + (Str s', Use c u') -> mf (deferAndUse False c) (anal (CD { sd = s', ud = u' }) e) + (Lazy, Use c u') -> mf (deferAndUse True c) (anal (CD { sd = HeadStr, ud = u' }) e) + where + mf f (a,b) = (f a, b) \end{code} +Note [Always analyse in virgin pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Tricky point: make sure that we analyse in the 'virgin' pass. Consider + rec { f acc x True = f (...rec { g y = ...g... }...) + f acc x False = acc } +In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type. +That might mean that we analyse the sub-expression containing the +E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse* +E, but just retuned botType. + +Then in the *next* (non-virgin) iteration for 'f', we might analyse E +in a weaker demand, and that will trigger doing a fixpoint iteration +for g. But *because it's not the virgin pass* we won't start g's +iteration at bottom. Disaster. (This happened in $sfibToList' of +nofib/spectral/fibheaps.) + +So in the virgin pass we make sure that we do analyse the expression +at least once, to initialise its signatures. + +Note [Analyzing with lazy demand and lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The insight for analyzing lambdas follows from the fact that for +strictness S = C(L). This polymorphic expansion is critical for +cardinality analysis of the following example: + +{-# NOINLINE build #-} +build g = (g (:) [], g (:) []) + +h c z = build (\x -> + let z1 = z ++ z + in if c + then \y -> x (y ++ z1) + else \y -> x (z1 ++ y)) + +One can see that `build` assigns to `g` demand <L,C(C1(U))>. +Therefore, when analyzing the lambda `(\x -> ...)`, we +expect each lambda \y -> ... to be annotated as "one-shot" +one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a +demand <C(C(..), C(C1(U))>. + +This is achieved by, first, converting the lazy demand L into the +strict S by the second clause of the analysis. + %************************************************************************ %* * Demand signatures @@ -905,8 +1173,9 @@ a demand on the Id into a DmdType, which gives 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 +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.) @@ -959,42 +1228,85 @@ botSig = StrictSig botDmdType cprProdSig :: StrictSig cprProdSig = StrictSig cprProdDmdType -dmdTransformSig :: StrictSig -> Demand -> DmdType +argsOneShots :: StrictSig -> Arity -> [[Bool]] +argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args + | arg_ds `lengthExceeds` n_val_args + = [] -- Too few arguments + | otherwise + = go arg_ds + where + go [] = [] + go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds + + cons [] [] = [] + cons a as = a:as + +argOneShots :: JointDmd -> [Bool] +argOneShots (JD { absd = usg }) + = case usg of + Use _ arg_usg -> go arg_usg + _ -> [] + where + go (UCall One u) = True : go u + go (UCall Many u) = False : go u + go _ = [] + +dmdTransformSig :: StrictSig -> CleanDemand -> DmdType -- (dmdTransformSig fun_sig dmd) considers a call to a function whose -- signature is fun_sig, with demand dmd. We return the demand -- that the function places on its context (eg its args) -dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) dmd - = go arg_ds dmd +dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) + (CD { sd = str, ud = abs }) + = dmd_ty2 where - go [] dmd - | isBotDmd dmd = botDmdType -- Transform bottom demand to bottom type - | otherwise = dmd_ty -- Saturated - go (_:as) dmd = case peelCallDmd dmd of - Just dmd' -> go as dmd' - Nothing -> deferType dmd_ty - -- NB: it's important to use deferType, and not just return topDmdType - -- Consider let { f x y = p + x } in f 1 - -- The application isn't saturated, but we must nevertheless propagate - -- a lazy demand for p! - -dmdTransformDataConSig :: Arity -> StrictSig -> Demand -> DmdType + dmd_ty1 | str_sat = dmd_ty + | otherwise = deferType dmd_ty + dmd_ty2 | abs_sat = dmd_ty1 + | otherwise = useType dmd_ty1 + + str_sat = go_str arg_ds str + abs_sat = go_abs arg_ds abs + + go_str [] _ = True + go_str (_:_) HyperStr = True -- HyperStr = Call(HyperStr) + go_str (_:as) (SCall d') = go_str as d' + go_str _ _ = False + + go_abs [] _ = True + go_abs (_:as) (UCall One d') = go_abs as d' + go_abs _ _ = False + + -- NB: it's important to use deferType, and not just return topDmdType + -- Consider let { f x y = p + x } in f 1 + -- The application isn't saturated, but we must nevertheless propagate + -- a lazy demand for p! + +dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType -- Same as dmdTranformSig but for a data constructor (worker), -- which has a special kind of demand transformer. -- If the constructor is saturated, we feed the demand on -- the result into the constructor arguments. -dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res)) dmd - = go arity dmd - where - go 0 dmd = DmdType emptyDmdEnv (splitProdDmd arity dmd) con_res +dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res)) + (CD { sd = str, ud = abs }) + | Just str_dmds <- go_str arity str + , Just abs_dmds <- go_abs arity abs + = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) con_res -- Must remember whether it's a product, hence con_res, not TopRes - go n dmd = case peelCallDmd dmd of - Nothing -> topDmdType - Just dmd' -> go (n-1) dmd' + + | otherwise -- Not saturated + = topDmdType + where + go_str 0 dmd = Just (splitStrProdDmd arity dmd) + go_str n (SCall s') = go_str (n-1) s' + go_str _ _ = Nothing + + go_abs 0 dmd = Just (splitUseProdDmd arity dmd) + go_abs n (UCall One u') = go_abs (n-1) u' + go_abs _ _ = Nothing \end{code} Note [Non-full application] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - If a function having bottom as its demand result is applied to a less number of arguments than its syntactic arity, we cannot say for sure that it is going to diverge. This is the reason why we use the @@ -1003,7 +1315,6 @@ of arguments, says conservatively if the function is going to diverge or not. \begin{code} - -- appIsBottom returns true if an application to n args would diverge appIsBottom :: StrictSig -> Int -> Bool appIsBottom (StrictSig (DmdType _ ds res)) n @@ -1019,6 +1330,49 @@ pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) = hcat (map ppr dmds) <> ppr res \end{code} +Zap absence or one-shot information, under control of flags + +\begin{code} +zapDemand :: DynFlags -> Demand -> Demand +zapDemand dflags dmd + | Just kfs <- killFlags dflags = zap_dmd kfs dmd + | otherwise = dmd + +zapStrictSig :: DynFlags -> StrictSig -> StrictSig +zapStrictSig dflags sig@(StrictSig (DmdType env ds r)) + | Just kfs <- killFlags dflags = StrictSig (DmdType env (map (zap_dmd kfs) ds) r) + | otherwise = sig + +type KillFlags = (Bool, Bool) + +killFlags :: DynFlags -> Maybe KillFlags +killFlags dflags + | not kill_abs && not kill_one_shot = Nothing + | otherwise = Just (kill_abs, kill_one_shot) + where + kill_abs = gopt Opt_KillAbsence dflags + kill_one_shot = gopt Opt_KillOneShot dflags + +zap_dmd :: KillFlags -> Demand -> Demand +zap_dmd kfs (JD {strd = s, absd = u}) = JD {strd = s, absd = zap_musg kfs u} + +zap_musg :: KillFlags -> MaybeUsed -> MaybeUsed +zap_musg (kill_abs, _) Abs + | kill_abs = useTop + | otherwise = Abs +zap_musg kfs (Use c u) = Use (zap_count kfs c) (zap_usg kfs u) + +zap_count :: KillFlags -> Count -> Count +zap_count (_, kill_one_shot) c + | kill_one_shot = Many + | otherwise = c + +zap_usg :: KillFlags -> UseDmd -> UseDmd +zap_usg kfs (UCall c u) = UCall (zap_count kfs c) (zap_usg kfs u) +zap_usg kfs (UProd us) = UProd (map (zap_musg kfs) us) +zap_usg _ u = u +\end{code} + %************************************************************************ %* * @@ -1030,47 +1384,83 @@ pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) \begin{code} instance Binary StrDmd where put_ bh HyperStr = do putByte bh 0 - put_ bh Lazy = do putByte bh 1 - put_ bh Str = do putByte bh 2 - put_ bh (SCall s) = do putByte bh 3 + put_ bh HeadStr = do putByte bh 1 + put_ bh (SCall s) = do putByte bh 2 put_ bh s - put_ bh (SProd sx) = do putByte bh 4 + put_ bh (SProd sx) = do putByte bh 3 put_ bh sx get bh = do h <- getByte bh case h of - 0 -> do return strBot - 1 -> do return strTop - 2 -> do return strStr - 3 -> do s <- get bh - return $ strCall s + 0 -> do return HyperStr + 1 -> do return HeadStr + 2 -> do s <- get bh + return (SCall s) _ -> do sx <- get bh - return $ strProd sx + return (SProd sx) -instance Binary AbsDmd where - put_ bh Abs = do +instance Binary MaybeStr where + put_ bh Lazy = do + putByte bh 0 + put_ bh (Str s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> return Lazy + _ -> do s <- get bh + return $ Str s + +instance Binary Count where + put_ bh One = do putByte bh 0 + put_ bh Many = do putByte bh 1 + + get bh = do h <- getByte bh + case h of + 0 -> return One + _ -> return Many + +instance Binary MaybeUsed where + put_ bh Abs = do putByte bh 0 - put_ bh Used = do + put_ bh (Use c u) = do putByte bh 1 - put_ bh UHead = do + put_ bh c + put_ bh u + + get bh = do + h <- getByte bh + case h of + 0 -> return Abs + _ -> do c <- get bh + u <- get bh + return $ Use c u + +instance Binary UseDmd where + put_ bh Used = do + putByte bh 0 + put_ bh UHead = do + putByte bh 1 + put_ bh (UCall c u) = do putByte bh 2 - put_ bh (UCall u) = do - putByte bh 3 + put_ bh c put_ bh u - put_ bh (UProd ux) = do - putByte bh 4 + put_ bh (UProd ux) = do + putByte bh 3 put_ bh ux get bh = do h <- getByte bh case h of - 0 -> return absBot - 1 -> return absTop - 2 -> return absHead - 3 -> do u <- get bh - return $ absCall u + 0 -> return $ Used + 1 -> return $ UHead + 2 -> do c <- get bh + u <- get bh + return (UCall c u) _ -> do ux <- get bh - return $ absProd ux + return (UProd ux) instance Binary JointDmd where put_ bh (JD {strd = x, absd = y}) = do put_ bh x; put_ bh y @@ -1110,3 +1500,4 @@ instance Binary CPRResult where 2 -> return NoCPR _ -> return BotCPR \end{code} + diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 112664c1e2..14e29c1d99 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -35,7 +35,7 @@ module MkId ( wiredInIds, ghcPrimIds, unsafeCoerceName, unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId, lazyId, lazyIdKey, - coercionTokenId, + coercionTokenId, magicSingIId, -- Re-export error Ids module PrelRules @@ -136,7 +136,8 @@ ghcPrimIds realWorldPrimId, unsafeCoerceId, nullAddrId, - seqId + seqId, + magicSingIId ] \end{code} @@ -320,10 +321,10 @@ mkDictSelId dflags no_unf name clas strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] topRes) arg_dmd | new_tycon = evalDmd - | otherwise = mkProdDmd [ if the_arg_id == id then evalDmd else absDmd + | otherwise = mkManyUsedDmd $ + mkProdDmd [ if the_arg_id == id then evalDmd else absDmd | id <- arg_ids ] - tycon = classTyCon clas new_tycon = isNewTyCon tycon [data_con] = tyConDataCons tycon @@ -346,14 +347,13 @@ mkDictSelId dflags no_unf name clas -- varToCoreExpr needed for equality superclass selectors -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } -dictSelRule :: Int -> Arity - -> DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr +dictSelRule :: Int -> Arity -> RuleFun -- 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 (getNth con_args val_index) @@ -547,7 +547,7 @@ mkDataConRep dflags fam_envs wrap_name data_con initial_wrap_app = Var (dataConWorkId data_con) `mkTyApps` res_ty_args `mkVarApps` ex_tvs - `mkCoApps` map (mkReflCo . snd) eq_spec + `mkCoApps` map (mkReflCo Nominal . snd) eq_spec -- Dont box the eq_spec coercions since they are -- marked as HsUnpack by mk_dict_strict_mark @@ -823,7 +823,7 @@ wrapNewTypeBody tycon args result_expr wrapFamInstBody tycon args $ mkCast result_expr (mkSymCo co) where - co = mkUnbranchedAxInstCo (newTyConCo tycon) args + co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args -- When unwrapping, we do *not* apply any family coercion, because this will -- be done via a CoPat by the type checker. We have to do it this way as @@ -833,7 +833,7 @@ wrapNewTypeBody tycon args result_expr unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapNewTypeBody tycon args result_expr = ASSERT( isNewTyCon tycon ) - mkCast result_expr (mkUnbranchedAxInstCo (newTyConCo tycon) args) + mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args) -- 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 @@ -843,7 +843,7 @@ unwrapNewTypeBody tycon args result_expr wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr wrapFamInstBody tycon args body | Just co_con <- tyConFamilyCoercion_maybe tycon - = mkCast body (mkSymCo (mkUnbranchedAxInstCo co_con args)) + = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args)) | otherwise = body @@ -851,7 +851,7 @@ wrapFamInstBody tycon args body -- represented by a `CoAxiom`, and not a `TyCon` wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr wrapTypeFamInstBody axiom ind args body - = mkCast body (mkSymCo (mkAxInstCo axiom ind args)) + = mkCast body (mkSymCo (mkAxInstCo Representational axiom ind args)) wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr wrapTypeUnbranchedFamInstBody axiom @@ -860,13 +860,13 @@ wrapTypeUnbranchedFamInstBody axiom unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapFamInstScrut tycon args scrut | Just co_con <- tyConFamilyCoercion_maybe tycon - = mkCast scrut (mkUnbranchedAxInstCo co_con args) -- data instances only + = mkCast scrut (mkUnbranchedAxInstCo Representational co_con args) -- data instances only | otherwise = scrut unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr unwrapTypeFamInstScrut axiom ind args scrut - = mkCast scrut (mkAxInstCo axiom ind args) + = mkCast scrut (mkAxInstCo Representational axiom ind args) unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr unwrapTypeUnbranchedFamInstScrut axiom @@ -1023,13 +1023,14 @@ they can unify with both unlifted and lifted types. Hence we provide another gun with which to shoot yourself in the foot. \begin{code} -lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName, coercionTokenName :: Name +lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName, coercionTokenName, magicSingIName :: Name unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId +magicSingIName = mkWiredInIdName gHC_PRIM (fsLit "magicSingI") magicSingIKey magicSingIId \end{code} \begin{code} @@ -1082,8 +1083,7 @@ seqId = pcMiscPrelId seqName ty info , ru_try = match_seq_of_cast } -match_seq_of_cast :: DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr] - -> Maybe CoreExpr +match_seq_of_cast :: RuleFun -- See Note [Built-in RULES for seq] match_seq_of_cast _ _ _ [Type _, Type res_ty, Cast scrut co, expr] = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty, @@ -1096,6 +1096,15 @@ lazyId = pcMiscPrelId lazyIdName ty info where info = noCafIdInfo ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy) + + +-------------------------------------------------------------------------------- +magicSingIId :: Id -- See Note [magicSingIId magic] +magicSingIId = pcMiscPrelId magicSingIName ty info + where + info = noCafIdInfo `setInlinePragInfo` neverInlinePragma + ty = mkForAllTys [alphaTyVar] alphaTy + \end{code} Note [Unsafe coerce magic] @@ -1189,6 +1198,45 @@ 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. + +Note [magicSingIId magic] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +The identifier `magicSIngI` is just a place-holder, which is used to +implement a primitve that we cannot define in Haskell but we can write +in Core. It is declared with a place-holder type: + + magicSingI :: forall a. a + +The intention is that the identifier will be used in a very specific way, +namely we add the following to the library: + + withSingI :: Sing n -> (SingI n => a) -> a + withSingI x = magicSingI x ((\f -> f) :: () -> ()) + +The actual primitive is `withSingI`, and it uses its first argument +(of type `Sing n`) as the evidece/dictionary in the second argument. +This is done by adding a built-in rule to `prelude/PrelRules.hs` +(see `match_magicSingI`), which works as follows: + +magicSingI @ (Sing n -> (() -> ()) -> (SingI n -> a) -> a) + x + (\f -> _) + +----> + +\(f :: (SingI n -> a) -> a) -> f (cast x (newtypeCo n)) + +The `newtypeCo` coercion is extracted from the `SingI` type constructor, +which is available in the instantiation. We are casting `Sing n` into `SingI n`, +which is OK because `SingI` is a class with a single methid, +and thus it is implemented as newtype. + +The `(\f -> f)` parameter is there just so that we can avoid +having to make up a new name for the lambda, it is completely +changed by the rewrite. + + ------------------------------------------------------------- @realWorld#@ used to be a magic literal, \tr{void#}. If things get nasty as-is, change it back to a literal (@Literal@). diff --git a/compiler/basicTypes/MkId.lhs-boot b/compiler/basicTypes/MkId.lhs-boot index 201f977e3d..fe66599df2 100644 --- a/compiler/basicTypes/MkId.lhs-boot +++ b/compiler/basicTypes/MkId.lhs-boot @@ -9,6 +9,8 @@ data DataConBoxer mkDataConWorkId :: Name -> DataCon -> Id mkPrimOpId :: PrimOp -> Id + +magicSingIId :: Id \end{code} diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index e11262568e..55edc8d505 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -135,15 +135,19 @@ 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 +2. In any invocation of GHC, an External Name for "M.x" has one and only one + unique. This unique association is ensured via the Name Cache; + see Note [The Name Cache] in IfaceEnv. + +3. 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 +4. 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: +5. 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 @@ -272,6 +276,9 @@ mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) -- | Create a name which definitely originates in the given module mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name +-- WATCH OUT! External Names should be in the Name Cache +-- (see Note [The Name Cache] in IfaceEnv), so don't just call mkExternalName +-- with some fresh unique without populating the Name Cache mkExternalName uniq mod occ loc = Name { n_uniq = getKeyFastInt uniq, n_sort = External mod, n_occ = occ, n_loc = loc } diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index afdde7c996..2329e5f815 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -58,7 +58,8 @@ module OccName ( -- ** Derived 'OccName's isDerivedOccName, - mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, + mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, + mkGenDefMethodOcc, mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, @@ -481,18 +482,12 @@ 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! @@ -574,8 +569,8 @@ isDerivedOccName occ = \end{code} \begin{code} -mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, - mkDerivedTyConOcc, mkClassDataConOcc, mkDictOcc, +mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, + mkGenDefMethodOcc, mkDerivedTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, mkGenD, mkGenR, mkGen1R, mkGenRCo, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, @@ -623,7 +618,7 @@ 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 +-- data T = MkT ... deriving( Data ) needs definitions for -- $tT :: Data.Generics.Basics.DataType -- $cMkT :: Data.Generics.Basics.Constr mkDataTOcc = mk_simple_deriv varName "$t" diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index ff98923eb8..7bfe27dcaf 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -23,46 +23,39 @@ -- -- * 'Var.Var': see "Var#name_types" -{-# 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 RdrName ( -- * The main type - RdrName(..), -- Constructors exported only to BinIface + RdrName(..), -- Constructors exported only to BinIface - -- ** Construction - mkRdrUnqual, mkRdrQual, - mkUnqual, mkVarUnqual, mkQual, mkOrig, - nameRdrName, getRdrName, + -- ** Construction + mkRdrUnqual, mkRdrQual, + mkUnqual, mkVarUnqual, mkQual, mkOrig, + nameRdrName, getRdrName, - -- ** Destruction - rdrNameOcc, rdrNameSpace, setRdrNameSpace, demoteRdrName, - isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, - isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, + -- ** Destruction + rdrNameOcc, rdrNameSpace, setRdrNameSpace, demoteRdrName, + isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, + isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, - -- * Local mapping of 'RdrName' to 'Name.Name' - LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, - lookupLocalRdrEnv, lookupLocalRdrOcc, elemLocalRdrEnv, inLocalRdrEnvScope, + -- * Local mapping of 'RdrName' to 'Name.Name' + LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, + lookupLocalRdrEnv, lookupLocalRdrOcc, elemLocalRdrEnv, inLocalRdrEnvScope, localRdrEnvElts, delLocalRdrEnvList, - -- * Global mapping of 'RdrName' to 'GlobalRdrElt's - GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, - lookupGlobalRdrEnv, extendGlobalRdrEnv, - pprGlobalRdrEnv, globalRdrEnvElts, - lookupGRE_RdrName, lookupGRE_Name, getGRE_NameQualifier_maybes, + -- * Global mapping of 'RdrName' to 'GlobalRdrElt's + GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, + lookupGlobalRdrEnv, extendGlobalRdrEnv, + pprGlobalRdrEnv, globalRdrEnvElts, + lookupGRE_RdrName, lookupGRE_Name, getGRE_NameQualifier_maybes, transformGREs, findLocalDupsRdrEnv, pickGREs, - -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' - GlobalRdrElt(..), isLocalGRE, unQualOK, qualSpecOK, unQualSpecOK, - Provenance(..), pprNameProvenance, - Parent(..), - ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), - importSpecLoc, importSpecModule, isExplicitItem - ) where + -- ** 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" @@ -81,9 +74,9 @@ import Data.Data \end{code} %************************************************************************ -%* * +%* * \subsection{The main data type} -%* * +%* * %************************************************************************ \begin{code} @@ -91,41 +84,41 @@ import Data.Data -- 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' + -- ^ 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' + -- ^ 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' - + -- ^ 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' + -- ^ 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' deriving (Data, Typeable) \end{code} %************************************************************************ -%* * +%* * \subsection{Simple functions} -%* * +%* * %************************************************************************ \begin{code} @@ -159,9 +152,9 @@ setRdrNameSpace :: RdrName -> NameSpace -> RdrName 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)) +setRdrNameSpace (Exact n) ns = ASSERT( isExternalName n ) + Orig (nameModule n) + (setOccNameSpace ns (nameOccName n)) -- demoteRdrName lowers the NameSpace of RdrName. -- see Note [Demotion] in OccName @@ -173,7 +166,7 @@ demoteRdrName (Exact _) = panic "demoteRdrName" \end{code} \begin{code} - -- These two are the basic constructors + -- These two are the basic constructors mkRdrUnqual :: OccName -> RdrName mkRdrUnqual occ = Unqual occ @@ -184,8 +177,8 @@ mkOrig :: Module -> OccName -> RdrName mkOrig mod occ = Orig mod occ --------------- - -- These two are used when parsing source files - -- They do encode the module and occurrence names + -- 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) @@ -207,9 +200,9 @@ nameRdrName name = Exact name -- of Types (which are converted to IfaceTypes before printing) nukeExact :: Name -> RdrName -nukeExact n +nukeExact n | isExternalName n = Orig (nameModule n) (nameOccName n) - | otherwise = Unqual (nameOccName n) + | otherwise = Unqual (nameOccName n) \end{code} \begin{code} @@ -224,7 +217,7 @@ isRdrTc rn = isTcOcc (rdrNameOcc rn) isSrcRdrName :: RdrName -> Bool isSrcRdrName (Unqual _) = True isSrcRdrName (Qual _ _) = True -isSrcRdrName _ = False +isSrcRdrName _ = False isUnqual :: RdrName -> Bool isUnqual (Unqual _) = True @@ -232,19 +225,19 @@ isUnqual _ = False isQual :: RdrName -> Bool isQual (Qual _ _) = True -isQual _ = False +isQual _ = False isQual_maybe :: RdrName -> Maybe (ModuleName, OccName) isQual_maybe (Qual m n) = Just (m,n) -isQual_maybe _ = Nothing +isQual_maybe _ = Nothing isOrig :: RdrName -> Bool isOrig (Orig _ _) = True -isOrig _ = False +isOrig _ = False isOrig_maybe :: RdrName -> Maybe (Module, OccName) isOrig_maybe (Orig m n) = Just (m,n) -isOrig_maybe _ = Nothing +isOrig_maybe _ = Nothing isExact :: RdrName -> Bool isExact (Exact _) = True @@ -257,9 +250,9 @@ isExact_maybe _ = Nothing %************************************************************************ -%* * +%* * \subsection{Instances} -%* * +%* * %************************************************************************ \begin{code} @@ -272,21 +265,21 @@ instance Outputable RdrName where -- Note [Outputable Orig RdrName] in HscTypes instance OutputableBndr RdrName where - pprBndr _ n - | isTvOcc (rdrNameOcc n) = char '@' <+> ppr n - | otherwise = ppr n + pprBndr _ n + | isTvOcc (rdrNameOcc n) = char '@' <+> ppr n + | otherwise = ppr n pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - pprPrefixOcc rdr + pprPrefixOcc rdr | Just name <- isExact_maybe rdr = pprPrefixName name -- pprPrefixName has some special cases, so -- we delegate to them rather than reproduce them | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) instance Eq RdrName where - (Exact n1) == (Exact n2) = n1==n2 - -- Convert exact to orig - (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 + (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 @@ -296,38 +289,38 @@ instance Eq RdrName where 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 -> 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"; - -- <decl involving n1,n2> } - -- I think we can do without this conversion + 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"; + -- <decl involving n1,n2> } + -- 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 (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 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 + compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Orig _ _) _ = GT \end{code} %************************************************************************ -%* * - LocalRdrEnv -%* * +%* * + LocalRdrEnv +%* * %************************************************************************ \begin{code} @@ -335,7 +328,7 @@ instance Ord RdrName where -- It is keyed by OccName, because we never use it for qualified names -- We keep the current mapping, *and* the set of all Names in scope -- Reason: see Note [Splicing Exact Names] in RnEnv -type LocalRdrEnv = (OccEnv Name, NameSet) +type LocalRdrEnv = (OccEnv Name, NameSet) emptyLocalRdrEnv :: LocalRdrEnv emptyLocalRdrEnv = (emptyOccEnv, emptyNameSet) @@ -358,7 +351,7 @@ lookupLocalRdrOcc (env, _) occ = lookupOccEnv env occ elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool elemLocalRdrEnv rdr_name (env, _) | isUnqual rdr_name = rdrNameOcc rdr_name `elemOccEnv` env - | otherwise = False + | otherwise = False localRdrEnvElts :: LocalRdrEnv -> [Name] localRdrEnvElts (env, _) = occEnvElts env @@ -372,9 +365,9 @@ delLocalRdrEnvList (env, ns) occs = (delListFromOccEnv env occs, ns) \end{code} %************************************************************************ -%* * - GlobalRdrEnv -%* * +%* * + GlobalRdrEnv +%* * %************************************************************************ \begin{code} @@ -388,39 +381,39 @@ type GlobalRdrEnv = OccEnv [GlobalRdrElt] -- 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: 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] +-- 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 +data GlobalRdrElt = GRE { gre_name :: Name, - gre_par :: Parent, - gre_prov :: Provenance -- ^ Why it's in scope + 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. See Note [Parents] data Parent = NoParent | ParentIs Name - deriving (Eq) + deriving (Eq) {- Note [Parents] ~~~~~~~~~~~~~~~~~ Parent Children ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ data T Data constructors - Record-field ids + Record-field ids data family T Data constructors and record-field ids of all visible data instances of T - class C Class operations - Associated type constructors + class C Class operations + Associated type constructors Note [Combining parents] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -435,7 +428,7 @@ With an associated type we might have data T Bool = TBool Then: C is the parent of T - T is the parent of TInt and TBool + T is the parent of TInt and TBool So: in an export list C(..) is short for C( op, T ) T(..) is short for T( TInt, TBool ) @@ -444,16 +437,16 @@ Module M exports everything, so its exports will be AvailTC C [C,T,op] AvailTC T [T,TInt,TBool] On import we convert to GlobalRdrElt and the combine -those. For T that will mean we have +those. For T that will mean we have one GRE with Parent C one GRE with NoParent That's why plusParent picks the "best" case. --} +-} instance Outputable Parent where ppr NoParent = empty ppr (ParentIs n) = ptext (sLit "parent:") <> ppr n - + plusParent :: Parent -> Parent -> Parent -- See Note [Combining parents] @@ -463,7 +456,7 @@ plusParent _ _ = NoParent hasParent :: Name -> Parent -> Parent #ifdef DEBUG -hasParent n (ParentIs n') +hasParent n (ParentIs n') | n /= n' = pprPanic "hasParent" (ppr n <+> ppr n') -- Parents should agree #endif hasParent n _ = ParentIs n @@ -482,15 +475,15 @@ pprGlobalRdrEnv :: GlobalRdrEnv -> SDoc pprGlobalRdrEnv env = vcat (map pp (occEnvElts env)) where - pp gres = ppr (nameOccName (gre_name (head gres))) <> colon <+> - vcat (map ppr gres) + pp gres = ppr (nameOccName (gre_name (head gres))) <> colon <+> + vcat (map ppr gres) \end{code} \begin{code} lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of - Nothing -> [] - Just gres -> gres + Nothing -> [] + Just gres -> gres extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv extendGlobalRdrEnv env gre = extendOccEnv_Acc (:) singleton env occ gre @@ -500,13 +493,13 @@ extendGlobalRdrEnv env gre = extendOccEnv_Acc (:) singleton env occ gre lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] lookupGRE_RdrName rdr_name env = case lookupOccEnv env (rdrNameOcc rdr_name) of - Nothing -> [] - Just gres -> pickGREs rdr_name gres + 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 ] + gre_name gre == name ] getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] -- Returns all the qualifiers by which 'x' is in scope @@ -523,20 +516,20 @@ pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] -- Pick those GREs that are suitable for this RdrName -- And for those, keep only only the Provenances that are suitable -- Only used for Qual and Unqual, not Orig or Exact --- +-- -- Consider: -- -- @ --- module A ( f ) where --- import qualified Foo( f ) --- import Baz( f ) --- f = undefined +-- 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/ +-- 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 = ASSERT2( isSrcRdrName rdr_name, ppr rdr_name ) @@ -546,28 +539,28 @@ pickGREs rdr_name gres 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 - = [] + 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 @@ -585,26 +578,26 @@ mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv mkGlobalRdrEnv gres = foldr add emptyGlobalRdrEnv gres where - add gre env = extendOccEnv_Acc insertGRE singleton env - (nameOccName (gre_name gre)) - gre + add gre env = extendOccEnv_Acc insertGRE singleton env + (nameOccName (gre_name gre)) + gre findLocalDupsRdrEnv :: GlobalRdrEnv -> [OccName] -> [[Name]] -- ^ For each 'OccName', see if there are multiple local definitions -- for it; return a list of all such -- and return a list of the duplicate bindings -findLocalDupsRdrEnv rdr_env occs +findLocalDupsRdrEnv rdr_env occs = go rdr_env [] occs where go _ dups [] = dups go rdr_env dups (occ:occs) = case filter isLocalGRE gres of - [] -> go rdr_env dups occs - [_] -> go rdr_env dups occs -- The common case - dup_gres -> go rdr_env' (map gre_name dup_gres : dups) occs + [] -> go rdr_env dups occs + [_] -> go rdr_env dups occs -- The common case + dup_gres -> go rdr_env' (map gre_name dup_gres : dups) occs where gres = lookupOccEnv rdr_env occ `orElse` [] - rdr_env' = delFromOccEnv rdr_env occ + rdr_env' = delFromOccEnv rdr_env occ -- The delFromOccEnv avoids repeating the same -- complaint twice, when occs itself has a duplicate -- which is a common case @@ -612,83 +605,83 @@ findLocalDupsRdrEnv rdr_env occs 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 + | 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 } + gre_prov = gre_prov g1 `plusProv` gre_prov g2, + gre_par = gre_par g1 `plusParent` gre_par g2 } transformGREs :: (GlobalRdrElt -> GlobalRdrElt) - -> [OccName] + -> [OccName] -> GlobalRdrEnv -> GlobalRdrEnv -- ^ Apply a transformation function to the GREs for these OccNames transformGREs trans_gre occs rdr_env = foldr trans rdr_env occs where - trans occ env - = case lookupOccEnv env occ of + trans occ env + = case lookupOccEnv env occ of Just gres -> extendOccEnv env occ (map trans_gre gres) Nothing -> env \end{code} %************************************************************************ -%* * - Provenance -%* * +%* * + 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 + = 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 ) + 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! + 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 + 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 + = ImpAll -- ^ The import had no import list, + -- or had a hiding list | ImpSome { - is_explicit :: Bool, - is_iloc :: SrcSpan -- Location of the import item + 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. + -- 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? @@ -706,11 +699,11 @@ importSpecModule :: ImportSpec -> ModuleName importSpecModule is = is_mod (is_decl is) isExplicitItem :: ImpItemSpec -> Bool -isExplicitItem ImpAll = False +isExplicitItem ImpAll = False isExplicitItem (ImpSome {is_explicit = exp}) = exp -- Note [Comparing provenance] --- Comparison of provenance is just used for grouping +-- 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 @@ -722,15 +715,15 @@ 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) + 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) + 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 @@ -755,18 +748,18 @@ 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:_) | opt_PprStyle_Debug -> vcat (map pp_why whys) + (why:_) | opt_PprStyle_Debug -> vcat (map pp_why whys) | otherwise -> pp_why why - [] -> panic "pprNameProvenance" + [] -> panic "pprNameProvenance" where pp_why why = sep [ppr why, ppr_defn_site why name] -- 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_site :: ImportSpec -> Name -> SDoc -ppr_defn_site imp_spec name +ppr_defn_site imp_spec name | same_module && not (isGoodSrcSpan loc) - = empty -- Nothing interesting to say + = empty -- Nothing interesting to say | otherwise = parens $ hang (ptext (sLit "and originally defined") <+> pp_mod) 2 (pprLoc loc) @@ -780,9 +773,9 @@ ppr_defn_site imp_spec name instance Outputable ImportSpec where ppr imp_spec - = ptext (sLit "imported") <+> qual + = ptext (sLit "imported") <+> qual <+> ptext (sLit "from") <+> quotes (ppr (importSpecModule imp_spec)) - <+> pprLoc (importSpecLoc imp_spec) + <+> pprLoc (importSpecLoc imp_spec) where qual | is_qual (is_decl imp_spec) = ptext (sLit "qualified") | otherwise = empty diff --git a/compiler/basicTypes/UniqSupply.lhs b/compiler/basicTypes/UniqSupply.lhs index f3fb28ac21..0c6007a4f7 100644 --- a/compiler/basicTypes/UniqSupply.lhs +++ b/compiler/basicTypes/UniqSupply.lhs @@ -81,7 +81,7 @@ mkSplitUniqSupply c -- This is one of the most hammered bits in the whole compiler mk_supply = unsafeDupableInterleaveIO ( - genSymZh >>= \ u_ -> case iUnbox u_ of { u -> ( + genSym >>= \ u_ -> case iUnbox u_ of { u -> ( mk_supply >>= \ s1 -> mk_supply >>= \ s2 -> return (MkSplitUniqSupply (mask `bitOrFastInt` u) s1 s2) @@ -89,7 +89,7 @@ mkSplitUniqSupply c in mk_supply -foreign import ccall unsafe "genSymZh" genSymZh :: IO Int +foreign import ccall unsafe "genSym" genSym :: IO Int splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2 @@ -176,6 +176,10 @@ class Monad m => MonadUnique m where -- | Get an infinite list of new unique identifiers getUniquesM :: m [Unique] + -- This default definition of getUniqueM, while correct, is not as + -- efficient as it could be since it needlessly generates and throws away + -- an extra Unique. For your instances consider providing an explicit + -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly. getUniqueM = liftM uniqFromSupply getUniqueSupplyM getUniquesM = liftM uniqsFromSupply getUniqueSupplyM @@ -185,8 +189,8 @@ instance MonadUnique UniqSM where getUniquesM = getUniquesUs getUniqueUs :: UniqSM Unique -getUniqueUs = USM (\us -> case splitUniqSupply us of - (us1,us2) -> (# uniqFromSupply us1, us2 #)) +getUniqueUs = USM (\us -> case takeUniqFromSupply us of + (u,us') -> (# u, us' #)) getUniquesUs :: UniqSM [Unique] getUniquesUs = USM (\us -> case splitUniqSupply us of diff --git a/compiler/basicTypes/VarSet.lhs b/compiler/basicTypes/VarSet.lhs index 5c71db99cc..2c334d40a1 100644 --- a/compiler/basicTypes/VarSet.lhs +++ b/compiler/basicTypes/VarSet.lhs @@ -24,7 +24,7 @@ module VarSet ( isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, minusVarSet, foldVarSet, filterVarSet, fixVarSet, lookupVarSet, mapVarSet, sizeVarSet, seqVarSet, - elemVarSetByKey + elemVarSetByKey, partitionVarSet ) where #include "HsVersions.h" @@ -72,6 +72,7 @@ extendVarSet_C :: (Var->Var->Var) -> VarSet -> Var -> VarSet delVarSetByKey :: VarSet -> Unique -> VarSet elemVarSetByKey :: Unique -> VarSet -> Bool fixVarSet :: (VarSet -> VarSet) -> VarSet -> VarSet +partitionVarSet :: (Var -> Bool) -> VarSet -> (VarSet, VarSet) emptyVarSet = emptyUniqSet unitVarSet = unitUniqSet @@ -102,6 +103,7 @@ filterVarSet = filterUniqSet extendVarSet_C = addOneToUniqSet_C delVarSetByKey = delOneFromUniqSet_Directly elemVarSetByKey = elemUniqSet_Directly +partitionVarSet = partitionUniqSet \end{code} \begin{code} diff --git a/compiler/cbits/genSym.c b/compiler/cbits/genSym.c new file mode 100644 index 0000000000..2d9779b898 --- /dev/null +++ b/compiler/cbits/genSym.c @@ -0,0 +1,9 @@ + +#include "Rts.h" + +static HsInt GenSymCounter = 0; + +HsInt genSym(void) { + return GenSymCounter++; +} + diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 8fe8c3c874..1b86f3d6b4 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -398,13 +398,13 @@ mkConEntryLabel name c = IdLabel name c ConEntry mkStaticConEntryLabel name c = IdLabel name c StaticConEntry -- Constructing Cmm Labels -mkSplitMarkerLabel, mkDirty_MUT_VAR_Label, mkUpdInfoLabel, +mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel, mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel, mkMAP_FROZEN_infoLabel, mkMAP_DIRTY_infoLabel, mkEMPTY_MVAR_infoLabel, mkTopTickyCtrLabel, mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel :: CLabel +mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkSplitMarkerLabel = CmmLabel rtsPackageId (fsLit "__stg_split_marker") CmmCode -mkDirty_MUT_VAR_Label = CmmLabel rtsPackageId (fsLit "dirty_MUT_VAR") CmmCode mkUpdInfoLabel = CmmLabel rtsPackageId (fsLit "stg_upd_frame") CmmInfo mkBHUpdInfoLabel = CmmLabel rtsPackageId (fsLit "stg_bh_upd_frame" ) CmmInfo mkIndStaticInfoLabel = CmmLabel rtsPackageId (fsLit "stg_IND_STATIC") CmmInfo @@ -837,13 +837,13 @@ idInfoLabelType info = -- @labelDynamic@ returns @True@ if the label is located -- in a DLL, be it a data reference or not. -labelDynamic :: DynFlags -> PackageId -> CLabel -> Bool -labelDynamic dflags this_pkg lbl = +labelDynamic :: DynFlags -> PackageId -> Module -> CLabel -> Bool +labelDynamic dflags this_pkg this_mod lbl = case lbl of -- is the RTS in a DLL or not? RtsLabel _ -> not (gopt Opt_Static dflags) && (this_pkg /= rtsPackageId) - IdLabel n _ _ -> isDllName dflags this_pkg n + IdLabel n _ _ -> isDllName dflags this_pkg this_mod n -- When compiling in the "dyn" way, each package is to be linked into -- its own shared library. @@ -1030,9 +1030,9 @@ pprCLbl (RtsLabel (RtsApFast str)) = ftext 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")) + ptext (if upd_reqd + then (sLit "_upd_info") + else (sLit "_noupd_info")) ] pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset)) diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index 1546dd4a60..eeca0b4a54 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -70,10 +70,10 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments) float = case (w, regs) of (W32, (vs, fs, ds, ls, s:ss)) -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss)) (W32, (vs, f:fs, ds, ls, ss)) - | not hasSseRegs -> k (RegisterParam f, (vs, fs, ds, ls, ss)) + | not hasXmmRegs -> k (RegisterParam f, (vs, fs, ds, ls, ss)) (W64, (vs, fs, ds, ls, s:ss)) -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss)) (W64, (vs, fs, d:ds, ls, ss)) - | not hasSseRegs -> k (RegisterParam d, (vs, fs, ds, ls, ss)) + | not hasXmmRegs -> k (RegisterParam d, (vs, fs, ds, ls, ss)) (W80, _) -> panic "F80 unsupported register type" _ -> (assts, (r:rs)) int = case (w, regs) of @@ -88,7 +88,7 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments) w = typeWidth ty gcp | isGcPtrType ty = VGcPtr | otherwise = VNonGcPtr - hasSseRegs = mAX_Real_SSE_REG dflags /= 0 + hasXmmRegs = mAX_Real_XMM_REG dflags /= 0 assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a] @@ -113,7 +113,7 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs. , [GlobalReg] -- floats , [GlobalReg] -- doubles , [GlobalReg] -- longs (int64 and word64) - , [Int] -- SSE (floats and doubles) + , [Int] -- XMM (floats and doubles) ) -- Vanilla registers can contain pointers, Ints, Chars. @@ -128,7 +128,7 @@ getRegsWithoutNode dflags = , realFloatRegs dflags , realDoubleRegs dflags , realLongRegs dflags - , sseRegNos dflags) + , realXmmRegNos dflags) -- getRegsWithNode uses R1/node even if it isn't a register getRegsWithNode dflags = @@ -138,28 +138,27 @@ getRegsWithNode dflags = , realFloatRegs dflags , realDoubleRegs dflags , realLongRegs dflags - , sseRegNos dflags) + , realXmmRegNos dflags) allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg] allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg] -allSseRegs :: DynFlags -> [Int] +allXmmRegs :: DynFlags -> [Int] allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags) allFloatRegs dflags = map FloatReg $ regList (mAX_Float_REG dflags) allDoubleRegs dflags = map DoubleReg $ regList (mAX_Double_REG dflags) allLongRegs dflags = map LongReg $ regList (mAX_Long_REG dflags) -allSseRegs dflags = regList (mAX_SSE_REG dflags) +allXmmRegs dflags = regList (mAX_XMM_REG dflags) realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg] realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg] +realXmmRegNos :: DynFlags -> [Int] realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags) realFloatRegs dflags = map FloatReg $ regList (mAX_Real_Float_REG dflags) realDoubleRegs dflags = map DoubleReg $ regList (mAX_Real_Double_REG dflags) realLongRegs dflags = map LongReg $ regList (mAX_Real_Long_REG dflags) - -sseRegNos :: DynFlags -> [Int] -sseRegNos dflags =regList (mAX_SSE_REG dflags) +realXmmRegNos dflags = regList (mAX_Real_XMM_REG dflags) regList :: Int -> [Int] regList n = [1 .. n] @@ -169,7 +168,7 @@ allRegs dflags = (allVanillaRegs dflags, allFloatRegs dflags, allDoubleRegs dflags, allLongRegs dflags, - allSseRegs dflags) + allXmmRegs dflags) nodeOnly :: AvailRegs nodeOnly = ([VanillaReg 1], [], [], [], []) @@ -187,7 +186,7 @@ globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++ -- only use this functionality in hand-written C-- code in the RTS. realArgRegsCover :: DynFlags -> [GlobalReg] realArgRegsCover dflags - | hasSseRegs = map ($VGcPtr) (realVanillaRegs dflags) ++ + | hasXmmRegs = map ($VGcPtr) (realVanillaRegs dflags) ++ realDoubleRegs dflags ++ realLongRegs dflags | otherwise = map ($VGcPtr) (realVanillaRegs dflags) ++ @@ -195,4 +194,4 @@ realArgRegsCover dflags realDoubleRegs dflags ++ realLongRegs dflags where - hasSseRegs = mAX_Real_SSE_REG dflags /= 0 + hasXmmRegs = mAX_Real_XMM_REG dflags /= 0 diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs index 6312fb9c50..34e22cecfb 100644 --- a/compiler/cmm/CmmCommonBlockElim.hs +++ b/compiler/cmm/CmmCommonBlockElim.hs @@ -96,7 +96,7 @@ hash_block block = hash_node (CmmBranch _) = 23 -- NB. ignore the label hash_node (CmmCondBranch p _ _) = hash_e p hash_node (CmmCall e _ _ _ _ _) = hash_e e - hash_node (CmmForeignCall t _ _ _ _ _) = hash_tgt t + hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t hash_node (CmmSwitch e _) = hash_e e hash_reg :: CmmReg -> Word32 diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index a48d48742d..2b2dccdaed 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -6,13 +6,13 @@ module CmmLayoutStack ( import StgCmmUtils ( callerSaveVolatileRegs ) -- XXX layering violation import StgCmmForeign ( saveThreadState, loadThreadState ) -- XXX layering violation +import BasicTypes import Cmm import CmmInfo import BlockId import CLabel import CmmUtils import MkGraph -import Module import ForeignCall import CmmLive import CmmProcPoint @@ -264,7 +264,7 @@ collectContInfo blocks CmmCall { cml_cont = Just l, .. } -> (Just (l, cml_ret_args), cml_ret_off) CmmForeignCall { .. } - -> (Just (succ, 0), updfr) -- ?? + -> (Just (succ, ret_args), ret_off) _other -> (Nothing, 0) @@ -346,8 +346,8 @@ handleLastNode dflags procpoints liveness cont_info stackmaps return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off CmmForeignCall{ succ = cont_lbl, .. } -> do - return $ lastCall cont_lbl (wORD_SIZE dflags) (wORD_SIZE dflags) (sm_ret_off stack0) - -- one word each for args and results: the return address + return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off + -- one word of args: the return address CmmBranch{..} -> handleBranches CmmCondBranch{..} -> handleBranches @@ -932,9 +932,10 @@ lowerSafeForeignCall dflags block caller_load <*> loadThreadState dflags load_tso load_stack - (ret_args, regs, copyout) = copyOutOflow dflags NativeReturn Jump (Young succ) - (map (CmmReg . CmmLocal) res) - updfr [] + (_, regs, copyout) = + copyOutOflow dflags NativeReturn Jump (Young succ) + (map (CmmReg . CmmLocal) res) + ret_off [] -- NB. after resumeThread returns, the top-of-stack probably contains -- the stack frame for succ, but it might not: if the current thread @@ -947,7 +948,7 @@ lowerSafeForeignCall dflags block , cml_args_regs = regs , cml_args = widthInBytes (wordWidth dflags) , cml_ret_args = ret_args - , cml_ret_off = updfr } + , cml_ret_off = ret_off } graph' <- lgraphOfAGraph $ suspend <*> midCall <*> @@ -965,7 +966,7 @@ lowerSafeForeignCall dflags block foreignLbl :: FastString -> CmmExpr -foreignLbl name = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name)) +foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction)) newTemp :: CmmType -> UniqSM LocalReg newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep) diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index da7b094643..92a137b98b 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -178,7 +178,7 @@ lintCmmLast labels node = case node of _ <- lintCmmExpr target maybe (return ()) checkTarget cont - CmmForeignCall tgt _ args succ _ _ -> do + CmmForeignCall tgt _ args succ _ _ _ -> do lintTarget tgt mapM_ lintCmmExpr args checkTarget succ diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index fae84e5d53..8d42bbd2cb 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -529,6 +529,7 @@ data CallishMachOp | MO_Memmove | MO_PopCnt Width + | MO_BSwap Width deriving (Eq, Show) pprCallishMachOp :: CallishMachOp -> SDoc diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs index 61c0b80179..47811bcd7f 100644 --- a/compiler/cmm/CmmNode.hs +++ b/compiler/cmm/CmmNode.hs @@ -4,13 +4,6 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -{-# 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 CmmNode ( CmmNode(..), CmmFormal, CmmActual, UpdFrameOffset, Convention(..), @@ -50,13 +43,13 @@ data CmmNode e x where -- Assign to memory location. Size is -- given by cmmExprType of the rhs. - CmmUnsafeForeignCall :: -- An unsafe foreign call; - -- see Note [Foreign calls] - -- Like a "fat machine instruction"; can occur - -- in the middle of a block - ForeignTarget -> -- call target - [CmmFormal] -> -- zero or more results - [CmmActual] -> -- zero or more arguments + CmmUnsafeForeignCall :: -- An unsafe foreign call; + -- see Note [Foreign calls] + -- Like a "fat machine instruction"; can occur + -- in the middle of a block + ForeignTarget -> -- call target + [CmmFormal] -> -- zero or more results + [CmmActual] -> -- zero or more arguments CmmNode O O -- Semantics: clobbers any GlobalRegs for which callerSaves r == True -- See Note [foreign calls clobber GlobalRegs] @@ -124,12 +117,13 @@ data CmmNode e x where } -> CmmNode O C CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls] - -- Always the last node of a block + -- Always the last node of a block tgt :: ForeignTarget, -- call target and convention res :: [CmmFormal], -- zero or more results args :: [CmmActual], -- zero or more arguments; see Note [Register parameter passing] succ :: ULabel, -- Label of continuation - updfr :: UpdFrameOffset, -- where the update frame is (for building infotable) + ret_args :: ByteOff, -- same as cml_ret_args + ret_off :: ByteOff, -- same as cml_ret_off intrbl:: Bool -- whether or not the call is interruptible } -> CmmNode O C @@ -143,14 +137,14 @@ instruction". In particular, they do *not* kill all live registers, just the registers they return to (there was a bit of code in GHC that conservatively assumed otherwise.) However, see [Register parameter passing]. -Safe ones are trickier. A safe foreign call +Safe ones are trickier. A safe foreign call r = f(x) ultimately expands to - push "return address" -- Never used to return to; - -- just points an info table + push "return address" -- Never used to return to; + -- just points an info table save registers into TSO call suspendThread - r = f(x) -- Make the call + r = f(x) -- Make the call call resumeThread restore registers pop "return address" @@ -354,7 +348,7 @@ instance DefinerOfRegs GlobalReg (CmmNode e x) where ----------------------------------- -- mapping Expr in CmmNode -mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget +mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c mapForeignTarget _ m@(PrimTarget _) = m @@ -374,7 +368,7 @@ mapExp _ l@(CmmBranch _) = l mapExp f (CmmCondBranch e ti fi) = CmmCondBranch (f e) ti fi mapExp f (CmmSwitch e tbl) = CmmSwitch (f e) tbl mapExp f n@CmmCall {cml_target=tgt} = n{cml_target = f tgt} -mapExp f (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ updfr intrbl +mapExp f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x mapExpDeep f = mapExp $ wrapRecExp f @@ -404,10 +398,10 @@ mapExpM f (CmmUnsafeForeignCall tgt fs as) = case mapForeignTargetM f tgt of Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as)) Nothing -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as -mapExpM f (CmmForeignCall tgt fs as succ updfr intrbl) +mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = case mapForeignTargetM f tgt of - Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ updfr intrbl) - Nothing -> (\xs -> CmmForeignCall tgt fs xs succ updfr intrbl) `fmap` mapListM f as + Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl) + Nothing -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as -- share as much as possible mapListM :: (a -> Maybe a) -> [a] -> Maybe [a] @@ -430,7 +424,7 @@ mapExpDeepM f = mapExpM $ wrapRecExpM f ----------------------------------- -- folding Expr in CmmNode -foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z +foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z foldExpForeignTarget exp (ForeignTarget e _) z = exp e z foldExpForeignTarget _ (PrimTarget _) z = z diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index cb3bf0c829..8c36deafbb 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -557,7 +557,7 @@ stmt :: { CmmParse () } -- we tweak the syntax to avoid the conflict. The later -- option is taken here because the other way would require -- multiple levels of expanding and get unwieldy. - | foreign_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety opt_never_returns ';' + | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';' {% foreignCall $3 $1 $4 $6 $8 $9 } | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';' {% primCall $1 $4 $6 } @@ -588,6 +588,9 @@ stmt :: { CmmParse () } | 'push' '(' exprs0 ')' maybe_body { pushStackFrame $3 $5 } +foreignLabel :: { CmmParse CmmExpr } + : NAME { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) } + opt_never_returns :: { CmmReturnInfo } : { CmmMayReturn } | 'never' 'returns' { CmmNeverReturns } @@ -1002,8 +1005,7 @@ stmtMacros = listToUFM [ tickyAllocPAP goods slop ), ( fsLit "TICK_ALLOC_UP_THK", \[goods,slop] -> tickyAllocThunk goods slop ), - ( fsLit "UPD_BH_UPDATABLE", \[reg] -> emitBlackHoleCode False reg ), - ( fsLit "UPD_BH_SINGLE_ENTRY", \[reg] -> emitBlackHoleCode True reg ) + ( fsLit "UPD_BH_UPDATABLE", \[reg] -> emitBlackHoleCode reg ) ] emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode () diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 5e9bca30e3..50d02de04e 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -70,7 +70,7 @@ cpsTop hsc_env proc = ----------- Eliminate common blocks ------------------------------------- g <- {-# SCC "elimCommonBlocks" #-} condPass Opt_CmmElimCommonBlocks elimCommonBlocks g - Opt_D_dump_cmm_cbe "Post common block elimination" + Opt_D_dump_cmm_cbe "Post common block elimination" -- Any work storing block Labels must be performed _after_ -- elimCommonBlocks diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs index 2a080c2e58..9f8a3975e7 100644 --- a/compiler/cmm/CmmSink.hs +++ b/compiler/cmm/CmmSink.hs @@ -390,7 +390,7 @@ tryToInline dflags live node assigs = go usages node [] assigs occurs_once = not (l `elemRegSet` live) && lookupUFM usages l == Just 1 - inl_node = mapExpDeep inline node + inl_node = mapExpDeep inline node -- mapExpDeep is where the inlining actually takes place! where inline (CmmReg (CmmLocal l')) | l == l' = rhs inline (CmmRegOff (CmmLocal l') off) | l == l' = cmmOffset dflags rhs off diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index 78e5562d81..a5acffb2f7 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -424,7 +424,7 @@ ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyM insertBlock :: CmmBlock -> BlockEnv CmmBlock -> BlockEnv CmmBlock insertBlock block map = - ASSERT (isNothing $ mapLookup id map) + ASSERT(isNothing $ mapLookup id map) mapInsert id block map where id = entryLabel block diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 45c415f35a..b0c9bd3f2f 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -189,7 +189,6 @@ pprStmt stmt = rep = cmmExprType dflags src CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args -> - maybe_proto $$ fnCall where (res_hints, arg_hints) = foreignTargetHints target @@ -200,40 +199,29 @@ pprStmt stmt = cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn) - real_fun_proto lbl = char ';' <> - pprCFunType (ppr lbl) cconv hresults hargs <> - noreturn_attr <> semi - - noreturn_attr = case ret of - CmmNeverReturns -> text "__attribute__ ((noreturn))" - CmmMayReturn -> empty - -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes - (maybe_proto, fnCall) = + fnCall = case fn of CmmLit (CmmLabel lbl) | StdCallConv <- cconv -> - let myCall = pprCall (ppr lbl) cconv hresults hargs - in (real_fun_proto lbl, myCall) + pprCall (ppr lbl) cconv hresults hargs -- stdcall functions must be declared with -- a function type, otherwise the C compiler -- doesn't add the @n suffix to the label. We -- can't add the @n suffix ourselves, because -- it isn't valid C. | CmmNeverReturns <- ret -> - let myCall = pprCall (ppr lbl) cconv hresults hargs - in (real_fun_proto lbl, myCall) + pprCall cast_fn cconv hresults hargs <> semi | not (isMathFun lbl) -> pprForeignCall (ppr lbl) cconv hresults hargs _ -> - (empty {- no proto -}, - pprCall cast_fn cconv hresults hargs <> semi) + pprCall cast_fn cconv hresults hargs <> semi -- for a dynamic call, no declaration is necessary. CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty CmmUnsafeForeignCall target@(PrimTarget op) results args -> - proto $$ fn_call + fn_call where cconv = CCallConv fn = pprCallishMachOp_for_C op @@ -242,15 +230,16 @@ pprStmt stmt = hresults = zip results res_hints hargs = zip args arg_hints - (proto, fn_call) + fn_call -- The mem primops carry an extra alignment arg, must drop it. -- We could maybe emit an alignment directive using this info. -- We also need to cast mem primops to prevent conflicts with GCC -- builtins (see bug #5967). | op `elem` [MO_Memcpy, MO_Memset, MO_Memmove] - = pprForeignCall fn cconv hresults (init hargs) + = (ptext (sLit ";EF_(") <> fn <> char ')' <> semi) $$ + pprForeignCall fn cconv hresults (init hargs) | otherwise - = (empty, pprCall fn cconv hresults hargs) + = pprCall fn cconv hresults hargs CmmBranch ident -> pprBranch ident CmmCondBranch expr yes no -> pprCondBranch expr yes no @@ -263,8 +252,8 @@ pprStmt stmt = type Hinted a = (a, ForeignHint) pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] - -> (SDoc, SDoc) -pprForeignCall fn cconv results args = (proto, fn_call) + -> SDoc +pprForeignCall fn cconv results args = fn_call where fn_call = braces ( pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi @@ -272,7 +261,6 @@ pprForeignCall fn cconv results args = (proto, fn_call) $$ pprCall (text "ghcFunPtr") cconv results args <> semi ) cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn) - proto = ptext (sLit ";EF_(") <> fn <> char ')' <> semi pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc pprCFunType ppr_fn cconv ress args @@ -750,6 +738,7 @@ pprCallishMachOp_for_C mop MO_Memcpy -> ptext (sLit "memcpy") MO_Memset -> ptext (sLit "memset") MO_Memmove -> ptext (sLit "memmove") + (MO_BSwap w) -> ptext (sLit $ bSwapLabel w) (MO_PopCnt w) -> ptext (sLit $ popCntLabel w) (MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w) diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index f3e2a02737..46257b4188 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -247,14 +247,15 @@ pprNode node = pp_node <+> pp_debug | Just r <- k = ptext (sLit "returns to") <+> ppr r <> comma | otherwise = empty - CmmForeignCall {tgt=t, res=rs, args=as, succ=s, updfr=u, intrbl=i} -> + CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} -> hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++ [ ptext (sLit "foreign call"), space , ppr t, ptext (sLit "(...)"), space , ptext (sLit "returns to") <+> ppr s <+> ptext (sLit "args:") <+> parens (ppr as) <+> ptext (sLit "ress:") <+> parens (ppr rs) - , ptext (sLit "upd:") <+> ppr u + , ptext (sLit "ret_args:") <+> ppr a + , ptext (sLit "ret_off:") <+> ppr u , semi ] pp_debug :: SDoc diff --git a/compiler/cmm/SMRep.lhs b/compiler/cmm/SMRep.lhs index 6f569ef6fa..c54f6d5f9d 100644 --- a/compiler/cmm/SMRep.lhs +++ b/compiler/cmm/SMRep.lhs @@ -16,6 +16,11 @@ module SMRep ( WordOff, ByteOff, roundUpToWords, +#if __GLASGOW_HASKELL__ > 706 + -- ** Immutable arrays of StgWords + UArrayStgWord, listArray, toByteArray, +#endif + -- * Closure repesentation SMRep(..), -- CmmInfo sees the rep; no one else does IsStatic, @@ -49,8 +54,13 @@ import DynFlags import Outputable import Platform import FastString +import qualified Data.Array.Base as Array + +#if __GLASGOW_HASKELL__ > 706 +import GHC.Base ( ByteArray# ) +import Data.Ix +#endif -import Data.Array.Base import Data.Char( ord ) import Data.Word import Data.Bits @@ -80,7 +90,11 @@ newtype StgWord = StgWord Word64 #if __GLASGOW_HASKELL__ < 706 Num, #endif - Bits, IArray UArray) + +#if __GLASGOW_HASKELL__ <= 706 + Array.IArray Array.UArray, +#endif + Bits) fromStgWord :: StgWord -> Integer fromStgWord (StgWord i) = toInteger i @@ -125,6 +139,30 @@ hALF_WORD_SIZE_IN_BITS :: DynFlags -> Int hALF_WORD_SIZE_IN_BITS dflags = platformWordSize (targetPlatform dflags) `shiftL` 2 \end{code} +%************************************************************************ +%* * + Immutable arrays of StgWords +%* * +%************************************************************************ + +\begin{code} + +#if __GLASGOW_HASKELL__ > 706 +-- TODO: Improve with newtype coercions! + +newtype UArrayStgWord i = UArrayStgWord (Array.UArray i Word64) + +listArray :: Ix i => (i, i) -> [StgWord] -> UArrayStgWord i +listArray (i,j) words + = UArrayStgWord $ Array.listArray (i,j) (map unStgWord words) + where unStgWord (StgWord w64) = w64 + +toByteArray :: UArrayStgWord i -> ByteArray# +toByteArray (UArrayStgWord (Array.UArray _ _ _ b)) = b + +#endif + +\end{code} %************************************************************************ %* * diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 6098e615ae..8b3bac3b4f 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -50,12 +50,12 @@ import Control.Monad (when,void) import Util codeGen :: DynFlags - -> Module - -> [TyCon] - -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. - -> [StgBinding] -- Bindings to convert - -> HpcInfo - -> Stream IO CmmGroup () -- Output as a stream, so codegen can + -> Module + -> [TyCon] + -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. + -> [StgBinding] -- Bindings to convert + -> HpcInfo + -> Stream IO CmmGroup () -- Output as a stream, so codegen can -- be interleaved with output codeGen dflags this_mod data_tycons @@ -118,33 +118,33 @@ variable. -} cgTopBinding :: DynFlags -> StgBinding -> FCode () cgTopBinding dflags (StgNonRec id rhs) = do { id' <- maybeExternaliseId dflags id - ; (info, fcode) <- cgTopRhs NonRecursive id' rhs + ; let (info, fcode) = cgTopRhs dflags NonRecursive id' rhs ; fcode - ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt, - -- so we find it when we look up occurrences + ; addBindC info -- Add the *un-externalised* Id to the envt, + -- so we find it when we look up occurrences } cgTopBinding dflags (StgRec pairs) = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs ; let pairs' = zip bndrs' rhss - ; r <- sequence $ unzipWith (cgTopRhs Recursive) pairs' - ; let (infos, fcodes) = unzip r + r = unzipWith (cgTopRhs dflags Recursive) pairs' + (infos, fcodes) = unzip r ; addBindsC infos ; sequence_ fcodes } -cgTopRhs :: RecFlag -> Id -> StgRhs -> FCode (CgIdInfo, FCode ()) +cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ()) -- The Id is passed along for setting up a binding... -- It's already been externalised if necessary -cgTopRhs _rec bndr (StgRhsCon _cc con args) - = forkStatics (cgTopRhsCon bndr con args) +cgTopRhs dflags _rec bndr (StgRhsCon _cc con args) + = cgTopRhsCon dflags bndr con args -cgTopRhs rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body) +cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body) = ASSERT(null fvs) -- There should be no free variables - forkStatics (cgTopRhsClosure rec bndr cc bi upd_flag args body) + cgTopRhsClosure dflags rec bndr cc bi upd_flag args body --------------------------------------------------------------- @@ -178,13 +178,13 @@ cgTopRhs rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body) module in the program, and we don't want to require that this name has the version and way info appended to it. -We initialise the module tree by keeping a work-stack, +We initialise the module tree by keeping a work-stack, * pointed to by Sp * that grows downward * Sp points to the last occupied slot -} -mkModuleInit +mkModuleInit :: CollectedCCs -- cost centre info -> Module -> HpcInfo diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 0ba99aed36..ce5491dc10 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -22,7 +22,6 @@ import StgCmmCon import StgCmmHeap import StgCmmProf import StgCmmTicky -import StgCmmGran import StgCmmLayout import StgCmmUtils import StgCmmClosure @@ -58,22 +57,21 @@ import Control.Monad -- For closures bound at top level, allocate in static space. -- They should have no free variables. -cgTopRhsClosure :: RecFlag -- member of a recursive group? +cgTopRhsClosure :: DynFlags + -> RecFlag -- member of a recursive group? -> Id -> CostCentreStack -- Optional cost centre annotation -> StgBinderInfo -> UpdateFlag -> [Id] -- Args -> StgExpr - -> FCode (CgIdInfo, FCode ()) - -cgTopRhsClosure rec id ccs _ upd_flag args body - = do { dflags <- getDynFlags - ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args - ; let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) - cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label) - ; return (cg_id_info, gen_code dflags lf_info closure_label) - } + -> (CgIdInfo, FCode ()) + +cgTopRhsClosure dflags rec id ccs _ upd_flag args body = + let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) + cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label) + lf_info = mkClosureLFInfo dflags id TopLevel [] upd_flag args + in (cg_id_info, gen_code dflags lf_info closure_label) where -- special case for a indirection (f = g). We create an IND_STATIC -- closure pointing directly to the indirectee. This is exactly @@ -106,7 +104,7 @@ cgTopRhsClosure rec id ccs _ upd_flag args body caffy = idCafInfo id info_tbl = mkCmmInfo closure_info -- XXX short-cut closure_rep = mkStaticClosureFields dflags info_tbl ccs caffy [] - + -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) ; emitDataLits closure_label closure_rep ; let fv_details :: [(NonVoid Id, VirtualHpOffset)] @@ -115,7 +113,7 @@ cgTopRhsClosure rec id ccs _ upd_flag args body -- Don't drop the non-void args until the closure info has been made ; forkClosureBody (closureCodeBody True id closure_info ccs (nonVoidIds args) (length args) body fv_details) - + ; return () } unLit (CmmLit l) = l @@ -128,10 +126,9 @@ cgTopRhsClosure rec id ccs _ upd_flag args body cgBind :: StgBinding -> FCode () cgBind (StgNonRec name rhs) = do { (info, fcode) <- cgRhs name rhs - ; addBindC (cg_id info) info + ; addBindC info ; init <- fcode - ; emit init - } + ; emit init } -- init cannot be used in body, so slightly better to sink it eagerly cgBind (StgRec pairs) @@ -205,9 +202,10 @@ cgRhs :: Id ) cgRhs id (StgRhsCon cc con args) - = withNewTickyCounterThunk (idName id) $ + = withNewTickyCounterThunk False (idName id) $ -- False for "not static" buildDynCon id True cc con args +{- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -} cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body) = do dflags <- getDynFlags mkRhsClosure dflags name cc bi (nonVoidIds fvs) upd_flag args body @@ -316,8 +314,8 @@ mkRhsClosure dflags bndr _cc _bi arity = length fvs ---------- Default case ------------------ -mkRhsClosure _ bndr cc _ fvs upd_flag args body - = do { lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args +mkRhsClosure dflags bndr cc _ fvs upd_flag args body + = do { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args ; (id_info, reg) <- rhsIdInfo bndr lf_info ; return (id_info, gen_code lf_info reg) } where @@ -383,7 +381,7 @@ cgRhsStdThunk bndr lf_info payload } where gen_code reg -- AHA! A STANDARD-FORM THUNK - = withNewTickyCounterStdThunk (idName bndr) $ + = withNewTickyCounterStdThunk False (idName bndr) $ -- False for "not static" do { -- LAY OUT THE OBJECT mod_name <- getModuleName @@ -399,7 +397,7 @@ cgRhsStdThunk bndr lf_info payload -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body ; let use_cc = curCCS; blame_cc = curCCS - ; tickyEnterStdThunk + ; tickyEnterStdThunk closure_info -- BUILD THE OBJECT ; let info_tbl = mkCmmInfo closure_info @@ -410,21 +408,22 @@ cgRhsStdThunk bndr lf_info payload ; return (mkRhsInit dflags reg lf_info hp_plus_n) } -mkClosureLFInfo :: Id -- The binder +mkClosureLFInfo :: DynFlags + -> Id -- The binder -> TopLevelFlag -- True of top level -> [NonVoid Id] -- Free vars -> UpdateFlag -- Update flag -> [Id] -- Args - -> FCode LambdaFormInfo -mkClosureLFInfo bndr top fvs upd_flag args - | null args = return (mkLFThunk (idType bndr) top (map unsafe_stripNV fvs) upd_flag) + -> LambdaFormInfo +mkClosureLFInfo dflags bndr top fvs upd_flag args + | null args = + mkLFThunk (idType bndr) top (map unsafe_stripNV fvs) upd_flag | otherwise = - do { arg_descr <- mkArgDescr (idName bndr) args - ; return (mkLFReEntrant top (map unsafe_stripNV fvs) args arg_descr) } + mkLFReEntrant top (map unsafe_stripNV fvs) args (mkArgDescr dflags args) ------------------------------------------------------------------------ --- The code for closures} +-- The code for closures ------------------------------------------------------------------------ closureCodeBody :: Bool -- whether this is a top-level binding @@ -452,8 +451,7 @@ closureCodeBody :: Bool -- whether this is a top-level binding closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details | arity == 0 -- No args i.e. thunk - = ASSERT ( not (isStaticClosure cl_info) ) - withNewTickyCounterThunk (closureName cl_info) $ + = withNewTickyCounterThunk (isStaticClosure cl_info) (closureName cl_info) $ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $ \(_, node, _) -> thunkCode cl_info fv_details cc node arity body where @@ -478,7 +476,6 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details ; let node_points = nodeMustPointToIt dflags lf_info node' = if node_points then Just node else Nothing ; when node_points (ldvEnterClosure cl_info) - ; granYield arg_regs node_points -- Main payload ; entryHeapCheck cl_info node' arity arg_regs $ do @@ -542,14 +539,14 @@ thunkCode cl_info fv_details _cc node arity body ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info) node' = if node_points then Just node else Nothing ; ldvEnterClosure cl_info -- NB: Node always points when profiling - ; granThunk node_points -- Heap overflow check ; entryHeapCheck cl_info node' arity [] $ do { -- Overwrite with black hole if necessary -- but *after* the heap-overflow check + ; tickyEnterThunk cl_info ; when (blackHoleOnEntry cl_info && node_points) - (blackHoleIt cl_info node) + (blackHoleIt node) -- Push update frame ; setupUpdate cl_info node $ @@ -557,7 +554,7 @@ thunkCode cl_info fv_details _cc node arity body -- that cc of enclosing scope will be recorded -- in update frame CAF/DICT functions will be -- subsumed by this enclosing cc - do { tickyEnterThunk + do { tickyEnterThunk cl_info ; enterCostCentreThunk (CmmReg nodeReg) ; let lf_info = closureLFInfo cl_info ; fv_bindings <- mapM bind_fv fv_details @@ -569,20 +566,20 @@ thunkCode cl_info fv_details _cc node arity body -- Update and black-hole wrappers ------------------------------------------------------------------------ -blackHoleIt :: ClosureInfo -> LocalReg -> FCode () +blackHoleIt :: LocalReg -> FCode () -- Only called for closures with no args -- Node points to the closure -blackHoleIt closure_info node - = emitBlackHoleCode (closureSingleEntry closure_info) (CmmReg (CmmLocal node)) +blackHoleIt node_reg + = emitBlackHoleCode (CmmReg (CmmLocal node_reg)) -emitBlackHoleCode :: Bool -> CmmExpr -> FCode () -emitBlackHoleCode is_single_entry node = do +emitBlackHoleCode :: CmmExpr -> FCode () +emitBlackHoleCode node = do dflags <- getDynFlags -- Eager blackholing is normally disabled, but can be turned on with -- -feager-blackholing. When it is on, we replace the info pointer -- of the thunk with stg_EAGER_BLACKHOLE_info on entry. - + -- If we wanted to do eager blackholing with slop filling, we'd need -- to do it at the *end* of a basic block, otherwise we overwrite -- the free variables in the thunk that we still need. We have a @@ -593,7 +590,7 @@ emitBlackHoleCode is_single_entry node = do -- on. But it didn't work, and it wasn't strictly necessary to bring -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is -- unconditionally disabled. -- krc 1/2007 - + -- Note the eager-blackholing check is here rather than in blackHoleOnEntry, -- because emitBlackHoleCode is called from CmmParse. @@ -604,7 +601,6 @@ emitBlackHoleCode is_single_entry node = do -- work with profiling. when eager_blackholing $ do - tickyBlackHole (not is_single_entry) emitStore (cmmOffsetW dflags node (fixedHdrSize dflags)) (CmmReg (CmmGlobal CurrentTSO)) emitPrimCall [] MO_WriteBarrier [] @@ -615,7 +611,7 @@ setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- so that the cost centre in the original closure can still be -- extracted by a subsequent enterCostCentre setupUpdate closure_info node body - | closureReEntrant closure_info + | not (lfUpdatable (closureLFInfo closure_info)) = body | not (isStaticClosure closure_info) @@ -736,7 +732,7 @@ link_caf node _is_upd = do -- This must be done *before* the info table pointer is overwritten, -- because the old info table ptr is needed for reversion ; ret <- newTemp (bWord dflags) - ; emitRtsCallGen [(ret,NoHint)] rtsPackageId (fsLit "newCAF") + ; emitRtsCallGen [(ret,NoHint)] (mkForeignLabel (fsLit "newCAF") Nothing ForeignLabelInExternalPackage IsFunction) [ (CmmReg (CmmGlobal BaseReg), AddrHint), (CmmReg (CmmLocal node), AddrHint), (hp_rel, AddrHint) ] diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index a057484d39..611a570d70 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- -- Stg to C-- code generation: --- +-- -- The types LambdaFormInfo -- ClosureInfo -- @@ -10,25 +10,19 @@ ----------------------------------------------------------------------------- {-# LANGUAGE RecordWildCards #-} -{-# 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 StgCmmClosure ( DynTag, tagForCon, isSmallFamily, - ConTagZ, dataConTagZ, + ConTagZ, dataConTagZ, idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps, - argPrimRep, + argPrimRep, -- * LambdaFormInfo LambdaFormInfo, -- Abstract - StandardFormInfo, -- ...ditto... - mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, - mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, + StandardFormInfo, -- ...ditto... + mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, + mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, mkLFBlackHole, lfDynTag, maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable, @@ -39,7 +33,7 @@ module StgCmmClosure ( isKnownFun, funTag, tagForArity, -- * ClosureInfo - ClosureInfo, + ClosureInfo, mkClosureInfo, mkCmmInfo, @@ -91,7 +85,7 @@ import DynFlags import Util ----------------------------------------------------------------------------- --- Representations +-- Representations ----------------------------------------------------------------------------- -- Why are these here? @@ -119,7 +113,7 @@ isGcPtrRep _ = False ----------------------------------------------------------------------------- --- LambdaFormInfo +-- LambdaFormInfo ----------------------------------------------------------------------------- -- Information about an identifier, from the code generator's point of @@ -128,81 +122,81 @@ isGcPtrRep _ = False -- tail call or return that identifier. data LambdaFormInfo - = LFReEntrant -- Reentrant closure (a function) - TopLevelFlag -- True if top level - !RepArity -- Arity. Invariant: always > 0 - !Bool -- True <=> no fvs - ArgDescr -- Argument descriptor (should really be in ClosureInfo) - - | LFThunk -- Thunk (zero arity) - TopLevelFlag - !Bool -- True <=> no free vars - !Bool -- True <=> updatable (i.e., *not* single-entry) - StandardFormInfo - !Bool -- True <=> *might* be a function type - - | LFCon -- A saturated constructor application - DataCon -- The constructor - - | LFUnknown -- Used for function arguments and imported things. - -- We know nothing about this closure. - -- Treat like updatable "LFThunk"... - -- Imported things which we *do* know something about use - -- one of the other LF constructors (eg LFReEntrant for - -- known functions) - !Bool -- True <=> *might* be a function type - -- The False case is good when we want to enter it, - -- because then we know the entry code will do - -- For a function, the entry code is the fast entry point - - | LFUnLifted -- A value of unboxed type; - -- always a value, neeeds evaluation - - | LFLetNoEscape -- See LetNoEscape module for precise description - - | LFBlackHole -- Used for the closures allocated to hold the result - -- of a CAF. We want the target of the update frame to - -- be in the heap, so we make a black hole to hold it. + = LFReEntrant -- Reentrant closure (a function) + TopLevelFlag -- True if top level + !RepArity -- Arity. Invariant: always > 0 + !Bool -- True <=> no fvs + ArgDescr -- Argument descriptor (should really be in ClosureInfo) + + | LFThunk -- Thunk (zero arity) + TopLevelFlag + !Bool -- True <=> no free vars + !Bool -- True <=> updatable (i.e., *not* single-entry) + StandardFormInfo + !Bool -- True <=> *might* be a function type + + | LFCon -- A saturated constructor application + DataCon -- The constructor + + | LFUnknown -- Used for function arguments and imported things. + -- We know nothing about this closure. + -- Treat like updatable "LFThunk"... + -- Imported things which we *do* know something about use + -- one of the other LF constructors (eg LFReEntrant for + -- known functions) + !Bool -- True <=> *might* be a function type + -- The False case is good when we want to enter it, + -- because then we know the entry code will do + -- For a function, the entry code is the fast entry point + + | LFUnLifted -- A value of unboxed type; + -- always a value, needs evaluation + + | LFLetNoEscape -- See LetNoEscape module for precise description + + | LFBlackHole -- Used for the closures allocated to hold the result + -- of a CAF. We want the target of the update frame to + -- be in the heap, so we make a black hole to hold it. -- XXX we can very nearly get rid of this, but -- allocDynClosure needs a LambdaFormInfo ------------------------- --- StandardFormInfo tells whether this thunk has one of +-- StandardFormInfo tells whether this thunk has one of -- a small number of standard forms data StandardFormInfo = NonStandardThunk - -- Not of of the standard forms + -- The usual case: not of the standard forms | SelectorThunk - -- A SelectorThunk is of form - -- case x of - -- con a1,..,an -> ak - -- and the constructor is from a single-constr type. - WordOff -- 0-origin offset of ak within the "goods" of - -- constructor (Recall that the a1,...,an may be laid - -- out in the heap in a non-obvious order.) - - | ApThunk - -- An ApThunk is of form - -- x1 ... xn - -- The code for the thunk just pushes x2..xn on the stack and enters x1. - -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled - -- in the RTS to save space. - RepArity -- Arity, n + -- A SelectorThunk is of form + -- case x of + -- con a1,..,an -> ak + -- and the constructor is from a single-constr type. + WordOff -- 0-origin offset of ak within the "goods" of + -- constructor (Recall that the a1,...,an may be laid + -- out in the heap in a non-obvious order.) + + | ApThunk + -- An ApThunk is of form + -- x1 ... xn + -- The code for the thunk just pushes x2..xn on the stack and enters x1. + -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled + -- in the RTS to save space. + RepArity -- Arity, n ------------------------------------------------------ --- Building LambdaFormInfo +-- Building LambdaFormInfo ------------------------------------------------------ mkLFArgument :: Id -> LambdaFormInfo -mkLFArgument id - | isUnLiftedType ty = LFUnLifted +mkLFArgument id + | isUnLiftedType ty = LFUnLifted | might_be_a_function ty = LFUnknown True - | otherwise = LFUnknown False + | otherwise = LFUnknown False where ty = idType id @@ -211,23 +205,23 @@ mkLFLetNoEscape :: LambdaFormInfo mkLFLetNoEscape = LFLetNoEscape ------------- -mkLFReEntrant :: TopLevelFlag -- True of top level - -> [Id] -- Free vars - -> [Id] -- Args - -> ArgDescr -- Argument descriptor - -> LambdaFormInfo +mkLFReEntrant :: TopLevelFlag -- True of top level + -> [Id] -- Free vars + -> [Id] -- Args + -> ArgDescr -- Argument descriptor + -> LambdaFormInfo -mkLFReEntrant top fvs args arg_descr +mkLFReEntrant top fvs args arg_descr = LFReEntrant top (length args) (null fvs) arg_descr ------------- mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo mkLFThunk thunk_ty top fvs upd_flag = ASSERT( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty) ) - LFThunk top (null fvs) - (isUpdatable upd_flag) - NonStandardThunk - (might_be_a_function thunk_ty) + LFThunk top (null fvs) + (isUpdatable upd_flag) + NonStandardThunk + (might_be_a_function thunk_ty) -------------- might_be_a_function :: Type -> Bool @@ -248,23 +242,23 @@ mkConLFInfo con = LFCon con ------------- mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo mkSelectorLFInfo id offset updatable - = LFThunk NotTopLevel False updatable (SelectorThunk offset) - (might_be_a_function (idType id)) + = LFThunk NotTopLevel False updatable (SelectorThunk offset) + (might_be_a_function (idType id)) ------------- mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo mkApLFInfo id upd_flag arity = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity) - (might_be_a_function (idType id)) + (might_be_a_function (idType id)) ------------- mkLFImported :: Id -> LambdaFormInfo mkLFImported id | Just con <- isDataConWorkId_maybe id , isNullaryRepDataCon con - = LFCon con -- An imported nullary constructor - -- We assume that the constructor is evaluated so that - -- the id really does point directly to the constructor + = LFCon con -- An imported nullary constructor + -- We assume that the constructor is evaluated so that + -- the id really does point directly to the constructor | arity > 0 = LFReEntrant TopLevel arity True (panic "arg_descr") @@ -279,25 +273,26 @@ mkLFBlackHole :: LambdaFormInfo mkLFBlackHole = LFBlackHole ----------------------------------------------------- --- Dynamic pointer tagging +-- Dynamic pointer tagging ----------------------------------------------------- -type ConTagZ = Int -- A *zero-indexed* contructor tag - -type DynTag = Int -- The tag on a *pointer* - -- (from the dynamic-tagging paper) +type ConTagZ = Int -- A *zero-indexed* contructor tag -{- Note [Data constructor dynamic tags] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The family size of a data type (the number of constructors -or the arity of a function) can be either: - * small, if the family size < 2**tag_bits - * big, otherwise. +type DynTag = Int -- The tag on a *pointer* + -- (from the dynamic-tagging paper) -Small families can have the constructor tag in the tag bits. -Big families only use the tag value 1 to represent evaluatedness. -We don't have very many tag bits: for example, we have 2 bits on -x86-32 and 3 bits on x86-64. -} +-- Note [Data constructor dynamic tags] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The family size of a data type (the number of constructors +-- or the arity of a function) can be either: +-- * small, if the family size < 2**tag_bits +-- * big, otherwise. +-- +-- Small families can have the constructor tag in the tag bits. +-- Big families only use the tag value 1 to represent evaluatedness. +-- We don't have very many tag bits: for example, we have 2 bits on +-- x86-32 and 3 bits on x86-64. isSmallFamily :: DynFlags -> Int -> Bool isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags @@ -329,7 +324,7 @@ lfDynTag _ _other = 0 ----------------------------------------------------------------------------- --- Observing LambdaFormInfo +-- Observing LambdaFormInfo ----------------------------------------------------------------------------- ------------- @@ -341,9 +336,9 @@ maybeIsLFCon _ = Nothing isLFThunk :: LambdaFormInfo -> Bool isLFThunk (LFThunk {}) = True isLFThunk LFBlackHole = True - -- return True for a blackhole: this function is used to determine - -- whether to use the thunk header in SMP mode, and a blackhole - -- must have one. + -- return True for a blackhole: this function is used to determine + -- whether to use the thunk header in SMP mode, and a blackhole + -- must have one. isLFThunk _ = False isLFReEntrant :: LambdaFormInfo -> Bool @@ -351,7 +346,7 @@ isLFReEntrant (LFReEntrant {}) = True isLFReEntrant _ = False ----------------------------------------------------------------------------- --- Choosing SM reps +-- Choosing SM reps ----------------------------------------------------------------------------- lfClosureType :: LambdaFormInfo -> ClosureTypeInfo @@ -371,118 +366,137 @@ thunkClosureType _ = Thunk -- to FUN_STATIC in this case. ----------------------------------------------------------------------------- --- nodeMustPointToIt +-- nodeMustPointToIt ----------------------------------------------------------------------------- nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool -nodeMustPointToIt _ (LFReEntrant top _ no_fvs _) - = not no_fvs || -- Certainly if it has fvs we need to point to it - isNotTopLevel top - -- If it is not top level we will point to it - -- We can have a \r closure with no_fvs which - -- is not top level as special case cgRhsClosure - -- has been dissabled in favour of let floating +-- If nodeMustPointToIt is true, then the entry convention for +-- this closure has R1 (the "Node" register) pointing to the +-- closure itself --- the "self" argument - -- For lex_profiling we also access the cost centre for a - -- non-inherited function i.e. not top level - -- the not top case above ensures this is ok. +nodeMustPointToIt _ (LFReEntrant top _ no_fvs _) + = not no_fvs -- Certainly if it has fvs we need to point to it + || isNotTopLevel top -- See Note [GC recovery] + -- For lex_profiling we also access the cost centre for a + -- non-inherited (i.e. non-top-level) function. + -- The isNotTopLevel test above ensures this is ok. + +nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _) + = not no_fvs -- Self parameter + || isNotTopLevel top -- Note [GC recovery] + || updatable -- Need to push update frame + || gopt Opt_SccProfilingOn dflags + -- For the non-updatable (single-entry case): + -- + -- True if has fvs (in which case we need access to them, and we + -- should black-hole it) + -- or profiling (in which case we need to recover the cost centre + -- from inside it) ToDo: do we need this even for + -- top-level thunks? If not, + -- isNotTopLevel subsumes this + +nodeMustPointToIt _ (LFThunk {}) -- Node must point to a standard-form thunk + = True nodeMustPointToIt _ (LFCon _) = True - -- Strictly speaking, the above two don't need Node to point - -- to it if the arity = 0. But this is a *really* unlikely - -- situation. If we know it's nil (say) and we are entering - -- it. Eg: let x = [] in x then we will certainly have inlined - -- x, since nil is a simple atom. So we gain little by not - -- having Node point to known zero-arity things. On the other - -- hand, we do lose something; Patrick's code for figuring out - -- when something has been updated but not entered relies on - -- having Node point to the result of an update. SLPJ - -- 27/11/92. - -nodeMustPointToIt dflags (LFThunk _ no_fvs updatable NonStandardThunk _) - = updatable || not no_fvs || gopt Opt_SccProfilingOn dflags - -- For the non-updatable (single-entry case): - -- - -- True if has fvs (in which case we need access to them, and we - -- should black-hole it) - -- or profiling (in which case we need to recover the cost centre - -- from inside it) - -nodeMustPointToIt _ (LFThunk {}) -- Node must point to a standard-form thunk - = True + -- Strictly speaking, the above two don't need Node to point + -- to it if the arity = 0. But this is a *really* unlikely + -- situation. If we know it's nil (say) and we are entering + -- it. Eg: let x = [] in x then we will certainly have inlined + -- x, since nil is a simple atom. So we gain little by not + -- having Node point to known zero-arity things. On the other + -- hand, we do lose something; Patrick's code for figuring out + -- when something has been updated but not entered relies on + -- having Node point to the result of an update. SLPJ + -- 27/11/92. nodeMustPointToIt _ (LFUnknown _) = True nodeMustPointToIt _ LFUnLifted = False nodeMustPointToIt _ LFBlackHole = True -- BH entry may require Node to point -nodeMustPointToIt _ LFLetNoEscape = False +nodeMustPointToIt _ LFLetNoEscape = False + +{- Note [GC recovery] +~~~~~~~~~~~~~~~~~~~~~ +If we a have a local let-binding (function or thunk) + let f = <body> in ... +AND <body> allocates, then the heap-overflow check needs to know how +to re-start the evaluation. It uses the "self" pointer to do this. +So even if there are no free variables in <body>, we still make +nodeMustPointToIt be True for non-top-level bindings. + +Why do any such bindings exist? After all, let-floating should have +floated them out. Well, a clever optimiser might leave one there to +avoid a space leak, deliberately recomputing a thunk. Also (and this +really does happen occasionally) let-floating may make a function f smaller +so it can be inlined, so now (f True) may generate a local no-fv closure. +This actually happened during bootsrapping GHC itself, with f=mkRdrFunBind +in TcGenDeriv.) -} ----------------------------------------------------------------------------- --- getCallMethod +-- getCallMethod ----------------------------------------------------------------------------- {- The entry conventions depend on the type of closure being entered, whether or not it has free variables, and whether we're running sequentially or in parallel. -Closure Node Argument Enter -Characteristics Par Req'd Passing Via +Closure Node Argument Enter +Characteristics Par Req'd Passing Via ------------------------------------------------------------------------------- -Unknown & no & yes & stack & node -Known fun (>1 arg), no fvs & no & no & registers & fast entry (enough args) - & slow entry (otherwise) -Known fun (>1 arg), fvs & no & yes & registers & fast entry (enough args) -0 arg, no fvs \r,\s & no & no & n/a & direct entry -0 arg, no fvs \u & no & yes & n/a & node -0 arg, fvs \r,\s & no & yes & n/a & direct entry -0 arg, fvs \u & no & yes & n/a & node - -Unknown & yes & yes & stack & node -Known fun (>1 arg), no fvs & yes & no & registers & fast entry (enough args) - & slow entry (otherwise) -Known fun (>1 arg), fvs & yes & yes & registers & node -0 arg, no fvs \r,\s & yes & no & n/a & direct entry -0 arg, no fvs \u & yes & yes & n/a & node -0 arg, fvs \r,\s & yes & yes & n/a & node -0 arg, fvs \u & yes & yes & n/a & node -\end{tabular} +Unknown & no & yes & stack & node +Known fun (>1 arg), no fvs & no & no & registers & fast entry (enough args) + & slow entry (otherwise) +Known fun (>1 arg), fvs & no & yes & registers & fast entry (enough args) +0 arg, no fvs \r,\s & no & no & n/a & direct entry +0 arg, no fvs \u & no & yes & n/a & node +0 arg, fvs \r,\s & no & yes & n/a & direct entry +0 arg, fvs \u & no & yes & n/a & node +Unknown & yes & yes & stack & node +Known fun (>1 arg), no fvs & yes & no & registers & fast entry (enough args) + & slow entry (otherwise) +Known fun (>1 arg), fvs & yes & yes & registers & node +0 arg, no fvs \r,\s & yes & no & n/a & direct entry +0 arg, no fvs \u & yes & yes & n/a & node +0 arg, fvs \r,\s & yes & yes & n/a & node +0 arg, fvs \u & yes & yes & n/a & node When black-holing, single-entry closures could also be entered via node (rather than directly) to catch double-entry. -} data CallMethod - = EnterIt -- No args, not a function + = EnterIt -- No args, not a function - | JumpToIt -- A join point + | JumpToIt -- A join point - | ReturnIt -- It's a value (function, unboxed value, - -- or constructor), so just return it. + | ReturnIt -- It's a value (function, unboxed value, + -- or constructor), so just return it. - | SlowCall -- Unknown fun, or known fun with - -- too few args. + | SlowCall -- Unknown fun, or known fun with + -- too few args. - | DirectEntry -- Jump directly, with args in regs - CLabel -- The code label - RepArity -- Its arity + | DirectEntry -- Jump directly, with args in regs + CLabel -- The code label + RepArity -- Its arity getCallMethod :: DynFlags -> Name -- Function being applied -> CafInfo -- Can it refer to CAF's? - -> LambdaFormInfo -- Its info - -> RepArity -- Number of available arguments - -> CallMethod + -> LambdaFormInfo -- Its info + -> RepArity -- Number of available arguments + -> CallMethod getCallMethod dflags _name _ lf_info _n_args | nodeMustPointToIt dflags lf_info && gopt Opt_Parallel dflags - = -- If we're parallel, then we must always enter via node. - -- The reason is that the closure may have been - -- fetched since we allocated it. + = -- If we're parallel, then we must always enter via node. + -- The reason is that the closure may have been + -- fetched since we allocated it. EnterIt getCallMethod dflags name caf (LFReEntrant _ arity _ _) n_args | n_args == 0 = ASSERT( arity /= 0 ) - ReturnIt -- No args at all - | n_args < arity = SlowCall -- Not enough args + ReturnIt -- No args at all + | n_args < arity = SlowCall -- Not enough args | otherwise = DirectEntry (enterIdLabel dflags name caf) arity getCallMethod _ _name _ LFUnLifted n_args @@ -492,17 +506,17 @@ getCallMethod _ _name _ (LFCon _) n_args = ASSERT( n_args == 0 ) ReturnIt getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_args - | is_fun -- it *might* be a function, so we must "call" it (which is always safe) - = SlowCall -- We cannot just enter it [in eval/apply, the entry code - -- is the fast-entry code] + | is_fun -- it *might* be a function, so we must "call" it (which is always safe) + = SlowCall -- We cannot just enter it [in eval/apply, the entry code + -- is the fast-entry code] -- Since is_fun is False, we are *definitely* looking at a data value | updatable || gopt Opt_Ticky dflags -- to catch double entry {- OLD: || opt_SMP - I decided to remove this, because in SMP mode it doesn't matter - if we enter the same thunk multiple times, so the optimisation - of jumping directly to the entry code is still valid. --SDM - -} + I decided to remove this, because in SMP mode it doesn't matter + if we enter the same thunk multiple times, so the optimisation + of jumping directly to the entry code is still valid. --SDM + -} = EnterIt -- We used to have ASSERT( n_args == 0 ), but actually it is -- possible for the optimiser to generate @@ -511,7 +525,7 @@ getCallMethod dflags name caf (LFThunk _ _ updatable std_form_info is_fun) n_arg -- This happens as a result of the case-of-error transformation -- So the right thing to do is just to enter the thing - | otherwise -- Jump direct to code for single-entry thunks + | otherwise -- Jump direct to code for single-entry thunks = ASSERT( n_args == 0 ) DirectEntry (thunkEntryLabel dflags name caf std_form_info updatable) 0 @@ -519,24 +533,24 @@ getCallMethod _ _name _ (LFUnknown True) _n_args = SlowCall -- might be a function getCallMethod _ name _ (LFUnknown False) n_args - = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) + = ASSERT2( n_args == 0, ppr name <+> ppr n_args ) EnterIt -- Not a function getCallMethod _ _name _ LFBlackHole _n_args - = SlowCall -- Presumably the black hole has by now - -- been updated, but we don't know with - -- what, so we slow call it + = SlowCall -- Presumably the black hole has by now + -- been updated, but we don't know with + -- what, so we slow call it getCallMethod _ _name _ LFLetNoEscape _n_args = JumpToIt isKnownFun :: LambdaFormInfo -> Bool isKnownFun (LFReEntrant _ _ _ _) = True -isKnownFun LFLetNoEscape = True +isKnownFun LFLetNoEscape = True isKnownFun _ = False ----------------------------------------------------------------------------- --- staticClosureRequired +-- staticClosureRequired ----------------------------------------------------------------------------- {- staticClosureRequired is never called (hence commented out) @@ -559,16 +573,16 @@ have closure, info table, and entry code.] * Fast-entry code ALWAYS NEEDED * Slow-entry code - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) we're in the parallel world and the function has free vars - [Reason: in parallel world, we always enter functions - with free vars via the closure.] + Needed iff (a) we have any un-saturated calls to the function + OR (b) the function is passed as an arg + OR (c) we're in the parallel world and the function has free vars + [Reason: in parallel world, we always enter functions + with free vars via the closure.] * The function closure - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) if the function has free vars (ie not top level) + Needed iff (a) we have any un-saturated calls to the function + OR (b) the function is passed as an arg + OR (c) if the function has free vars (ie not top level) Why case (a) here? Because if the arg-satis check fails, UpdatePAP stuffs a pointer to the function closure in the PAP. @@ -578,9 +592,9 @@ have closure, info table, and entry code.] [NB: these conditions imply that we might need the closure without the slow-entry code. Here's how. - f x y = let g w = ...x..y..w... - in - ...(g t)... + f x y = let g w = ...x..y..w... + in + ...(g t)... Here we need a closure for g which contains x and y, but since the calls are all saturated we just jump to the @@ -588,35 +602,35 @@ have closure, info table, and entry code.] * Standard info table - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) the function has free vars (ie not top level) - - NB. In the sequential world, (c) is only required so that the function closure has - an info table to point to, to keep the storage manager happy. - If (c) alone is true we could fake up an info table by choosing - one of a standard family of info tables, whose entry code just - bombs out. - - [NB In the parallel world (c) is needed regardless because - we enter functions with free vars via the closure.] - - If (c) is retained, then we'll sometimes generate an info table - (for storage mgr purposes) without slow-entry code. Then we need - to use an error label in the info table to substitute for the absent - slow entry code. + Needed iff (a) we have any un-saturated calls to the function + OR (b) the function is passed as an arg + OR (c) the function has free vars (ie not top level) + + NB. In the sequential world, (c) is only required so that the function closure has + an info table to point to, to keep the storage manager happy. + If (c) alone is true we could fake up an info table by choosing + one of a standard family of info tables, whose entry code just + bombs out. + + [NB In the parallel world (c) is needed regardless because + we enter functions with free vars via the closure.] + + If (c) is retained, then we'll sometimes generate an info table + (for storage mgr purposes) without slow-entry code. Then we need + to use an error label in the info table to substitute for the absent + slow entry code. -} staticClosureRequired - :: Name - -> StgBinderInfo - -> LambdaFormInfo - -> Bool + :: Name + -> StgBinderInfo + -> LambdaFormInfo + -> Bool staticClosureRequired binder bndr_info - (LFReEntrant top_level _ _ _) -- It's a function + (LFReEntrant top_level _ _ _) -- It's a function = ASSERT( isTopLevel top_level ) - -- Assumption: it's a top-level, no-free-var binding - not (satCallsOnly bndr_info) + -- Assumption: it's a top-level, no-free-var binding + not (satCallsOnly bndr_info) staticClosureRequired binder other_binder_info other_lf_info = True -} @@ -639,7 +653,7 @@ staticClosureRequired binder other_binder_info other_lf_info = True a) to construct the info table itself, and build other things related to the binding (e.g. slow entry points for a function) b) to allocate a closure containing that info pointer (i.e. - it knows the info table label) + it knows the info table label) -} data ClosureInfo @@ -668,22 +682,22 @@ mkCmmInfo ClosureInfo {..} -------------------------------------- --- Building ClosureInfos +-- Building ClosureInfos -------------------------------------- mkClosureInfo :: DynFlags - -> Bool -- Is static - -> Id - -> LambdaFormInfo - -> Int -> Int -- Total and pointer words + -> Bool -- Is static + -> Id + -> LambdaFormInfo + -> Int -> Int -- Total and pointer words -> String -- String descriptor - -> ClosureInfo + -> ClosureInfo mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr - = ClosureInfo { closureName = name, - closureLFInfo = lf_info, - closureInfoLabel = info_lbl, -- These three fields are - closureSMRep = sm_rep, -- (almost) an info table - closureProf = prof } -- (we don't have an SRT yet) + = ClosureInfo { closureName = name + , closureLFInfo = lf_info + , closureInfoLabel = info_lbl -- These three fields are + , closureSMRep = sm_rep -- (almost) an info table + , closureProf = prof } -- (we don't have an SRT yet) where name = idName id sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) @@ -708,8 +722,8 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr -- -- -- Previously, eager blackholing was enabled when ticky-ticky --- was on. But it didn't work, and it wasn't strictly necessary --- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING +-- was on. But it didn't work, and it wasn't strictly necessary +-- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING -- is unconditionally disabled. -- krc 1/2007 -- Static closures are never themselves black-holed. @@ -717,12 +731,12 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr blackHoleOnEntry :: ClosureInfo -> Bool blackHoleOnEntry cl_info | isStaticRep (closureSMRep cl_info) - = False -- Never black-hole a static closure + = False -- Never black-hole a static closure | otherwise = case closureLFInfo cl_info of - LFReEntrant _ _ _ _ -> False - LFLetNoEscape -> False + LFReEntrant _ _ _ _ -> False + LFLetNoEscape -> False LFThunk _ _no_fvs _updatable _ _ -> True _other -> panic "blackHoleOnEntry" -- Should never happen @@ -734,9 +748,9 @@ closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info lfUpdatable :: LambdaFormInfo -> Bool lfUpdatable (LFThunk _ _ upd _ _) = upd -lfUpdatable LFBlackHole = True - -- Black-hole closures are allocated to receive the results of an - -- alg case with a named default... so they need to be updated. +lfUpdatable LFBlackHole = True + -- Black-hole closures are allocated to receive the results of an + -- alg case with a named default... so they need to be updated. lfUpdatable _ = False closureSingleEntry :: ClosureInfo -> Bool @@ -763,7 +777,7 @@ isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) = case lf_info of LFReEntrant TopLevel _ _ _ -> True LFThunk TopLevel _ _ _ _ -> True - _other -> False + _other -> False -------------------------------------- -- Label generation @@ -785,17 +799,17 @@ mkClosureInfoTableLabel id lf_info = case lf_info of LFBlackHole -> mkCAFBlackHoleInfoTableLabel - LFThunk _ _ upd_flag (SelectorThunk offset) _ + LFThunk _ _ upd_flag (SelectorThunk offset) _ -> mkSelectorInfoLabel upd_flag offset - LFThunk _ _ upd_flag (ApThunk arity) _ + LFThunk _ _ upd_flag (ApThunk arity) _ -> mkApInfoTableLabel upd_flag arity LFThunk{} -> std_mk_lbl name cafs LFReEntrant{} -> std_mk_lbl name cafs _other -> panic "closureInfoTableLabel" - where + where name = idName id std_mk_lbl | is_local = mkLocalInfoTableLabel @@ -860,16 +874,16 @@ getTyDescription :: Type -> String getTyDescription ty = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) -> case tau_ty of - TyVarTy _ -> "*" - AppTy fun _ -> getTyDescription fun - FunTy _ res -> '-' : '>' : fun_result res - TyConApp tycon _ -> getOccString tycon + TyVarTy _ -> "*" + AppTy fun _ -> getTyDescription fun + FunTy _ res -> '-' : '>' : fun_result res + TyConApp tycon _ -> getOccString tycon ForAllTy _ ty -> getTyDescription ty LitTy n -> getTyLitDescription n } where fun_result (FunTy _ res) = '>' : fun_result res - fun_result other = getTyDescription other + fun_result other = getTyDescription other getTyLitDescription :: TyLit -> String getTyLitDescription l = @@ -923,8 +937,8 @@ indStaticInfoTable staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool -- A static closure needs a link field to aid the GC when traversing -- the static closure graph. But it only needs such a field if either --- a) it has an SRT --- b) it's a constructor with one or more pointer fields +-- a) it has an SRT +-- b) it's a constructor with one or more pointer fields -- In case (b), the constructor's fields themselves play the role -- of the SRT. -- diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index d2a25ebd6c..57d4759346 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -50,24 +50,24 @@ import Data.Char -- Top-level constructors --------------------------------------------------------------- -cgTopRhsCon :: Id -- Name of thing bound to this RHS +cgTopRhsCon :: DynFlags + -> Id -- Name of thing bound to this RHS -> DataCon -- Id -> [StgArg] -- Args - -> FCode (CgIdInfo, FCode ()) -cgTopRhsCon id con args - = do dflags <- getDynFlags - let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label) - return ( id_info, gen_code ) + -> (CgIdInfo, FCode ()) +cgTopRhsCon dflags id con args = + let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label) + in (id_info, gen_code) where name = idName id caffy = idCafInfo id -- any stgArgHasCafRefs args closure_label = mkClosureLabel name caffy gen_code = - do { dflags <- getDynFlags + do { this_mod <- getModuleName ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ -- Windows DLLs have a problem with static cross-DLL refs. - ASSERT( not (isDllConApp dflags con args) ) return () + ASSERT( not (isDllConApp dflags this_mod con args) ) return () ; ASSERT( args `lengthIs` dataConRepRepArity con ) return () -- LAY IT OUT @@ -234,7 +234,7 @@ buildDynCon' dflags _ binder actually_bound ccs con args use_cc -- cost-centre to stick in the object | isCurrentCCS ccs = curCCS | otherwise = panic "buildDynCon: non-current CCS not implemented" - + blame_cc = use_cc -- cost-centre on which to blame the alloc (same) diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index 1fdb364b56..353fec5a5f 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -8,8 +8,6 @@ module StgCmmEnv ( CgIdInfo, - cgIdInfoId, cgIdInfoLF, - litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit, idInfoToAmode, @@ -20,8 +18,8 @@ module StgCmmEnv ( bindArgsToRegs, bindToReg, rebindToReg, bindArgToReg, idToReg, getArgAmode, getNonVoidArgAmodes, - getCgIdInfo, - maybeLetNoEscape, + getCgIdInfo, + maybeLetNoEscape, ) where #include "HsVersions.h" @@ -113,12 +111,6 @@ addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr -- A tag adds a byte offset to the pointer addDynTag dflags expr tag = cmmOffsetB dflags expr tag -cgIdInfoId :: CgIdInfo -> Id -cgIdInfoId = cg_id - -cgIdInfoLF :: CgIdInfo -> LambdaFormInfo -cgIdInfoLF = cg_lf - maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg]) maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args) maybeLetNoEscape _other = Nothing @@ -127,15 +119,15 @@ maybeLetNoEscape _other = Nothing --------------------------------------------------------- -- The binding environment --- --- There are three basic routines, for adding (addBindC), +-- +-- There are three basic routines, for adding (addBindC), -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings. --------------------------------------------------------- -addBindC :: Id -> CgIdInfo -> FCode () -addBindC name stuff_to_bind = do +addBindC :: CgIdInfo -> FCode () +addBindC stuff_to_bind = do binds <- getBinds - setBinds $ extendVarEnv binds name stuff_to_bind + setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind addBindsC :: [CgIdInfo] -> FCode () addBindsC new_bindings = do @@ -147,39 +139,26 @@ addBindsC new_bindings = do getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id - = do { -- Try local bindings first - ; local_binds <- getBinds + = do { dflags <- getDynFlags + ; local_binds <- getBinds -- Try local bindings first ; case lookupVarEnv local_binds id of { Just info -> return info ; - Nothing -> do - - { -- Try top-level bindings - static_binds <- getStaticBinds - ; case lookupVarEnv static_binds id of { - Just info -> return info ; - Nothing -> + Nothing -> do { -- Should be imported; make up a CgIdInfo for it - let - name = idName id - in - if isExternalName name then do - let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id) - dflags <- getDynFlags - return (litIdInfo dflags id (mkLFImported id) ext_lbl) - else - -- Bug - cgLookupPanic id - }}}} - + let name = idName id + ; if isExternalName name then + let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id) + in return (litIdInfo dflags id (mkLFImported id) ext_lbl) + else + cgLookupPanic id -- Bug + }}} + cgLookupPanic :: Id -> FCode a cgLookupPanic id - = do static_binds <- getStaticBinds - local_binds <- getBinds + = do local_binds <- getBinds pprPanic "StgCmmEnv: variable not found" (vcat [ppr id, - ptext (sLit "static binds for:"), - vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ], ptext (sLit "local binds for:"), vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ] ]) @@ -192,7 +171,7 @@ getArgAmode (NonVoid (StgVarArg var)) = getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] --- NB: Filters out void args, +-- NB: Filters out void args, -- so the result list may be shorter than the argument list getNonVoidArgAmodes [] = return [] getNonVoidArgAmodes (arg:args) @@ -210,15 +189,15 @@ bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg bindToReg nvid@(NonVoid id) lf_info = do dflags <- getDynFlags let reg = idToReg dflags nvid - addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))) + addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))) return reg rebindToReg :: NonVoid Id -> FCode LocalReg --- Like bindToReg, but the Id is already in scope, so +-- Like bindToReg, but the Id is already in scope, so -- get its LF info from the envt rebindToReg nvid@(NonVoid id) = do { info <- getCgIdInfo id - ; bindToReg nvid (cgIdInfoLF info) } + ; bindToReg nvid (cg_lf info) } bindArgToReg :: NonVoid Id -> FCode LocalReg bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id) @@ -233,7 +212,7 @@ idToReg :: DynFlags -> NonVoid Id -> LocalReg -- We re-use the Unique from the Id to make it easier to see what is going on -- -- By now the Ids should be uniquely named; else one would worry --- about accidental collision +-- about accidental collision idToReg dflags (NonVoid id) = LocalReg (idUnique id) (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id) diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index d7edf8e193..24b12f7237 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -43,7 +43,6 @@ import Maybes import Util import FastString import Outputable -import UniqSupply import Control.Monad (when,void) @@ -70,8 +69,8 @@ cgExpr (StgLit lit) = do cmm_lit <- cgLit lit cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr } cgExpr (StgLetNoEscape _ _ binds expr) = - do { us <- newUniqSupply - ; let join_id = mkBlockId (uniqFromSupply us) + do { u <- newUnique + ; let join_id = mkBlockId u ; cgLneBinds join_id binds ; r <- cgExpr expr ; emitLabel join_id @@ -107,7 +106,7 @@ cgLneBinds join_id (StgNonRec bndr rhs) -- See Note [Saving the current cost centre] ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs ; fcode - ; addBindC (cg_id info) info } + ; addBindC info } cgLneBinds join_id (StgRec pairs) = do { local_cc <- saveCurrentCostCentre @@ -142,9 +141,9 @@ cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body) = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args) = cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con args) - -- For a constructor RHS we want to generate a single chunk of - -- code which can be jumped to from many places, which will - -- return the constructor. It's easy; just behave as if it + -- For a constructor RHS we want to generate a single chunk of + -- code which can be jumped to from many places, which will + -- return the constructor. It's easy; just behave as if it -- was an StgRhsClosure with a ConApp inside! ------------------------- @@ -194,9 +193,9 @@ heapcheck will take their worst case into account. In favour of omitting !Q!, !R!: - *May* save a heap overflow test, - if ...P... allocates anything. + if ...P... allocates anything. - - We can use relative addressing from a single Hp to + - We can use relative addressing from a single Hp to get at all the closures so allocated. - No need to save volatile vars etc across heap checks @@ -204,7 +203,7 @@ In favour of omitting !Q!, !R!: Against omitting !Q!, !R! - - May put a heap-check into the inner loop. Suppose + - May put a heap-check into the inner loop. Suppose the main loop is P -> R -> P -> R... Q is the loop exit, and only it does allocation. This only hurts us if P does no allocation. If P allocates, @@ -213,7 +212,7 @@ Against omitting !Q!, !R! - May do more allocation than reqd. This sometimes bites us badly. For example, nfib (ha!) allocates about 30\% more space if the worst-casing is done, because many many calls to nfib are leaf calls - which don't need to allocate anything. + which don't need to allocate anything. We can un-allocate, but that costs an instruction @@ -249,7 +248,7 @@ Hence: two basic plans for ...save current cost centre... - ...code for e, + ...code for e, with sequel (SetLocals r) ...restore current cost centre... @@ -314,13 +313,20 @@ cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts {- Note [case on bool] - +~~~~~~~~~~~~~~~~~~~ This special case handles code like case a <# b of True -> False -> +--> case tagToEnum# (a <$# b) of + True -> .. ; False -> ... + +--> case (a <$# b) of r -> + case tagToEnum# r of + True -> .. ; False -> ... + If we let the ordinary case code handle it, we'll get something like tmp1 = a < b @@ -339,8 +345,12 @@ So we add a special case to generate and later optimisations will further improve this. -We should really change all these primops to return Int# instead, that -would make this special case go away. +Now that #6135 has been resolved it should be possible to remove that +special case. The idea behind this special case and pre-6135 implementation +of Bool-returning primops was that tagToEnum# was added implicitly in the +codegen and then optimized away. Now the call to tagToEnum# is explicit +in the source code, which allows to optimize it away at the earlier stages +of compilation (i.e. at the Core level). -} @@ -499,7 +509,7 @@ cgAlts gc_plan bndr (PrimAlt _) alts -- PrimAlts always have a DEFAULT case -- and it always comes first - tagged_cmms' = [(lit,code) + tagged_cmms' = [(lit,code) | (LitAlt lit, code) <- tagged_cmms] ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt ; return AssignedDirectly } @@ -619,34 +629,21 @@ cgConApp con stg_args ; emit =<< fcode_init ; emitReturn [idInfoToAmode idinfo] } - cgIdApp :: Id -> [StgArg] -> FCode ReturnKind cgIdApp fun_id [] | isVoidId fun_id = emitReturn [] -cgIdApp fun_id args - = do { fun_info <- getCgIdInfo fun_id - ; case maybeLetNoEscape fun_info of - Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args - Nothing -> cgTailCall (cg_id fun_info) fun_info args } - -- NB. use (cg_id fun_info) instead of fun_id, because the former - -- may be externalised for -split-objs. - -- See StgCmm.maybeExternaliseId. - -cgLneJump :: BlockId -> [LocalReg] -> [StgArg] -> FCode ReturnKind -cgLneJump blk_id lne_regs args -- Join point; discard sequel - = do { adjustHpBackwards -- always do this before a tail-call - ; cmm_args <- getNonVoidArgAmodes args - ; emitMultiAssign lne_regs cmm_args - ; emit (mkBranch blk_id) - ; return AssignedDirectly } - -cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode ReturnKind -cgTailCall fun_id fun_info args = do - dflags <- getDynFlags +cgIdApp fun_id args = do + dflags <- getDynFlags + fun_info <- getCgIdInfo fun_id + let fun_arg = StgVarArg fun_id + fun_name = idName fun_id + fun = idInfoToAmode fun_info + lf_info = cg_lf fun_info + node_points dflags = nodeMustPointToIt dflags lf_info case (getCallMethod dflags fun_name (idCafInfo fun_id) lf_info (length args)) of -- A value in WHNF, so we can just return it. ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged? - + EnterIt -> ASSERT( null args ) -- Discarding arguments emitEnter fun @@ -654,7 +651,7 @@ cgTailCall fun_id fun_info args = do { tickySlowCall lf_info args ; emitComment $ mkFastString "slowCall" ; slowCall fun args } - + -- A direct function call (possibly with some left-over arguments) DirectEntry lbl arity -> do { tickyDirectCall arity args @@ -662,15 +659,14 @@ cgTailCall fun_id fun_info args = do then directCall NativeNodeCall lbl arity (fun_arg:args) else directCall NativeDirectCall lbl arity args } - JumpToIt {} -> panic "cgTailCall" -- ??? - - where - fun_arg = StgVarArg fun_id - fun_name = idName fun_id - fun = idInfoToAmode fun_info - lf_info = cgIdInfoLF fun_info - node_points dflags = nodeMustPointToIt dflags lf_info - + -- Let-no-escape call + JumpToIt -> let (LneLoc blk_id lne_regs) = cg_loc fun_info + in do + { adjustHpBackwards -- always do this before a tail-call + ; cmm_args <- getNonVoidArgAmodes args + ; emitMultiAssign lne_regs cmm_args + ; emit (mkBranch blk_id) + ; return AssignedDirectly } emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs index f73122bf89..e710204222 100644 --- a/compiler/codeGen/StgCmmExtCode.hs +++ b/compiler/codeGen/StgCmmExtCode.hs @@ -10,9 +10,9 @@ -- back in circularly (to avoid a two-pass algorithm). module StgCmmExtCode ( - CmmParse(..), + CmmParse, unEC, Named(..), Env, - + loopDecls, getEnv, @@ -50,13 +50,13 @@ import Unique -- | The environment contains variable definitions or blockids. -data Named +data Named = VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type, - -- eg, RtsLabel, ForeignLabel, CmmLabel etc. + -- eg, RtsLabel, ForeignLabel, CmmLabel etc. | FunN PackageId -- ^ A function name from this package | LabelN BlockId -- ^ A blockid of some code or data. - + -- | An environment of named things. type Env = UniqFM Named @@ -65,7 +65,7 @@ type Decls = [(FastString,Named)] -- | Does a computation in the FCode monad, with a current environment -- and a list of local declarations. Returns the resulting list of declarations. -newtype CmmParse a +newtype CmmParse a = EC { unEC :: Env -> Decls -> FCode (Decls, a) } type ExtCode = CmmParse () @@ -86,7 +86,7 @@ instance HasDynFlags CmmParse where -- | Takes the variable decarations and imports from the monad --- and makes an environment, which is looped back into the computation. +-- and makes an environment, which is looped back into the computation. -- In this way, we can have embedded declarations that scope over the whole -- procedure, and imports that scope over the entire module. -- Discards the local declaration contained within decl' @@ -94,7 +94,7 @@ instance HasDynFlags CmmParse where loopDecls :: CmmParse a -> CmmParse a loopDecls (EC fcode) = EC $ \e globalDecls -> do - (_, a) <- F.fixC (\ ~(decls, _) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls) + (_, a) <- F.fixC (\ ~(decls, _) -> fcode (addListToUFM e decls) globalDecls) return (globalDecls, a) @@ -103,24 +103,26 @@ getEnv :: CmmParse Env getEnv = EC $ \e s -> return (s, e) --- | Add a new variable to the list of local declarations. --- The CmmExpr says where the value is stored. +addDecl :: FastString -> Named -> ExtCode +addDecl name named = EC $ \_ s -> return ((name, named) : s, ()) + + +-- | Add a new variable to the list of local declarations. +-- The CmmExpr says where the value is stored. addVarDecl :: FastString -> CmmExpr -> ExtCode -addVarDecl var expr - = EC $ \_ s -> return ((var, VarN expr):s, ()) +addVarDecl var expr = addDecl var (VarN expr) -- | Add a new label to the list of local declarations. addLabel :: FastString -> BlockId -> ExtCode -addLabel name block_id - = EC $ \_ s -> return ((name, LabelN block_id):s, ()) +addLabel name block_id = addDecl name (LabelN block_id) -- | Create a fresh local variable of a given type. -newLocal +newLocal :: CmmType -- ^ data type -> FastString -- ^ name of variable -> CmmParse LocalReg -- ^ register holding the value - + newLocal ty name = do u <- code newUnique let reg = LocalReg u ty @@ -139,33 +141,32 @@ newBlockId :: CmmParse BlockId newBlockId = code F.newLabelC -- | Add add a local function to the environment. -newFunctionName - :: FastString -- ^ name of the function +newFunctionName + :: FastString -- ^ name of the function -> PackageId -- ^ package of the current module -> ExtCode - -newFunctionName name pkg - = EC $ \_ s -> return ((name, FunN pkg):s, ()) - - + +newFunctionName name pkg = addDecl name (FunN pkg) + + -- | Add an imported foreign label to the list of local declarations. -- If this is done at the start of the module the declaration will scope -- over the whole module. -newImport - :: (FastString, CLabel) +newImport + :: (FastString, CLabel) -> CmmParse () -newImport (name, cmmLabel) +newImport (name, cmmLabel) = addVarDecl name (CmmLit (CmmLabel cmmLabel)) -- | Lookup the BlockId bound to the label with this name. --- If one hasn't been bound yet, create a fresh one based on the +-- If one hasn't been bound yet, create a fresh one based on the -- Unique of the name. lookupLabel :: FastString -> CmmParse BlockId lookupLabel name = do env <- getEnv - return $ + return $ case lookupUFM env name of Just (LabelN l) -> l _other -> mkBlockId (newTagUnique (getUnique name) 'L') @@ -178,7 +179,7 @@ lookupLabel name = do lookupName :: FastString -> CmmParse CmmExpr lookupName name = do env <- getEnv - return $ + return $ case lookupUFM env name of Just (VarN e) -> e Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name)) @@ -187,7 +188,7 @@ lookupName name = do -- | Lift an FCode computation into the CmmParse monad code :: FCode a -> CmmParse a -code fc = EC $ \_ s -> do +code fc = EC $ \_ s -> do r <- fc return (s, r) diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index 30bd46318a..0b782fffcc 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -225,7 +225,8 @@ emitForeignCall safety results target args , res = results , args = args' , succ = k - , updfr = updfr_off + , ret_args = off + , ret_off = updfr_off , intrbl = playInterruptible safety }) <*> mkLabel k <*> copyout diff --git a/compiler/codeGen/StgCmmGran.hs b/compiler/codeGen/StgCmmGran.hs deleted file mode 100644 index 91b0c8ba04..0000000000 --- a/compiler/codeGen/StgCmmGran.hs +++ /dev/null @@ -1,120 +0,0 @@ ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow -2006 --- --- Code generation relaed to GpH --- (a) parallel --- (b) GranSim --- ------------------------------------------------------------------------------ - -module StgCmmGran ( - staticGranHdr,staticParHdr, - granThunk, granYield, - doGranAllocate - ) where - --- This entire module consists of no-op stubs at the moment --- GranSim worked once, but it certainly doesn't any more --- I've left the calls, though, in case anyone wants to resurrect it - -import StgCmmMonad -import CmmExpr - -staticGranHdr :: [CmmLit] -staticGranHdr = [] - -staticParHdr :: [CmmLit] -staticParHdr = [] - -doGranAllocate :: VirtualHpOffset -> FCode () --- Must be lazy in the amount of allocation -doGranAllocate _ = return () - -granYield :: [LocalReg] -> Bool -> FCode () -granYield _regs _node_reqd = return () - -granThunk :: Bool -> FCode () -granThunk _node_points = return () - ------------------------------------------------------------------ -{- ------- Everything below here is commented out ------------- ------------------------------------------------------------------ - --- Parallel header words in a static closure -staticParHdr :: [CmmLit] --- Parallel header words in a static closure -staticParHdr = [] - -staticGranHdr :: [CmmLit] --- Gransim header words in a static closure -staticGranHdr = [] - -doGranAllocate :: CmmExpr -> Code --- macro DO_GRAN_ALLOCATE -doGranAllocate hp - | not opt_GranMacros = return () - | otherwise = panic "doGranAllocate" - - - -------------------------- -granThunk :: Bool -> FCode () --- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node --- (we prefer fetchAndReschedule-style context switches to yield ones) -granThunk node_points - | node_points = granFetchAndReschedule [] node_points - | otherwise = granYield [] node_points - -granFetchAndReschedule :: [(Id,GlobalReg)] -- Live registers - -> Bool -- Node reqd? - -> Code --- Emit code for simulating a fetch and then reschedule. -granFetchAndReschedule regs node_reqd - | opt_GranMacros && (node `elem` map snd regs || node_reqd) - = do { fetch - ; reschedule liveness node_reqd } - | otherwise - = return () - where - liveness = mkRegLiveness regs 0 0 - -fetch = panic "granFetch" - -- Was: absC (CMacroStmt GRAN_FETCH []) - --HWL: generate GRAN_FETCH macro for GrAnSim - -- currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai - -reschedule liveness node_reqd = panic "granReschedule" - -- Was: absC (CMacroStmt GRAN_RESCHEDULE [ - -- mkIntCLit (I# (word2Int# liveness_mask)), - -- mkIntCLit (if node_reqd then 1 else 0)]) - - -------------------------- --- The @GRAN_YIELD@ macro is taken from JSM's code for Concurrent Haskell. It --- allows to context-switch at places where @node@ is not alive (it uses the --- @Continue@ rather than the @EnterNodeCode@ function in the RTS). We emit --- this kind of macro at the beginning of the following kinds of basic bocks: --- \begin{itemize} --- \item Slow entry code where node is not alive (see @StgCmmClosure.lhs@). Normally --- we use @fetchAndReschedule@ at a slow entry code. --- \item Fast entry code (see @CgClosure.lhs@). --- \item Alternatives in case expressions (@CLabelledCode@ structures), provided --- that they are not inlined (see @CgCases.lhs@). These alternatives will --- be turned into separate functions. - -granYield :: [(Id,GlobalReg)] -- Live registers - -> Bool -- Node reqd? - -> Code - -granYield regs node_reqd - | opt_GranMacros && node_reqd = yield liveness - | otherwise = return () - where - liveness = mkRegLiveness regs 0 0 - -yield liveness = panic "granYield" - -- Was : absC (CMacroStmt GRAN_YIELD - -- [mkIntCLit (I# (word2Int# liveness_mask))]) - --} diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index b8962cedb4..97233aa500 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -30,7 +30,6 @@ import StgCmmUtils import StgCmmMonad import StgCmmProf import StgCmmTicky -import StgCmmGran import StgCmmClosure import StgCmmEnv @@ -135,8 +134,7 @@ emitSetDynHdr base info_ptr ccs where header :: DynFlags -> [CmmExpr] header dflags = [info_ptr] ++ dynProfHdr dflags ccs - -- ToDo: Gransim stuff - -- ToDo: Parallel stuff + -- ToDof: Parallel stuff -- No ticky header hpStore :: CmmExpr -> [CmmExpr] -> [VirtualHpOffset] -> FCode () @@ -207,16 +205,11 @@ mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field = [CmmLabel info_lbl] - ++ variable_header_words + ++ staticProfHdr dflags ccs ++ concatMap (padLitToWord dflags) payload ++ padding ++ static_link_field ++ saved_info_field - where - variable_header_words - = staticGranHdr - ++ staticParHdr - ++ staticProfHdr dflags ccs -- JD: Simon had ellided this padding, but without it the C back end asserts -- failure. Maybe it's a bad assertion, and this padding is indeed unnecessary? @@ -469,7 +462,7 @@ cannedGCEntryPoint dflags regs W32 -> Just (mkGcLabel "stg_gc_f1") W64 -> Just (mkGcLabel "stg_gc_d1") _ -> Nothing - + | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1") | width == W64 -> Just (mkGcLabel "stg_gc_l1") | otherwise -> Nothing @@ -529,7 +522,6 @@ heapCheck checkStack checkYield do_gc code | otherwise = Nothing ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc ; tickyAllocHeap True hpHw - ; doGranAllocate hpHw ; setRealHp hpHw ; code } diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 06a47c151b..6c6e49dafa 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -6,23 +6,16 @@ -- ----------------------------------------------------------------------------- -{-# 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 StgCmmLayout ( - mkArgDescr, + mkArgDescr, emitCall, emitReturn, adjustHpBackwards, - emitClosureProcAndInfoTable, - emitClosureAndInfoTable, + emitClosureProcAndInfoTable, + emitClosureAndInfoTable, - slowCall, directCall, + slowCall, directCall, - mkVirtHeapOffsets, mkVirtConstrOffsets, getHpRelOffset, hpRel, + mkVirtHeapOffsets, mkVirtConstrOffsets, getHpRelOffset, hpRel, ArgRep(..), toArgRep, argRepSizeW -- re-exported from StgCmmArgRep ) where @@ -46,9 +39,8 @@ import CmmInfo import CLabel import StgSyn import Id -import Name -import TyCon ( PrimRep(..) ) -import BasicTypes ( RepArity ) +import TyCon ( PrimRep(..) ) +import BasicTypes ( RepArity ) import DynFlags import Module @@ -59,7 +51,7 @@ import FastString import Control.Monad ------------------------------------------------------------------------ --- Call and return sequences +-- Call and return sequences ------------------------------------------------------------------------ -- | Return multiple values to the sequel @@ -108,10 +100,10 @@ emitCallWithExtraStack :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> [CmmExpr] -> FCode ReturnKind emitCallWithExtraStack (callConv, retConv) fun args extra_stack - = do { dflags <- getDynFlags + = do { dflags <- getDynFlags ; adjustHpBackwards - ; sequel <- getSequel - ; updfr_off <- getUpdFrameOff + ; sequel <- getSequel + ; updfr_off <- getUpdFrameOff ; case sequel of Return _ -> do emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack @@ -129,33 +121,33 @@ emitCallWithExtraStack (callConv, retConv) fun args extra_stack adjustHpBackwards :: FCode () -- This function adjusts and heap pointers just before a tail call or --- return. At a call or return, the virtual heap pointer may be less --- than the real Hp, because the latter was advanced to deal with --- the worst-case branch of the code, and we may be in a better-case --- branch. In that case, move the real Hp *back* and retract some +-- return. At a call or return, the virtual heap pointer may be less +-- than the real Hp, because the latter was advanced to deal with +-- the worst-case branch of the code, and we may be in a better-case +-- branch. In that case, move the real Hp *back* and retract some -- ticky allocation count. -- -- It *does not* deal with high-water-mark adjustment. -- That's done by functions which allocate heap. adjustHpBackwards - = do { hp_usg <- getHpUsage - ; let rHp = realHp hp_usg - vHp = virtHp hp_usg - adjust_words = vHp -rHp - ; new_hp <- getHpRelOffset vHp + = do { hp_usg <- getHpUsage + ; let rHp = realHp hp_usg + vHp = virtHp hp_usg + adjust_words = vHp -rHp + ; new_hp <- getHpRelOffset vHp - ; emit (if adjust_words == 0 - then mkNop - else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp + ; emit (if adjust_words == 0 + then mkNop + else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp - ; tickyAllocHeap False adjust_words -- ...ditto + ; tickyAllocHeap False adjust_words -- ...ditto - ; setRealHp vHp - } + ; setRealHp vHp + } ------------------------------------------------------------------------- --- Making calls: directCall and slowCall +-- Making calls: directCall and slowCall ------------------------------------------------------------------------- -- General plan is: @@ -183,7 +175,7 @@ directCall conv lbl arity stg_args slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind -- (slowCall fun args) applies fun to args, returning the results to Sequel -slowCall fun stg_args +slowCall fun stg_args = do { dflags <- getDynFlags ; argsreps <- getArgRepsAmodes stg_args ; let (rts_fun, arity) = slowCallPattern (map fst argsreps) @@ -299,13 +291,13 @@ slowArgs dflags args -- careful: reps contains voids (V), but args does not save_cccs_lbl = mkCmmRetInfoLabel rtsPackageId (fsLit "stg_restore_cccs") ------------------------------------------------------------------------- ----- Laying out objects on the heap and stack +---- Laying out objects on the heap and stack ------------------------------------------------------------------------- -- The heap always grows upwards, so hpRel is easy -hpRel :: VirtualHpOffset -- virtual offset of Hp - -> VirtualHpOffset -- virtual offset of The Thing - -> WordOff -- integer word offset +hpRel :: VirtualHpOffset -- virtual offset of Hp + -> VirtualHpOffset -- virtual offset of The Thing + -> WordOff -- integer word offset hpRel hp off = off - hp getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr @@ -316,10 +308,10 @@ getHpRelOffset virtual_offset mkVirtHeapOffsets :: DynFlags - -> Bool -- True <=> is a thunk - -> [(PrimRep,a)] -- Things to make offsets for - -> (WordOff, -- _Total_ number of words allocated - WordOff, -- Number of words allocated for *pointers* + -> Bool -- True <=> is a thunk + -> [(PrimRep,a)] -- Things to make offsets for + -> (WordOff, -- _Total_ number of words allocated + WordOff, -- Number of words allocated for *pointers* [(NonVoid a, VirtualHpOffset)]) -- Things with their offsets from start of object in order of @@ -333,10 +325,10 @@ mkVirtHeapOffsets -- than the unboxed things mkVirtHeapOffsets dflags is_thunk things - = let non_void_things = filterOut (isVoidRep . fst) things - (ptrs, non_ptrs) = partition (isGcPtrRep . fst) non_void_things - (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs - (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs + = let non_void_things = filterOut (isVoidRep . fst) things + (ptrs, non_ptrs) = partition (isGcPtrRep . fst) non_void_things + (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs + (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs in (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets) where @@ -344,8 +336,8 @@ mkVirtHeapOffsets dflags is_thunk things | otherwise = fixedHdrSize dflags computeOffset wds_so_far (rep, thing) - = (wds_so_far + argRepSizeW dflags (toArgRep rep), - (NonVoid thing, hdr_size + wds_so_far)) + = (wds_so_far + argRepSizeW dflags (toArgRep rep), + (NonVoid thing, hdr_size + wds_so_far)) mkVirtConstrOffsets :: DynFlags -> [(PrimRep,a)] -> (WordOff, WordOff, [(NonVoid a, VirtualHpOffset)]) -- Just like mkVirtHeapOffsets, but for constructors @@ -354,11 +346,11 @@ mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False ------------------------------------------------------------------------- -- --- Making argument descriptors +-- Making argument descriptors -- -- An argument descriptor describes the layout of args on the stack, --- both for * GC (stack-layout) purposes, and --- * saving/restoring registers when a heap-check fails +-- both for * GC (stack-layout) purposes, and +-- * saving/restoring registers when a heap-check fails -- -- Void arguments aren't important, therefore (contrast constructSlowCall) -- @@ -367,17 +359,16 @@ mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False -- bring in ARG_P, ARG_N, etc. #include "../includes/rts/storage/FunTypes.h" -mkArgDescr :: Name -> [Id] -> FCode ArgDescr -mkArgDescr _nm args - = do dflags <- getDynFlags - let arg_bits = argBits dflags arg_reps - arg_reps = filter isNonV (map idArgRep args) +mkArgDescr :: DynFlags -> [Id] -> ArgDescr +mkArgDescr dflags args + = let arg_bits = argBits dflags arg_reps + arg_reps = filter isNonV (map idArgRep args) -- Getting rid of voids eases matching of standard patterns - case stdPattern arg_reps of - Just spec_id -> return (ArgSpec spec_id) - Nothing -> return (ArgGen arg_bits) + in case stdPattern arg_reps of + Just spec_id -> ArgSpec spec_id + Nothing -> ArgGen arg_bits -argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr +argBits :: DynFlags -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr argBits _ [] = [] argBits dflags (P : args) = False : argBits dflags args argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True) @@ -387,37 +378,37 @@ argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True) stdPattern :: [ArgRep] -> Maybe Int stdPattern reps = case reps of - [] -> Just ARG_NONE -- just void args, probably - [N] -> Just ARG_N - [P] -> Just ARG_P - [F] -> Just ARG_F - [D] -> Just ARG_D - [L] -> Just ARG_L - [V16] -> Just ARG_V16 - - [N,N] -> Just ARG_NN - [N,P] -> Just ARG_NP - [P,N] -> Just ARG_PN - [P,P] -> Just ARG_PP - - [N,N,N] -> Just ARG_NNN - [N,N,P] -> Just ARG_NNP - [N,P,N] -> Just ARG_NPN - [N,P,P] -> Just ARG_NPP - [P,N,N] -> Just ARG_PNN - [P,N,P] -> Just ARG_PNP - [P,P,N] -> Just ARG_PPN - [P,P,P] -> Just ARG_PPP - - [P,P,P,P] -> Just ARG_PPPP - [P,P,P,P,P] -> Just ARG_PPPPP - [P,P,P,P,P,P] -> Just ARG_PPPPPP - - _ -> Nothing + [] -> Just ARG_NONE -- just void args, probably + [N] -> Just ARG_N + [P] -> Just ARG_P + [F] -> Just ARG_F + [D] -> Just ARG_D + [L] -> Just ARG_L + [V16] -> Just ARG_V16 + + [N,N] -> Just ARG_NN + [N,P] -> Just ARG_NP + [P,N] -> Just ARG_PN + [P,P] -> Just ARG_PP + + [N,N,N] -> Just ARG_NNN + [N,N,P] -> Just ARG_NNP + [N,P,N] -> Just ARG_NPN + [N,P,P] -> Just ARG_NPP + [P,N,N] -> Just ARG_PNN + [P,N,P] -> Just ARG_PNP + [P,P,N] -> Just ARG_PPN + [P,P,P] -> Just ARG_PPP + + [P,P,P,P] -> Just ARG_PPPP + [P,P,P,P,P] -> Just ARG_PPPPP + [P,P,P,P,P,P] -> Just ARG_PPPPPP + + _ -> Nothing ------------------------------------------------------------------------- -- --- Generating the info table and code for a closure +-- Generating the info table and code for a closure -- ------------------------------------------------------------------------- @@ -427,7 +418,7 @@ stdPattern reps -- When loading the free variables, a function closure pointer may be tagged, -- so we must take it into account. -emitClosureProcAndInfoTable :: Bool -- top-level? +emitClosureProcAndInfoTable :: Bool -- top-level? -> Id -- name of the closure -> LambdaFormInfo -> CmmInfoTable diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 1f3d5c4886..17bad247e2 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -12,7 +12,7 @@ module StgCmmMonad ( initC, runC, thenC, thenFC, listCs, returnFC, fixC, - newUnique, newUniqSupply, + newUnique, newUniqSupply, newLabelC, emitLabel, @@ -26,7 +26,7 @@ module StgCmmMonad ( mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto, mkCall, mkCmmCall, - forkClosureBody, forkStatics, forkAlts, forkProc, codeOnly, + forkClosureBody, forkAlts, forkProc, codeOnly, ConTagZ, @@ -46,9 +46,9 @@ module StgCmmMonad ( -- ideally we wouldn't export these, but some other modules access internal state getState, setState, getInfoDown, getDynFlags, getThisPackage, - -- more localised access to monad state + -- more localised access to monad state CgIdInfo(..), CgLoc(..), - getBinds, setBinds, getStaticBinds, + getBinds, setBinds, -- out of general friendliness, we also export ... CgInfoDownwards(..), CgState(..) -- non-abstract @@ -76,7 +76,6 @@ import Outputable import Control.Monad import Data.List import Prelude hiding( sequence, succ ) -import qualified Prelude( sequence ) infixr 9 `thenC` -- Right-associative! infixr 9 `thenFC` @@ -133,7 +132,7 @@ returnFC :: a -> FCode a returnFC val = FCode (\_info_down state -> (# val, state #)) thenC :: FCode () -> FCode a -> FCode a -thenC (FCode m) (FCode k) = +thenC (FCode m) (FCode k) = FCode $ \info_down state -> case m info_down state of (# _,new_state #) -> k info_down new_state @@ -142,7 +141,7 @@ listCs [] = return () listCs (fc:fcs) = do fc listCs fcs - + thenFC :: FCode a -> (a -> FCode c) -> FCode c thenFC (FCode m) k = FCode $ \info_down state -> @@ -153,7 +152,7 @@ thenFC (FCode m) k = FCode $ fixC :: (a -> FCode a) -> FCode a fixC fcode = FCode ( - \info_down state -> + \info_down state -> let (v,s) = doFCode (fcode v) info_down state in @@ -164,15 +163,14 @@ fixC fcode = FCode ( -- The code generator environment -------------------------------------------------------- --- This monadery has some information that it only passes --- *downwards*, as well as some ``state'' which is modified +-- This monadery has some information that it only passes +-- *downwards*, as well as some ``state'' which is modified -- as we go along. data CgInfoDownwards -- information only passed *downwards* by the monad = MkCgInfoDown { cgd_dflags :: DynFlags, cgd_mod :: Module, -- Module being compiled - cgd_statics :: CgBindings, -- [Id -> info] : static environment cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame cgd_ticky :: CLabel, -- Current destination for ticky counts cgd_sequel :: Sequel -- What to do at end of basic block @@ -181,11 +179,11 @@ data CgInfoDownwards -- information only passed *downwards* by the monad type CgBindings = IdEnv CgIdInfo data CgIdInfo - = CgIdInfo + = CgIdInfo { cg_id :: Id -- Id that this is the info for - -- Can differ from the Id at occurrence sites by + -- Can differ from the Id at occurrence sites by -- virtue of being externalised, for splittable C - , cg_lf :: LambdaFormInfo + , cg_lf :: LambdaFormInfo , cg_loc :: CgLoc -- CmmExpr for the *tagged* value } @@ -194,9 +192,9 @@ data CgLoc -- Hp, so that it remains valid across calls | LneLoc BlockId [LocalReg] -- A join point - -- A join point (= let-no-escape) should only + -- A join point (= let-no-escape) should only -- be tail-called, and in a saturated way. - -- To tail-call it, assign to these locals, + -- To tail-call it, assign to these locals, -- and branch to the block id instance Outputable CgIdInfo where @@ -213,7 +211,7 @@ data Sequel = Return Bool -- Return result(s) to continuation found on the stack -- True <=> the continuation is update code (???) - | AssignTo + | AssignTo [LocalReg] -- Put result(s) in these regs and fall through -- NB: no void arguments here -- @@ -298,12 +296,11 @@ data ReturnKind initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards initCgInfoDown dflags mod - = MkCgInfoDown { cgd_dflags = dflags, - cgd_mod = mod, - cgd_statics = emptyVarEnv, - cgd_updfr_off = initUpdFrameOff dflags, - cgd_ticky = mkTopTickyCtrLabel, - cgd_sequel = initSequel } + = MkCgInfoDown { cgd_dflags = dflags + , cgd_mod = mod + , cgd_updfr_off = initUpdFrameOff dflags + , cgd_ticky = mkTopTickyCtrLabel + , cgd_sequel = initSequel } initSequel :: Sequel initSequel = Return False @@ -322,12 +319,10 @@ data CgState cgs_tops :: OrdList CmmDecl, -- Other procedures and data blocks in this compilation unit - -- Both are ordered only so that we can + -- Both are ordered only so that we can -- reduce forward references, when it's easy to do so - - cgs_binds :: CgBindings, -- [Id -> info] : *local* bindings environment - -- Bindings for top-level things are given in - -- the info-down part + + cgs_binds :: CgBindings, cgs_hp_usg :: HeapUsage, @@ -347,18 +342,19 @@ type VirtualHpOffset = WordOff initCgState :: UniqSupply -> CgState initCgState uniqs - = MkCgState { cgs_stmts = mkNop, cgs_tops = nilOL, - cgs_binds = emptyVarEnv, - cgs_hp_usg = initHpUsage, - cgs_uniqs = uniqs } + = MkCgState { cgs_stmts = mkNop + , cgs_tops = nilOL + , cgs_binds = emptyVarEnv + , cgs_hp_usg = initHpUsage + , cgs_uniqs = uniqs } stateIncUsage :: CgState -> CgState -> CgState --- stateIncUsage@ e1 e2 incorporates in e1 +-- stateIncUsage@ e1 e2 incorporates in e1 -- the heap high water mark found in e2. stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg }) = s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg } `addCodeBlocksFrom` s2 - + addCodeBlocksFrom :: CgState -> CgState -> CgState -- Add code blocks from the latter to the former -- (The cgs_stmts will often be empty, but not always; see codeOnly) @@ -371,13 +367,13 @@ s1 `addCodeBlocksFrom` s2 -- only records the high water marks of forked-off branches, so to find the -- heap high water mark you have to take the max of virtHp and hwHp. Remember, -- virtHp never retreats! --- +-- -- Note Jan 04: ok, so why do we only look at the virtual Hp?? heapHWM :: HeapUsage -> VirtualHpOffset heapHWM = virtHp -initHpUsage :: HeapUsage +initHpUsage :: HeapUsage initHpUsage = HeapUsage { virtHp = 0, realHp = 0 } maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage @@ -397,7 +393,7 @@ getHpUsage :: FCode HeapUsage getHpUsage = do state <- getState return $ cgs_hp_usg state - + setHpUsage :: HeapUsage -> FCode () setHpUsage new_hp_usg = do state <- getState @@ -405,36 +401,31 @@ setHpUsage new_hp_usg = do setVirtHp :: VirtualHpOffset -> FCode () setVirtHp new_virtHp - = do { hp_usage <- getHpUsage + = do { hp_usage <- getHpUsage ; setHpUsage (hp_usage {virtHp = new_virtHp}) } getVirtHp :: FCode VirtualHpOffset -getVirtHp - = do { hp_usage <- getHpUsage +getVirtHp + = do { hp_usage <- getHpUsage ; return (virtHp hp_usage) } setRealHp :: VirtualHpOffset -> FCode () setRealHp new_realHp - = do { hp_usage <- getHpUsage + = do { hp_usage <- getHpUsage ; setHpUsage (hp_usage {realHp = new_realHp}) } getBinds :: FCode CgBindings getBinds = do state <- getState return $ cgs_binds state - + setBinds :: CgBindings -> FCode () setBinds new_binds = do state <- getState setState $ state {cgs_binds = new_binds} -getStaticBinds :: FCode CgBindings -getStaticBinds = do - info <- getInfoDown - return (cgd_statics info) - withState :: FCode a -> CgState -> FCode (a,CgState) -withState (FCode fcode) newstate = FCode $ \info_down state -> +withState (FCode fcode) newstate = FCode $ \info_down state -> case fcode info_down newstate of (# retval, state2 #) -> (# (retval,state2), state #) @@ -447,8 +438,10 @@ newUniqSupply = do newUnique :: FCode Unique newUnique = do - us <- newUniqSupply - return (uniqFromSupply us) + state <- getState + let (u,us') = takeUniqFromSupply (cgs_uniqs state) + setState $ state { cgs_uniqs = us' } + return u ------------------ getInfoDown :: FCode CgInfoDownwards @@ -461,7 +454,7 @@ getThisPackage :: FCode PackageId getThisPackage = liftM thisPackage getDynFlags withInfoDown :: FCode a -> CgInfoDownwards -> FCode a -withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state +withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState) doFCode (FCode fcode) info_down state = @@ -479,7 +472,7 @@ getModuleName = do { info <- getInfoDown; return (cgd_mod info) } withSequel :: Sequel -> FCode a -> FCode a withSequel sequel code - = do { info <- getInfoDown + = do { info <- getInfoDown ; withInfoDown code (info {cgd_sequel = sequel }) } getSequel :: FCode Sequel @@ -498,12 +491,12 @@ getSequel = do { info <- getInfoDown withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a withUpdFrameOff size code - = do { info <- getInfoDown + = do { info <- getInfoDown ; withInfoDown code (info {cgd_updfr_off = size }) } getUpdFrameOff :: FCode UpdFrameOffset getUpdFrameOff - = do { info <- getInfoDown + = do { info <- getInfoDown ; return $ cgd_updfr_off info } -- ---------------------------------------------------------------------------- @@ -525,61 +518,43 @@ setTickyCtrLabel ticky code = do -------------------------------------------------------- forkClosureBody :: FCode () -> FCode () --- forkClosureBody takes a code, $c$, and compiles it in a +-- forkClosureBody takes a code, $c$, and compiles it in a -- fresh environment, except that: -- - compilation info and statics are passed in unchanged. -- - local bindings are passed in unchanged -- (it's up to the enclosed code to re-bind the -- free variables to a field of the closure) --- +-- -- The current state is passed on completely unaltered, except that -- C-- from the fork is incorporated. forkClosureBody body_code - = do { dflags <- getDynFlags - ; info <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let body_info_down = info { cgd_sequel = initSequel - , cgd_updfr_off = initUpdFrameOff dflags } - fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } - ((),fork_state_out) - = doFCode body_code body_info_down fork_state_in + = do { dflags <- getDynFlags + ; info <- getInfoDown + ; us <- newUniqSupply + ; state <- getState + ; let body_info_down = info { cgd_sequel = initSequel + , cgd_updfr_off = initUpdFrameOff dflags } + fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } + ((),fork_state_out) = doFCode body_code body_info_down fork_state_in ; setState $ state `addCodeBlocksFrom` fork_state_out } - -forkStatics :: FCode a -> FCode a --- @forkStatics@ $fc$ compiles $fc$ in an environment whose *statics* come --- from the current *local bindings*, but which is otherwise freshly initialised. --- The Abstract~C returned is attached to the current state, but the --- bindings and usage information is otherwise unchanged. -forkStatics body_code - = do { dflags <- getDynFlags - ; info <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let rhs_info_down = info { cgd_statics = cgs_binds state - , cgd_sequel = initSequel - , cgd_updfr_off = initUpdFrameOff dflags } - (result, fork_state_out) = doFCode body_code rhs_info_down - (initCgState us) - ; setState (state `addCodeBlocksFrom` fork_state_out) - ; return result } forkProc :: FCode a -> FCode a -- 'forkProc' takes a code and compiles it in the *current* environment, --- returning the graph thus constructed. +-- returning the graph thus constructed. -- -- The current environment is passed on completely unchanged to -- the successor. In particular, any heap usage from the enclosed --- code is discarded; it should deal with its own heap consumption +-- code is discarded; it should deal with its own heap consumption. +-- forkProc is used to compile let-no-escape bindings. forkProc body_code - = do { info_down <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let info_down' = info_down -- { cgd_sequel = initSequel } - fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } - (result, fork_state_out) = doFCode body_code info_down' fork_state_in - ; setState $ state `addCodeBlocksFrom` fork_state_out + = do { info_down <- getInfoDown + ; us <- newUniqSupply + ; state <- getState + ; let info_down' = info_down -- { cgd_sequel = initSequel } + fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } + (result, fork_state_out) = doFCode body_code info_down' fork_state_in + ; setState $ state `addCodeBlocksFrom` fork_state_out ; return result } codeOnly :: FCode () -> FCode () @@ -587,7 +562,7 @@ codeOnly :: FCode () -> FCode () -- Do not affect anything else in the outer state -- Used in almost-circular code to prevent false loop dependencies codeOnly body_code - = do { info_down <- getInfoDown + = do { info_down <- getInfoDown ; us <- newUniqSupply ; state <- getState ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state, @@ -622,7 +597,7 @@ forkAlts branch_fcodes -- collect the code emitted by an FCode computation getCodeR :: FCode a -> FCode (a, CmmAGraph) getCodeR fcode - = do { state1 <- getState + = do { state1 <- getState ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop }) ; setState $ state2 { cgs_stmts = cgs_stmts state1 } ; return (a, cgs_stmts state2) } @@ -632,21 +607,21 @@ getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts } -- 'getHeapUsage' applies a function to the amount of heap that it uses. -- It initialises the heap usage to zeros, and passes on an unchanged --- heap usage. +-- heap usage. -- -- It is usually a prelude to performing a GC check, so everything must -- be in a tidy and consistent state. --- +-- -- Note the slightly subtle fixed point behaviour needed here getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a getHeapUsage fcode - = do { info_down <- getInfoDown + = do { info_down <- getInfoDown ; state <- getState ; let fstate_in = state { cgs_hp_usg = initHpUsage } (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in hp_hw = heapHWM (cgs_hp_usg fstate_out) -- Loop here! - + ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state } ; return r } @@ -682,12 +657,12 @@ newLabelC = do { u <- newUnique emit :: CmmAGraph -> FCode () emit ag - = do { state <- getState + = do { state <- getState ; setState $ state { cgs_stmts = cgs_stmts state <*> ag } } emitDecl :: CmmDecl -> FCode () emitDecl decl - = do { state <- getState + = do { state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } } emitOutOfLine :: BlockId -> CmmAGraph -> FCode () @@ -752,10 +727,10 @@ getCmm :: FCode () -> FCode CmmGroup -- Get all the CmmTops (there should be no stmts) -- Return a single Cmm which may be split from other Cmms by -- object splitting (at a later stage) -getCmm code - = do { state1 <- getState +getCmm code + = do { state1 <- getState ; ((), state2) <- withState code (state1 { cgs_tops = nilOL }) - ; setState $ state2 { cgs_tops = cgs_tops state1 } + ; setState $ state2 { cgs_tops = cgs_tops state1 } ; return (fromOL (cgs_tops state2)) } @@ -776,7 +751,7 @@ mkCmmIfGoto e tid = do mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph mkCmmIfThen e tbranch = do endif <- newLabelC - tid <- newLabelC + tid <- newLabelC return $ mkCbranch e tid endif <*> mkLabel tid <*> tbranch <*> mkLabel endif @@ -785,7 +760,7 @@ mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset -> [CmmActual] -> FCode CmmAGraph mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do dflags <- getDynFlags - k <- newLabelC + k <- newLabelC let area = Young k (off, _, copyin) = copyInOflow dflags retConv area results [] copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index fb5acde956..c11df7009c 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -36,7 +36,6 @@ import CLabel import CmmUtils import PrimOp import SMRep -import Module import FastString import Outputable import Util @@ -108,15 +107,6 @@ cgOpApp (StgPrimOp primop) args res_ty cgPrimOp regs primop args emitReturn (map (CmmReg . CmmLocal) regs) - | ReturnsAlg tycon <- result_info - , isEnumerationTyCon tycon - -- c.f. cgExpr (...TagToEnumOp...) - = do dflags <- getDynFlags - tag_reg <- newTemp (bWord dflags) - cgPrimOp [tag_reg] primop args - emitReturn [tagToClosure dflags tycon - (CmmReg (CmmLocal tag_reg))] - | otherwise = panic "cgPrimop" where result_info = getPrimOpResultInfo primop @@ -214,7 +204,7 @@ emitPrimOp _ [res] ParOp [arg] -- later, we might want to inline it. emitCCall [(res,NoHint)] - (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) + (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction))) [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] emitPrimOp dflags [res] SparkOp [arg] @@ -226,7 +216,7 @@ emitPrimOp dflags [res] SparkOp [arg] tmp2 <- newTemp (bWord dflags) emitCCall [(tmp2,NoHint)] - (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) + (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction))) [(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp)) @@ -542,6 +532,11 @@ emitPrimOp _ [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] = emitPrimOp _ [] SetByteArrayOp [ba,off,len,c] = doSetByteArrayOp ba off len c +emitPrimOp _ [res] BSwap16Op [w] = emitBSwapCall res w W16 +emitPrimOp _ [res] BSwap32Op [w] = emitBSwapCall res w W32 +emitPrimOp _ [res] BSwap64Op [w] = emitBSwapCall res w W64 +emitPrimOp dflags [res] BSwapOp [w] = emitBSwapCall res w (wordWidth dflags) + -- Population count emitPrimOp _ [res] PopCnt8Op [w] = emitPopCntCall res w W8 emitPrimOp _ [res] PopCnt16Op [w] = emitPopCntCall res w W16 @@ -1043,7 +1038,7 @@ doIndexOffAddrOp _ _ _ _ doIndexOffAddrOpAs :: Maybe MachOp -> CmmType - -> CmmType + -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode () @@ -1060,19 +1055,19 @@ doIndexByteArrayOp :: Maybe MachOp doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] = do dflags <- getDynFlags mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx -doIndexByteArrayOp _ _ _ _ +doIndexByteArrayOp _ _ _ _ = panic "StgCmmPrim: doIndexByteArrayOp" doIndexByteArrayOpAs :: Maybe MachOp -> CmmType - -> CmmType + -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode () doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] = do dflags <- getDynFlags mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx -doIndexByteArrayOpAs _ _ _ _ _ +doIndexByteArrayOpAs _ _ _ _ _ = panic "StgCmmPrim: doIndexByteArrayOpAs" doReadPtrArrayOp :: LocalReg @@ -1217,7 +1212,7 @@ doVecPackOp maybe_pre_write_cast ty z es res = do Just cast -> CmmMachOp cast [val] len :: Length - len = vecLength ty + len = vecLength ty wid :: Width wid = typeWidth (vecElemType ty) @@ -1251,7 +1246,7 @@ doVecUnpackOp maybe_post_read_cast ty e res = Just cast -> CmmMachOp cast [val] len :: Length - len = vecLength ty + len = vecLength ty wid :: Width wid = typeWidth (vecElemType ty) @@ -1278,7 +1273,7 @@ doVecInsertOp maybe_pre_write_cast ty src e idx res = do Just cast -> CmmMachOp cast [val] len :: Length - len = vecLength ty + len = vecLength ty wid :: Width wid = typeWidth (vecElemType ty) @@ -1569,6 +1564,13 @@ emitAllocateCall res cap n = do allocate = CmmLit (CmmLabel (mkForeignLabel (fsLit "allocate") Nothing ForeignLabelInExternalPackage IsFunction)) +emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitBSwapCall res x width = do + emitPrimCall + [ res ] + (MO_BSwap width) + [ x ] + emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode () emitPopCntCall res x width = do emitPrimCall diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index 3307604a87..5044d763a4 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -6,28 +6,21 @@ -- ----------------------------------------------------------------------------- -{-# 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 StgCmmProf ( - initCostCentres, ccType, ccsType, - mkCCostCentre, mkCCostCentreStack, + initCostCentres, ccType, ccsType, + mkCCostCentre, mkCCostCentreStack, - -- Cost-centre Profiling - dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf, + -- Cost-centre Profiling + dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf, enterCostCentreThunk, enterCostCentreFun, costCentreFrom, curCCS, storeCurCCS, emitSetCCC, - saveCurrentCostCentre, restoreCurrentCostCentre, + saveCurrentCostCentre, restoreCurrentCostCentre, - -- Lag/drag/void stuff - ldvEnter, ldvEnterClosure, ldvRecordCreate + -- Lag/drag/void stuff + ldvEnter, ldvEnterClosure, ldvRecordCreate ) where #include "HsVersions.h" @@ -78,8 +71,8 @@ mkCCostCentreStack :: CostCentreStack -> CmmLit mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs) costCentreFrom :: DynFlags - -> CmmExpr -- A closure pointer - -> CmmExpr -- The cost centre from that closure + -> CmmExpr -- A closure pointer + -> CmmExpr -- The cost centre from that closure costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags) -- | The profiling header words in a static closure @@ -94,43 +87,43 @@ dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags] -- | Initialise the profiling field of an update frame initUpdFrameProf :: CmmExpr -> FCode () initUpdFrameProf frame - = ifProfiling $ -- frame->header.prof.ccs = CCCS + = ifProfiling $ -- frame->header.prof.ccs = CCCS do dflags <- getDynFlags emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) curCCS -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) - -- is unnecessary because it is not used anyhow. + -- is unnecessary because it is not used anyhow. --------------------------------------------------------------------------- --- Saving and restoring the current cost centre +-- Saving and restoring the current cost centre --------------------------------------------------------------------------- -{- Note [Saving the current cost centre] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The current cost centre is like a global register. Like other +{- Note [Saving the current cost centre] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The current cost centre is like a global register. Like other global registers, it's a caller-saves one. But consider - case (f x) of (p,q) -> rhs -Since 'f' may set the cost centre, we must restore it + case (f x) of (p,q) -> rhs +Since 'f' may set the cost centre, we must restore it before resuming rhs. So we want code like this: - local_cc = CCC -- save - r = f( x ) - CCC = local_cc -- restore + local_cc = CCC -- save + r = f( x ) + CCC = local_cc -- restore That is, we explicitly "save" the current cost centre in a LocalReg, local_cc; and restore it after the call. The C-- infrastructure will arrange to save local_cc across the -call. +call. The same goes for join points; - let j x = join-stuff - in blah-blah + let j x = join-stuff + in blah-blah We want this kind of code: - local_cc = CCC -- save - blah-blah - J: + local_cc = CCC -- save + blah-blah + J: CCC = local_cc -- restore -} saveCurrentCostCentre :: FCode (Maybe LocalReg) - -- Returns Nothing if profiling is off + -- Returns Nothing if profiling is off saveCurrentCostCentre = do dflags <- getDynFlags if not (gopt Opt_SccProfilingOn dflags) @@ -140,7 +133,7 @@ saveCurrentCostCentre return (Just local_cc) restoreCurrentCostCentre :: Maybe LocalReg -> FCode () -restoreCurrentCostCentre Nothing +restoreCurrentCostCentre Nothing = return () restoreCurrentCostCentre (Just local_cc) = emit (storeCurCCS (CmmReg (CmmLocal local_cc))) @@ -178,7 +171,7 @@ profAlloc words ccs -- Setting the current cost centre on entry to a closure enterCostCentreThunk :: CmmExpr -> FCode () -enterCostCentreThunk closure = +enterCostCentreThunk closure = ifProfiling $ do dflags <- getDynFlags emit $ storeCurCCS (costCentreFrom dflags closure) @@ -207,7 +200,7 @@ ifProfilingL dflags xs --------------------------------------------------------------- --- Initialising Cost Centres & CCSs +-- Initialising Cost Centres & CCSs --------------------------------------------------------------- initCostCentres :: CollectedCCs -> FCode () @@ -220,7 +213,7 @@ initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) emitCostCentreDecl :: CostCentre -> FCode () -emitCostCentreDecl cc = do +emitCostCentreDecl cc = do { dflags <- getDynFlags ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF | otherwise = zero dflags @@ -233,20 +226,20 @@ emitCostCentreDecl cc = do showPpr dflags (costCentreSrcSpan cc) -- XXX going via FastString to get UTF-8 encoding is silly ; let - lits = [ zero dflags, -- StgInt ccID, - label, -- char *label, - modl, -- char *module, + lits = [ zero dflags, -- StgInt ccID, + label, -- char *label, + modl, -- char *module, loc, -- char *srcloc, zero64, -- StgWord64 mem_alloc zero dflags, -- StgWord time_ticks is_caf, -- StgInt is_caf zero dflags -- struct _CostCentre *link - ] + ] ; emitDataLits (mkCCLabel cc) lits } emitCostCentreStackDecl :: CostCentreStack -> FCode () -emitCostCentreStackDecl ccs +emitCostCentreStackDecl ccs = case maybeSingletonCCS ccs of Just cc -> do dflags <- getDynFlags @@ -290,19 +283,19 @@ emitSetCCC cc tick push pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc = emitRtsCallWithResult result AddrHint - rtsPackageId + rtsPackageId (fsLit "pushCostCentre") [(ccs,AddrHint), - (CmmLit (mkCCostCentre cc), AddrHint)] + (CmmLit (mkCCostCentre cc), AddrHint)] False bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph bumpSccCount dflags ccs = addToMem (rEP_CostCentreStack_scc_count dflags) - (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 + (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 ----------------------------------------------------------------------------- -- --- Lag/drag/void stuff +-- Lag/drag/void stuff -- ----------------------------------------------------------------------------- @@ -316,12 +309,12 @@ staticLdvInit = zeroCLit -- Initial value of the LDV field in a dynamic closure -- dynLdvInit :: DynFlags -> CmmExpr -dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE +dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE CmmMachOp (mo_wordOr dflags) [ CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)], CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags)) ] - + -- -- Initialise the LDV word of a new closure -- @@ -340,7 +333,7 @@ ldvEnterClosure closure_info = do dflags <- getDynFlags let tag = funTag dflags closure_info ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag)) -- don't forget to substract node's tag - + ldvEnter :: CmmExpr -> FCode () -- Argument is a closure pointer ldvEnter cl_ptr = do @@ -364,8 +357,7 @@ loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags)) (cInt dflags)] ldvWord :: DynFlags -> CmmExpr -> CmmExpr --- Takes the address of a closure, and returns +-- Takes the address of a closure, and returns -- the address of the LDV word in the closure ldvWord dflags closure_ptr = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags) - diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index 79afe0b17e..3b06d3ba62 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -133,7 +133,7 @@ import TyCon import Data.Maybe import qualified Data.Char -import Control.Monad ( when ) +import Control.Monad ( unless, when ) ----------------------------------------------------------------------------- -- @@ -150,10 +150,13 @@ withNewTickyCounterLNE nm args code = do b <- tickyLNEIsOn if not b then code else withNewTickyCounter TickyLNE nm args code -withNewTickyCounterThunk,withNewTickyCounterStdThunk :: Name -> FCode a -> FCode a -withNewTickyCounterThunk name code = do +withNewTickyCounterThunk,withNewTickyCounterStdThunk :: + Bool -> Name -> FCode a -> FCode a +withNewTickyCounterThunk isStatic name code = do b <- tickyDynThunkIsOn - if not b then code else withNewTickyCounter TickyThunk name [] code + if isStatic || not b -- ignore static thunks + then code + else withNewTickyCounter TickyThunk name [] code withNewTickyCounterStdThunk = withNewTickyCounterThunk @@ -235,15 +238,24 @@ tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr") tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr") tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr") -tickyEnterThunk :: FCode () -tickyEnterThunk = ifTicky $ do - bumpTickyCounter (fsLit "ENT_DYN_THK_ctr") - ifTickyDynThunk $ do - ticky_ctr_lbl <- getTickyCtrLabel - registerTickyCtrAtEntryDyn ticky_ctr_lbl - bumpTickyEntryCount ticky_ctr_lbl +tickyEnterThunk :: ClosureInfo -> FCode () +tickyEnterThunk cl_info + = ifTicky $ do + { bumpTickyCounter ctr + ; unless static $ do + ticky_ctr_lbl <- getTickyCtrLabel + registerTickyCtrAtEntryDyn ticky_ctr_lbl + bumpTickyEntryCount ticky_ctr_lbl } + where + updatable = closureSingleEntry cl_info + static = isStaticClosure cl_info + + ctr | static = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr" + else fsLit "ENT_STATIC_THK_MANY_ctr" + | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr" + else fsLit "ENT_DYN_THK_MANY_ctr" -tickyEnterStdThunk :: FCode () +tickyEnterStdThunk :: ClosureInfo -> FCode () tickyEnterStdThunk = tickyEnterThunk tickyBlackHole :: Bool{-updatable-} -> FCode () @@ -558,19 +570,18 @@ bumpTickyLit lhs = bumpTickyLitBy lhs 1 bumpTickyLitBy :: CmmLit -> Int -> FCode () bumpTickyLitBy lhs n = do dflags <- getDynFlags - -- All the ticky-ticky counters are declared "unsigned long" in C - emit (addToMem (cLong dflags) (CmmLit lhs) n) + emit (addToMem (bWord dflags) (CmmLit lhs) n) bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode () bumpTickyLitByE lhs e = do dflags <- getDynFlags - -- All the ticky-ticky counters are declared "unsigned long" in C - emit (addToMemE (cLong dflags) (CmmLit lhs) e) + emit (addToMemE (bWord dflags) (CmmLit lhs) e) bumpHistogram :: FastString -> Int -> FCode () bumpHistogram _lbl _n -- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongWidth)) = return () -- TEMP SPJ Apr 07 + -- six years passed - still temp? JS Aug 2013 {- bumpHistogramE :: LitString -> CmmExpr -> FCode () diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 3df75ceaa2..45b0f0c785 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -173,22 +173,21 @@ tagToClosure dflags tycon tag ------------------------------------------------------------------------- emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () -emitRtsCall pkg fun args safe = emitRtsCallGen [] pkg fun args safe +emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCallWithResult res hint pkg fun args safe - = emitRtsCallGen [(res,hint)] pkg fun args safe + = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe -- Make a call to an RTS C procedure emitRtsCallGen :: [(LocalReg,ForeignHint)] - -> PackageId - -> FastString + -> CLabel -> [(CmmExpr,ForeignHint)] -> Bool -- True <=> CmmSafe call -> FCode () -emitRtsCallGen res pkg fun args safe +emitRtsCallGen res lbl args safe = do { dflags <- getDynFlags ; updfr_off <- getUpdFrameOff ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags @@ -204,7 +203,7 @@ emitRtsCallGen res pkg fun args safe emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args' (args', arg_hints) = unzip args (res', res_hints) = unzip res - fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun) + fun_expr = mkLblExpr lbl ----------------------------------------------------------------------------- diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs index 6b9e3e8d9f..7bf15d8216 100644 --- a/compiler/coreSyn/CoreArity.lhs +++ b/compiler/coreSyn/CoreArity.lhs @@ -30,7 +30,7 @@ import Var import VarEnv import Id import Type -import TyCon ( isRecursiveTyCon, isClassTyCon ) +import TyCon ( initRecTc, checkRecTc ) import Coercion import BasicTypes import Unique @@ -88,7 +88,7 @@ exprArity e = go e go (Lam x e) | isId x = go e + 1 | otherwise = go e go (Tick t e) | not (tickishIsCode t) = go e - go (Cast e co) = go e `min` length (typeArity (pSnd (coercionKind co))) + go (Cast e co) = trim_arity (go e) (pSnd (coercionKind co)) -- Note [exprArity invariant] go (App e (Type _)) = go e go (App f a) | exprIsTrivial a = (go f - 1) `max` 0 @@ -97,6 +97,8 @@ exprArity e = go e go _ = 0 + trim_arity :: Arity -> Type -> Arity + trim_arity arity ty = arity `min` length (typeArity ty) --------------- typeArity :: Type -> [OneShot] @@ -104,24 +106,32 @@ typeArity :: Type -> [OneShot] -- We look through foralls, and newtypes -- See Note [exprArity invariant] typeArity ty - | Just (_, ty') <- splitForAllTy_maybe ty - = typeArity ty' - - | Just (arg,res) <- splitFunTy_maybe ty - = isStateHackType arg : typeArity res - - | Just (tc,tys) <- splitTyConApp_maybe ty - , Just (ty', _) <- instNewTyCon_maybe tc tys - , not (isRecursiveTyCon tc) - , not (isClassTyCon tc) -- Do not eta-expand through newtype classes - -- See Note [Newtype classes and eta expansion] - = typeArity ty' + = go initRecTc ty + where + go rec_nts ty + | Just (_, ty') <- splitForAllTy_maybe ty + = go rec_nts ty' + + | Just (arg,res) <- splitFunTy_maybe ty + = isStateHackType arg : go rec_nts res + + | Just (tc,tys) <- splitTyConApp_maybe ty + , Just (ty', _) <- instNewTyCon_maybe tc tys + , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] + -- in TyCon +-- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes +-- -- See Note [Newtype classes and eta expansion] +-- (no longer required) + = go rec_nts' ty' -- Important to look through non-recursive newtypes, so that, eg -- (f x) where f has arity 2, f :: Int -> IO () -- Here we want to get arity 1 for the result! + -- + -- AND through a layer of recursive newtypes + -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b))) - | otherwise - = [] + | otherwise + = [] --------------- exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig) @@ -168,6 +178,11 @@ in exprArity. That is a less local change, so I'm going to leave it for today! Note [Newtype classes and eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + NB: this nasty special case is no longer required, becuase + for newtype classes we don't use the class-op rule mechanism + at all. See Note [Single-method classes] in TcInstDcls. SLPJ May 2013 + +-------- Old out of date comments, just for interest ----------- We have to be careful when eta-expanding through newtypes. In general it's a good idea, but annoyingly it interacts badly with the class-op rule mechanism. Consider @@ -207,6 +222,7 @@ exprIsConApp_maybe won't hold of the argument to op. I considered trying to *make* it hold, but it's tricky and I gave up. The test simplCore/should_compile/T3722 is an excellent example. +-------- End of old out of date comments, just for interest ----------- Note [exprArity for applications] @@ -542,7 +558,7 @@ PAPSs f = g d ==> f = \x. g d x because that might in turn make g inline (if it has an inline pragma), which we might not want. After all, INLINE pragmas say "inline only -when saturate" so we don't want to be too gung-ho about saturating! +when saturated" so we don't want to be too gung-ho about saturating! \begin{code} arityLam :: Id -> ArityType -> ArityType @@ -726,7 +742,7 @@ The biggest reason for doing this is for cases like True -> \y -> e1 False -> \y -> e2 -Here we want to get the lambdas together. A good exmaple is the nofib +Here we want to get the lambdas together. A good example is the nofib program fibheaps, which gets 25% more allocation if you don't do this eta-expansion. diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index 2a11723fa9..636c049c42 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -104,8 +104,17 @@ type InterestingVarFun = Var -> Bool \begin{code} type FV = InterestingVarFun - -> VarSet -- In scope + -> VarSet -- Locally bound -> VarSet -- Free vars + -- Return the vars that are both (a) interesting + -- and (b) not locally bound + -- See function keep_it + +keep_it :: InterestingVarFun -> VarSet -> Var -> Bool +keep_it fv_cand in_scope var + | var `elemVarSet` in_scope = False + | fv_cand var = True + | otherwise = False union :: FV -> FV -> FV union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope @@ -152,13 +161,6 @@ someVars :: VarSet -> FV someVars vars fv_cand in_scope = filterVarSet (keep_it fv_cand in_scope) vars -keep_it :: InterestingVarFun -> VarSet -> Var -> Bool -keep_it fv_cand in_scope var - | var `elemVarSet` in_scope = False - | fv_cand var = True - | otherwise = False - - addBndr :: CoreBndr -> FV -> FV addBndr bndr fv fv_cand in_scope = someVars (varTypeTyVars bndr) fv_cand in_scope @@ -434,15 +436,18 @@ idUnfoldingVars :: Id -> VarSet -- and we'll get exponential behaviour if we look at both unf and rhs! -- But do look at the *real* unfolding, even for loop breakers, else -- we might get out-of-scope variables -idUnfoldingVars id = stableUnfoldingVars isLocalId (realIdUnfolding id) `orElse` emptyVarSet +idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id) `orElse` emptyVarSet -stableUnfoldingVars :: InterestingVarFun -> Unfolding -> Maybe VarSet -stableUnfoldingVars fv_cand unf +stableUnfoldingVars :: Unfolding -> Maybe VarSet +stableUnfoldingVars unf = case unf of CoreUnfolding { uf_tmpl = rhs, uf_src = src } - | isStableSource src -> Just (exprSomeFreeVars fv_cand rhs) - DFunUnfolding _ _ args -> Just (exprsSomeFreeVars fv_cand (dfunArgExprs args)) - _other -> Nothing + | isStableSource src + -> Just (exprFreeVars rhs) + DFunUnfolding { df_bndrs = bndrs, df_args = args } + -> Just (exprs_fvs args isLocalVar (mkVarSet bndrs)) + -- DFuns are top level, so no fvs from types of bndrs + _other -> Nothing \end{code} diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 0e9bcce895..68aaea5b5c 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -24,7 +24,6 @@ import Demand import CoreSyn import CoreFVs import CoreUtils -import Pair import Bag import Literal import DataCon @@ -199,21 +198,25 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) do { ty <- lintCoreExpr rhs ; lintBinder binder -- Check match to RHS type ; binder_ty <- applySubstTy binder_ty - ; checkTys binder_ty ty (mkRhsMsg binder ty) + ; checkTys binder_ty ty (mkRhsMsg binder (ptext (sLit "RHS")) ty) + -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples) ; checkL (not (isUnLiftedType binder_ty) || (isNonRec rec_flag && exprOkForSpeculation rhs)) (mkRhsPrimMsg binder rhs) + -- Check that if the binder is top-level or recursive, it's not demanded ; checkL (not (isStrictId binder) || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))) (mkStrictMsg binder) + -- Check that if the binder is local, it is not marked as exported ; checkL (not (isExportedId binder) || isTopLevel top_lvl_flag) (mkNonTopExportedMsg binder) -- Check that if the binder is local, it does not have an external name ; checkL (not (isExternalName (Var.varName binder)) || isTopLevel top_lvl_flag) (mkNonTopExternalNameMsg binder) + -- Check whether binder's specialisations contain any out-of-scope variables ; mapM_ (checkBndrIdInScope binder) bndr_vars @@ -225,7 +228,9 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) -- already happened) ; checkL (case dmdTy of StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs) - (mkArityMsg binder) } + (mkArityMsg binder) + + ; lintIdUnfolding binder binder_ty (idUnfolding binder) } -- We should check the unfolding, if any, but this is tricky because -- the unfolding is a SimplifiableCoreExpr. Give up for now. @@ -238,6 +243,14 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) -- See Note [GHC Formalism] lintBinder var | isId var = lintIdBndr var $ \_ -> (return ()) | otherwise = return () + +lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () +lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) + | isStableSource src + = do { ty <- lintCoreExpr rhs + ; checkTys bndr_ty ty (mkRhsMsg bndr (ptext (sLit "unfolding")) ty) } +lintIdUnfolding _ _ _ + = return () -- We could check more \end{code} %************************************************************************ @@ -292,7 +305,8 @@ lintCoreExpr (Lit lit) lintCoreExpr (Cast expr co) = do { expr_ty <- lintCoreExpr expr ; co' <- applySubstCo co - ; (_, from_ty, to_ty) <- lintCoercion co' + ; (_, from_ty, to_ty, r) <- lintCoercion co' + ; checkRole co' Representational r ; checkTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) ; return to_ty } @@ -386,9 +400,8 @@ lintCoreExpr (Type ty) = pprPanic "lintCoreExpr" (ppr ty) lintCoreExpr (Coercion co) - = do { co' <- lintInCo co - ; let Pair ty1 ty2 = coercionKind co' - ; return (mkCoercionType ty1 ty2) } + = do { (_kind, ty1, ty2, role) <- lintInCo co + ; return (mkCoercionType role ty1 ty2) } \end{code} @@ -790,49 +803,56 @@ lint_app doc kfn kas %************************************************************************ \begin{code} -lintInCo :: InCoercion -> LintM OutCoercion +lintInCo :: InCoercion -> LintM (LintedKind, LintedType, LintedType, Role) -- Check the coercion, and apply the substitution to it -- See Note [Linting type lets] lintInCo co = addLoc (InCo co) $ do { co' <- applySubstCo co - ; _ <- lintCoercion co' - ; return co' } + ; lintCoercion co' } -lintCoercion :: OutCoercion -> LintM (LintedKind, LintedType, LintedType) +lintCoercion :: OutCoercion -> LintM (LintedKind, LintedType, LintedType, Role) -- Check the kind of a coercion term, returning the kind -- Post-condition: the returned OutTypes are lint-free -- and have the same kind as each other -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] -lintCoercion (Refl ty) +lintCoercion (Refl r ty) = do { k <- lintType ty - ; return (k, ty, ty) } + ; return (k, ty, ty, r) } -lintCoercion co@(TyConAppCo tc cos) +lintCoercion co@(TyConAppCo r tc cos) | tc `hasKey` funTyConKey , [co1,co2] <- cos - = do { (k1,s1,t1) <- lintCoercion co1 - ; (k2,s2,t2) <- lintCoercion co2 + = do { (k1,s1,t1,r1) <- lintCoercion co1 + ; (k2,s2,t2,r2) <- lintCoercion co2 ; rk <- lintArrow (ptext (sLit "coercion") <+> quotes (ppr co)) k1 k2 - ; return (rk, mkFunTy s1 s2, mkFunTy t1 t2) } + ; checkRole co1 r r1 + ; checkRole co2 r r2 + ; return (rk, mkFunTy s1 s2, mkFunTy t1 t2, r) } | otherwise - = do { (ks,ss,ts) <- mapAndUnzip3M lintCoercion cos + = do { (ks,ss,ts,rs) <- mapAndUnzip4M lintCoercion cos ; rk <- lint_co_app co (tyConKind tc) (ss `zip` ks) - ; return (rk, mkTyConApp tc ss, mkTyConApp tc ts) } + ; _ <- zipWith3M checkRole cos (tyConRolesX r tc) rs + ; return (rk, mkTyConApp tc ss, mkTyConApp tc ts, r) } lintCoercion co@(AppCo co1 co2) - = do { (k1,s1,t1) <- lintCoercion co1 - ; (k2,s2,t2) <- lintCoercion co2 + = do { (k1,s1,t1,r1) <- lintCoercion co1 + ; (k2,s2,t2,r2) <- lintCoercion co2 ; rk <- lint_co_app co k1 [(s2,k2)] - ; return (rk, mkAppTy s1 s2, mkAppTy t1 t2) } + ; if r1 == Phantom + then checkL (r2 == Phantom || r2 == Nominal) + (ptext (sLit "Second argument in AppCo cannot be R:") $$ + ppr co) + else checkRole co Nominal r2 + ; return (rk, mkAppTy s1 s2, mkAppTy t1 t2, r1) } lintCoercion (ForAllCo tv co) = do { lintTyBndrKind tv - ; (k, s, t) <- addInScopeVar tv (lintCoercion co) - ; return (k, mkForAllTy tv s, mkForAllTy tv t) } + ; (k, s, t, r) <- addInScopeVar tv (lintCoercion co) + ; return (k, mkForAllTy tv s, mkForAllTy tv t, r) } lintCoercion (CoVarCo cv) | not (isCoVar cv) @@ -843,52 +863,58 @@ lintCoercion (CoVarCo cv) ; cv' <- lookupIdInScope cv ; let (s,t) = coVarKind cv' k = typeKind s + r = coVarRole cv' ; when (isSuperKind k) $ - checkL (s `eqKind` t) (hang (ptext (sLit "Non-refl kind equality")) - 2 (ppr cv)) - ; return (k, s, t) } + do { checkL (r == Nominal) (hang (ptext (sLit "Non-nominal kind equality")) + 2 (ppr cv)) + ; checkL (s `eqKind` t) (hang (ptext (sLit "Non-refl kind equality")) + 2 (ppr cv)) } + ; return (k, s, t, r) } -lintCoercion (UnsafeCo ty1 ty2) +lintCoercion (UnivCo r ty1 ty2) = do { k1 <- lintType ty1 ; _k2 <- lintType ty2 -- ; unless (k1 `eqKind` k2) $ -- failWithL (hang (ptext (sLit "Unsafe coercion changes kind")) -- 2 (ppr co)) - ; return (k1, ty1, ty2) } + ; return (k1, ty1, ty2, r) } lintCoercion (SymCo co) - = do { (k, ty1, ty2) <- lintCoercion co - ; return (k, ty2, ty1) } + = do { (k, ty1, ty2, r) <- lintCoercion co + ; return (k, ty2, ty1, r) } lintCoercion co@(TransCo co1 co2) - = do { (k1, ty1a, ty1b) <- lintCoercion co1 - ; (_, ty2a, ty2b) <- lintCoercion co2 + = do { (k1, ty1a, ty1b, r1) <- lintCoercion co1 + ; (_, ty2a, ty2b, r2) <- lintCoercion co2 ; checkL (ty1b `eqType` ty2a) (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co) 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b])) - ; return (k1, ty1a, ty2b) } + ; checkRole co r1 r2 + ; return (k1, ty1a, ty2b, r1) } lintCoercion the_co@(NthCo n co) - = do { (_,s,t) <- lintCoercion co + = do { (_,s,t,r) <- lintCoercion co ; case (splitTyConApp_maybe s, splitTyConApp_maybe t) of (Just (tc_s, tys_s), Just (tc_t, tys_t)) | tc_s == tc_t , tys_s `equalLength` tys_t , n < length tys_s - -> return (ks, ts, tt) + -> return (ks, ts, tt, tr) where ts = getNth tys_s n tt = getNth tys_t n + tr = nthRole r tc_s n ks = typeKind ts _ -> failWithL (hang (ptext (sLit "Bad getNth:")) 2 (ppr the_co $$ ppr s $$ ppr t)) } lintCoercion the_co@(LRCo lr co) - = do { (_,s,t) <- lintCoercion co + = do { (_,s,t,r) <- lintCoercion co + ; checkRole co Nominal r ; case (splitAppTy_maybe s, splitAppTy_maybe t) of (Just s_pr, Just t_pr) - -> return (k, s_pick, t_pick) + -> return (k, s_pick, t_pick, Nominal) where s_pick = pickLR lr s_pr t_pick = pickLR lr t_pr @@ -898,13 +924,13 @@ lintCoercion the_co@(LRCo lr co) 2 (ppr the_co $$ ppr s $$ ppr t)) } lintCoercion (InstCo co arg_ty) - = do { (k,s,t) <- lintCoercion co - ; arg_kind <- lintType arg_ty + = do { (k,s,t,r) <- lintCoercion co + ; arg_kind <- lintType arg_ty ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of (Just (tv1,ty1), Just (tv2,ty2)) | arg_kind `isSubKind` tyVarKind tv1 -> return (k, substTyWith [tv1] [arg_ty] ty1, - substTyWith [tv2] [arg_ty] ty2) + substTyWith [tv2] [arg_ty] ty2, r) | otherwise -> failWithL (ptext (sLit "Kind mis-match in inst coercion")) _ -> failWithL (ptext (sLit "Bad argument of inst")) } @@ -913,27 +939,29 @@ lintCoercion co@(AxiomInstCo con ind cos) = do { unless (0 <= ind && ind < brListLength (coAxiomBranches con)) (bad_ax (ptext (sLit "index out of range"))) -- See Note [Kind instantiation in coercions] - ; let CoAxBranch { cab_tvs = ktvs - , cab_lhs = lhs - , cab_rhs = rhs } = coAxiomNthBranch con ind + ; let CoAxBranch { cab_tvs = ktvs + , cab_roles = roles + , cab_lhs = lhs + , cab_rhs = rhs } = coAxiomNthBranch con ind ; unless (equalLength ktvs cos) (bad_ax (ptext (sLit "lengths"))) ; in_scope <- getInScope ; let empty_subst = mkTvSubst in_scope emptyTvSubstEnv ; (subst_l, subst_r) <- foldlM check_ki (empty_subst, empty_subst) - (ktvs `zip` cos) + (zip3 ktvs roles cos) ; let lhs' = Type.substTys subst_l lhs rhs' = Type.substTy subst_r rhs ; case checkAxInstCo co of - Just bad_index -> bad_ax $ ptext (sLit "inconsistent with") <+> (ppr bad_index) + Just bad_branch -> bad_ax $ ptext (sLit "inconsistent with") <+> (pprCoAxBranch (coAxiomTyCon con) bad_branch) Nothing -> return () - ; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs') } + ; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs', coAxiomRole con) } where bad_ax what = addErrL (hang (ptext (sLit "Bad axiom application") <+> parens what) 2 (ppr co)) - check_ki (subst_l, subst_r) (ktv, co) - = do { (k, t1, t2) <- lintCoercion co + check_ki (subst_l, subst_r) (ktv, role, co) + = do { (k, t1, t2, r) <- lintCoercion co + ; checkRole co role r ; let ktv_kind = Type.substTy subst_l (tyVarKind ktv) -- Using subst_l is ok, because subst_l and subst_r -- must agree on kind equalities @@ -941,6 +969,11 @@ lintCoercion co@(AxiomInstCo con ind cos) (bad_ax (ptext (sLit "check_ki2") <+> vcat [ ppr co, ppr k, ppr ktv, ppr ktv_kind ] )) ; return (Type.extendTvSubst subst_l ktv t1, Type.extendTvSubst subst_r ktv t2) } + +lintCoercion co@(SubCo co') + = do { (k,s,t,r) <- lintCoercion co' + ; checkRole co Nominal r + ; return (k,s,t,Representational) } \end{code} %************************************************************************ @@ -1117,6 +1150,17 @@ checkTys :: OutType -> OutType -> MsgDoc -> LintM () -- annotations need only be consistent, not equal) -- Assumes ty1,ty2 are have alrady had the substitution applied checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg + +checkRole :: Coercion + -> Role -- expected + -> Role -- actual + -> LintM () +checkRole co r1 r2 + = checkL (r1 == r2) + (ptext (sLit "Role incompatibility: expected") <+> ppr r1 <> comma <+> + ptext (sLit "got") <+> ppr r2 $$ + ptext (sLit "in") <+> ppr co) + \end{code} %************************************************************************ @@ -1263,10 +1307,10 @@ mkTyAppMsg ty arg_ty hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -mkRhsMsg :: Id -> Type -> MsgDoc -mkRhsMsg binder ty +mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc +mkRhsMsg binder what ty = vcat - [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"), + [hsep [ptext (sLit "The type of this binder doesn't match the type of its") <+> what <> colon, ppr binder], hsep [ptext (sLit "Binder's type:"), ppr (idType binder)], hsep [ptext (sLit "Rhs type:"), ppr ty]] diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 084c853382..d87fdfc197 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -8,7 +8,8 @@ Core pass to saturate constructors and PrimOps {-# LANGUAGE BangPatterns #-} module CorePrep ( - corePrepPgm, corePrepExpr, cvtLitInteger + corePrepPgm, corePrepExpr, cvtLitInteger, + lookupMkIntegerName, ) where #include "HsVersions.h" @@ -40,6 +41,7 @@ import TysWiredIn import DataCon import PrimOp import BasicTypes +import Module import UniqSupply import Maybes import OrdList @@ -343,12 +345,13 @@ cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats) cpeBind top_lvl env (NonRec bndr rhs) = do { (_, bndr1) <- cpCloneBndr env bndr - ; let is_strict = isStrictDmd (idDemandInfo bndr) + ; let dmd = idDemandInfo bndr is_unlifted = isUnLiftedType (idType bndr) ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive - (is_strict || is_unlifted) + dmd + is_unlifted env bndr1 rhs - ; let new_float = mkFloat is_strict is_unlifted bndr2 rhs2 + ; let new_float = mkFloat dmd is_unlifted bndr2 rhs2 -- We want bndr'' in the envt, because it records -- the evaluated-ness of the binder @@ -358,7 +361,7 @@ cpeBind top_lvl env (NonRec bndr rhs) cpeBind top_lvl env (Rec pairs) = do { let (bndrs,rhss) = unzip pairs ; (env', bndrs1) <- cpCloneBndrs env (map fst pairs) - ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss + ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') bndrs1 rhss ; let (floats_s, bndrs2, rhss2) = unzip3 stuff all_pairs = foldrOL add_float (bndrs2 `zip` rhss2) @@ -373,11 +376,11 @@ cpeBind top_lvl env (Rec pairs) add_float b _ = pprPanic "cpeBind" (ppr b) --------------- -cpePair :: TopLevelFlag -> RecFlag -> RhsDemand +cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool -> CorePrepEnv -> Id -> CoreExpr -> UniqSM (Floats, Id, CpeRhs) -- Used for all bindings -cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs +cpePair top_lvl is_rec dmd is_unlifted env bndr rhs = do { (floats1, rhs1) <- cpeRhsE env rhs -- See if we are allowed to float this stuff out of the RHS @@ -390,7 +393,7 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr) -- Note [Silly extra arguments] (do { v <- newVar (idType bndr) - ; let float = mkFloat False False v rhs2 + ; let float = mkFloat topDmd False v rhs2 ; return ( addFloat floats2 float , cpeEtaExpand arity (Var v)) }) @@ -404,6 +407,8 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs ; return (floats3, bndr', rhs') } where + is_strict_or_unlifted = (isStrictDmd dmd) || is_unlifted + platform = targetPlatform (cpe_dynFlags env) arity = idArity bndr -- We must match this arity @@ -648,9 +653,8 @@ cpeApp env expr [] -> (topDmd, []) (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $ splitFunTy_maybe fun_ty - is_strict = isStrictDmd ss1 - ; (fs, arg') <- cpeArg env is_strict arg arg_ty + ; (fs, arg') <- cpeArg env ss1 arg arg_ty ; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) } collect_args (Var v) depth @@ -680,8 +684,8 @@ cpeApp env expr -- N-variable fun, better let-bind it collect_args fun depth - = do { (fun_floats, fun') <- cpeArg env True fun ty - -- The True says that it's sure to be evaluated, + = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty + -- The evalDmd says that it's sure to be evaluated, -- so we'll end up case-binding it ; return (fun', (fun', depth), ty, fun_floats, []) } where @@ -692,9 +696,9 @@ cpeApp env expr -- --------------------------------------------------------------------------- -- This is where we arrange that a non-trivial argument is let-bound -cpeArg :: CorePrepEnv -> RhsDemand +cpeArg :: CorePrepEnv -> Demand -> CoreArg -> Type -> UniqSM (Floats, CpeTriv) -cpeArg env is_strict arg arg_ty +cpeArg env dmd arg arg_ty = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda ; (floats2, arg2) <- if want_float floats1 arg1 then return (floats1, arg1) @@ -708,11 +712,12 @@ cpeArg env is_strict arg arg_ty else do { v <- newVar arg_ty ; let arg3 = cpeEtaExpand (exprArity arg2) arg2 - arg_float = mkFloat is_strict is_unlifted v arg3 + arg_float = mkFloat dmd is_unlifted v arg3 ; return (addFloat floats2 arg_float, varToCoreExpr v) } } where is_unlifted = isUnLiftedType arg_ty - want_float = wantFloatNested NonRecursive (is_strict || is_unlifted) + is_strict = isStrictDmd dmd + want_float = wantFloatNested NonRecursive (is_strict || is_unlifted) \end{code} Note [Floating unlifted arguments] @@ -907,20 +912,16 @@ tryEtaReducePrep _ _ = Nothing \end{code} --- ----------------------------------------------------------------------------- --- Demands --- ----------------------------------------------------------------------------- - -\begin{code} -type RhsDemand = Bool -- True => used strictly; hence not top-level, non-recursive -\end{code} - %************************************************************************ %* * Floats %* * %************************************************************************ +Note [Pin demand info on floats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pin demand info on floated lets so that we can see the one-shot thunks. + \begin{code} data FloatingBind = FloatLet CoreBind -- Rhs of bindings are CpeRhss @@ -955,12 +956,16 @@ data OkToSpec -- ok-to-speculate unlifted bindings | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings -mkFloat :: Bool -> Bool -> Id -> CpeRhs -> FloatingBind -mkFloat is_strict is_unlifted bndr rhs +mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind +mkFloat dmd is_unlifted bndr rhs | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs) - | otherwise = FloatLet (NonRec bndr rhs) + | is_hnf = FloatLet (NonRec bndr rhs) + | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs) + -- See Note [Pin demand info on floats] where - use_case = is_unlifted || is_strict && not (exprIsHNF rhs) + is_hnf = exprIsHNF rhs + is_strict = isStrictDmd dmd + use_case = is_unlifted || is_strict && not is_hnf -- Don't make a case for a value binding, -- even if it's strict. Otherwise we get -- case (\x -> e) of ...! @@ -1107,10 +1112,18 @@ data CorePrepEnv = CPE { cpe_mkIntegerId :: Id } +lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id +lookupMkIntegerName dflags hsc_env + = if thisPackage dflags == primPackageId + then return $ panic "Can't use Integer in ghc-prim" + else if thisPackage dflags == integerPackageId + then return $ panic "Can't use Integer in integer" + else liftM tyThingId + $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName) + mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv mkInitialCorePrepEnv dflags hsc_env - = do mkIntegerId <- liftM tyThingId - $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName) + = do mkIntegerId <- lookupMkIntegerName dflags hsc_env return $ CPE { cpe_dynFlags = dflags, cpe_env = emptyVarEnv, diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index 8023786cf7..2e6d907b51 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -59,7 +59,6 @@ import Type hiding ( substTy, extendTvSubst, extendTvSubstList , isInScope, substTyVarBndr, cloneTyVarBndr ) import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr ) -import TcType ( tcSplitDFunTy ) import TyCon ( tyConArity ) import DataCon import PrelNames ( eqBoxDataConKey ) @@ -78,7 +77,6 @@ import Maybes import ErrUtils import DynFlags import BasicTypes ( isAlwaysActive ) -import ListSetOps import Util import Pair import Outputable @@ -656,10 +654,11 @@ substUnfoldingSC subst unf -- Short-cut version | isEmptySubst subst = unf | otherwise = substUnfolding subst unf -substUnfolding subst (DFunUnfolding ar con args) - = DFunUnfolding ar con (map subst_arg args) +substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = df { df_bndrs = bndrs', df_args = args' } where - subst_arg = fmap (substExpr (text "dfun-unf") subst) + (subst',bndrs') = substBndrs subst bndrs + args' = map (substExpr (text "subst-unf:dfun") subst') args substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) -- Retain an InlineRule! @@ -896,12 +895,12 @@ type OutExpr = CoreExpr -- In these functions the substitution maps InVar -> OutExpr ---------------------- -simple_opt_expr, simple_opt_expr' :: Subst -> InExpr -> OutExpr -simple_opt_expr s e = simple_opt_expr' s e - -simple_opt_expr' subst expr +simple_opt_expr :: Subst -> InExpr -> OutExpr +simple_opt_expr subst expr = go expr where + in_scope_env = (substInScope subst, simpleUnfoldingFun) + go (Var v) = lookupIdSubst (text "simpleOptExpr") subst v go (App e1 e2) = simple_app subst e1 [go e2] go (Type ty) = Type (substTy subst ty) @@ -921,7 +920,7 @@ simple_opt_expr' subst expr go (Case e b ty as) -- See Note [Optimise coercion boxes agressively] | isDeadBinder b - , Just (con, _tys, es) <- expr_is_con_app e' + , Just (con, _tys, es) <- exprIsConApp_maybe in_scope_env e' , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as = case altcon of DEFAULT -> go rhs @@ -1088,8 +1087,10 @@ add_info subst old_bndr new_bndr | otherwise = maybeModifyIdInfo mb_new_info new_bndr where mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr) -expr_is_con_app :: OutExpr -> Maybe (DataCon, [Type], [OutExpr]) -expr_is_con_app = exprIsConApp_maybe (\id -> if isAlwaysActive (idInlineActivation id) then idUnfolding id else noUnfolding) +simpleUnfoldingFun :: IdUnfoldingFun +simpleUnfoldingFun id + | isAlwaysActive (idInlineActivation id) = idUnfolding id + | otherwise = noUnfolding \end{code} Note [Inline prag in simplOpt] @@ -1137,12 +1138,10 @@ data ConCont = CC [CoreExpr] Coercion -- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is -- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@, -- where t1..tk are the *universally-qantified* type args of 'dc' -exprIsConApp_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) -exprIsConApp_maybe id_unf expr - = go (Left in_scope) expr (CC [] (mkReflCo (exprType expr))) +exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) +exprIsConApp_maybe (in_scope, id_unf) expr + = go (Left in_scope) expr (CC [] (mkReflCo Representational (exprType expr))) where - in_scope = mkInScopeSet (exprFreeVars expr) - go :: Either InScopeSet Subst -> CoreExpr -> ConCont -> Maybe (DataCon, [Type], [CoreExpr]) @@ -1163,17 +1162,13 @@ exprIsConApp_maybe id_unf expr go (Left in_scope) (Var fun) cont@(CC args co) | Just con <- isDataConWorkId_maybe fun , count isValArg args == idArity fun - , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args - = dealWithCoercion co (con, stripTypeArgs univ_ty_args, rest_args) + = dealWithCoercion co con args -- Look through dictionary functions; see Note [Unfolding DFuns] - | DFunUnfolding dfun_nargs con ops <- unfolding - , length args == dfun_nargs -- See Note [DFun arity check] - , let (dfun_tvs, _theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun) - subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args)) - mk_arg (DFunPolyArg e) = mkApps e args - mk_arg (DFunLamArg i) = getNth args i - = dealWithCoercion co (con, substTys subst dfun_res_tys, map mk_arg ops) + | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding + , bndrs `equalLength` args -- See Note [DFun arity check] + , let subst = mkOpenSubst in_scope (bndrs `zip` args) + = dealWithCoercion co con (map (substExpr (text "exprIsConApp1") subst) dfun_args) -- Look through unfoldings, but only arity-zero one; -- if arity > 0 we are effectively inlining a function call, @@ -1196,17 +1191,17 @@ exprIsConApp_maybe id_unf expr subst_co (Right s) co = CoreSubst.substCo s co subst_arg (Left {}) e = e - subst_arg (Right s) e = substExpr (text "exprIsConApp") s e + subst_arg (Right s) e = substExpr (text "exprIsConApp2") s e extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) extend (Right s) v e = Right (extendSubst s v e) -dealWithCoercion :: Coercion - -> (DataCon, [Type], [CoreExpr]) +dealWithCoercion :: Coercion -> DataCon -> [CoreExpr] -> Maybe (DataCon, [Type], [CoreExpr]) -dealWithCoercion co stuff@(dc, _dc_univ_args, dc_args) +dealWithCoercion co dc dc_args | isReflCo co - = Just stuff + , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args + = Just (dc, stripTypeArgs univ_ty_args, rest_args) | Pair _from_ty to_ty <- coercionKind co , Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty @@ -1229,23 +1224,27 @@ dealWithCoercion co stuff@(dc, _dc_univ_args, dc_args) dc_ex_tyvars = dataConExTyVars dc arg_tys = dataConRepArgTys dc - (ex_args, val_args) = splitAtList dc_ex_tyvars dc_args + non_univ_args = dropList dc_univ_tyvars dc_args + (ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args -- Make the "theta" from Fig 3 of the paper gammas = decomposeCo tc_arity co - theta_subst = liftCoSubstWith + theta_subst = liftCoSubstWith Representational (dc_univ_tyvars ++ dc_ex_tyvars) - (gammas ++ map mkReflCo (stripTypeArgs ex_args)) + -- existentials are at role N + (gammas ++ map (mkReflCo Nominal) + (stripTypeArgs ex_args)) -- Cast the value arguments (which include dictionaries) new_val_args = zipWith cast_arg arg_tys val_args cast_arg arg_ty arg = mkCast arg (theta_subst arg_ty) dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars, - ppr arg_tys, ppr dc_args, ppr _dc_univ_args, + ppr arg_tys, ppr dc_args, ppr ex_args, ppr val_args, ppr co, ppr _from_ty, ppr to_ty, ppr to_tc ] in - ASSERT2( eqType _from_ty (mkTyConApp to_tc _dc_univ_args), dump_doc ) + ASSERT2( eqType _from_ty (mkTyConApp to_tc (stripTypeArgs $ takeList dc_univ_tyvars dc_args)) + , dump_doc ) ASSERT2( all isTypeArg ex_args, dump_doc ) ASSERT2( equalLength val_args arg_tys, dump_doc ) Just (dc, to_tc_arg_tys, ex_args ++ new_val_args) @@ -1278,16 +1277,16 @@ type args) matches what the dfun is expecting. This may be *less* than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn \begin{code} -exprIsLiteral_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe Literal +exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal -- Same deal as exprIsConApp_maybe, but much simpler -- Nevertheless we do need to look through unfoldings for -- Integer literals, which are vigorously hoisted to top level -- and not subsequently inlined -exprIsLiteral_maybe id_unf e +exprIsLiteral_maybe env@(_, id_unf) e = case e of Lit l -> Just l - Tick _ e' -> exprIsLiteral_maybe id_unf e' -- dubious? + Tick _ e' -> exprIsLiteral_maybe env e' -- dubious? Var v | Just rhs <- expandUnfolding_maybe (id_unf v) - -> exprIsLiteral_maybe id_unf rhs + -> exprIsLiteral_maybe env rhs _ -> Nothing \end{code} diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 010b6cb6de..dd7307d190 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -49,7 +49,6 @@ module CoreSyn ( -- * Unfolding data types Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), - DFunArg(..), dfunArgExprs, -- ** Constructing 'Unfolding's noUnfolding, evaldUnfolding, mkOtherCon, @@ -78,7 +77,7 @@ module CoreSyn ( -- * Core rule data types CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only - RuleName, IdUnfoldingFun, + RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, -- ** Operations on 'CoreRule's seqRules, ruleArity, ruleName, ruleIdName, ruleActivation, @@ -92,6 +91,7 @@ module CoreSyn ( #include "HsVersions.h" import CostCentre +import VarEnv( InScopeSet ) import Var import Type import Coercion @@ -577,13 +577,16 @@ data CoreRule ru_fn :: Name, -- ^ As above ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, -- if it fires, including type arguments - ru_try :: DynFlags -> Id -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr + ru_try :: RuleFun -- ^ This function does the rewrite. It given too many -- arguments, it simply discards them; the returned 'CoreExpr' -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args } -- See Note [Extra args in rule matching] in Rules.lhs +type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr +type InScopeEnv = (InScopeSet, IdUnfoldingFun) + type IdUnfoldingFun = Id -> Unfolding -- A function that embodies how to unfold an Id if you need -- to do that in the Rule. The reason we need to pass this info in @@ -663,17 +666,15 @@ data Unfolding -- -- Here, @f@ gets an @OtherCon []@ unfolding. - | DFunUnfolding -- The Unfolding of a DFunId + | DFunUnfolding { -- The Unfolding of a DFunId -- See Note [DFun unfoldings] - -- df = /\a1..am. \d1..dn. MkD (op1 a1..am d1..dn) + -- df = /\a1..am. \d1..dn. MkD t1 .. tk + -- (op1 a1..am d1..dn) -- (op2 a1..am d1..dn) - - Arity -- Arity = m+n, the *total* number of args - -- (unusually, both type and value) to the dfun - - DataCon -- The dictionary data constructor (possibly a newtype datacon) - - [DFunArg CoreExpr] -- Specification of superclasses and methods, in positional order + df_bndrs :: [Var], -- The bound variables [a1..m],[d1..dn] + df_con :: DataCon, -- The dictionary data constructor (never a newtype datacon) + df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods, + } -- in positional order | CoreUnfolding { -- An unfolding for an Id with no pragma, -- or perhaps a NOINLINE pragma @@ -710,20 +711,6 @@ data Unfolding -- -- uf_guidance: Tells us about the /size/ of the unfolding template ------------------------------------------------- -data DFunArg e -- Given (df a b d1 d2 d3) - = DFunPolyArg e -- Arg is (e a b d1 d2 d3) - | DFunLamArg Int -- Arg is one of [a,b,d1,d2,d3], zero indexed - deriving( Functor ) - - -- 'e' is often CoreExpr, which are usually variables, but can - -- be trivial expressions instead (e.g. a type application). - -dfunArgExprs :: [DFunArg e] -> [e] -dfunArgExprs [] = [] -dfunArgExprs (DFunPolyArg e : as) = e : dfunArgExprs as -dfunArgExprs (DFunLamArg {} : as) = dfunArgExprs as - ------------------------------------------------ data UnfoldingSource diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs index 77e5f09faa..f0c947246a 100644 --- a/compiler/coreSyn/CoreTidy.lhs +++ b/compiler/coreSyn/CoreTidy.lhs @@ -206,8 +206,11 @@ tidyIdBndr env@(tidy_env, var_env) id ------------ Unfolding -------------- tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding -tidyUnfolding tidy_env (DFunUnfolding ar con args) _ - = DFunUnfolding ar con (map (fmap (tidyExpr tidy_env)) args) +tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _ + = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args } + where + (tidy_env', bndrs') = tidyBndrs tidy_env bndrs + tidyUnfolding tidy_env unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) unf_from_rhs diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 2198b36c64..bbf9e0eb40 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -48,7 +48,6 @@ module CoreUnfold ( import DynFlags import CoreSyn import PprCore () -- Instances -import TcType ( tcSplitDFunTy ) import OccurAnal ( occurAnalyseExpr ) import CoreSubst hiding( substTy ) import CoreArity ( manifestArity, exprBotStrictness_maybe ) @@ -98,13 +97,9 @@ mkImplicitUnfolding dflags expr mkSimpleUnfolding :: DynFlags -> CoreExpr -> Unfolding mkSimpleUnfolding dflags = mkUnfolding dflags InlineRhs False False -mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding -mkDFunUnfolding dfun_ty ops - = DFunUnfolding dfun_nargs data_con ops - where - (tvs, theta, cls, _) = tcSplitDFunTy dfun_ty - dfun_nargs = length tvs + length theta - data_con = classDataCon cls +mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding +mkDFunUnfolding bndrs con ops + = DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = ops } mkWwInlineRule :: CoreExpr -> Arity -> Unfolding mkWwInlineRule expr arity @@ -952,6 +947,8 @@ tryUnfolding dflags id lone_variable where n_val_args = length arg_infos saturated = n_val_args >= uf_arity + cont_info' | n_val_args > uf_arity = ValAppCtxt + | otherwise = cont_info result | yes_or_no = Just unf_template | otherwise = Nothing @@ -969,12 +966,11 @@ tryUnfolding dflags id lone_variable some_benefit | not saturated = interesting_args -- Under-saturated -- Note [Unsaturated applications] - | n_val_args > uf_arity = True -- Over-saturated - | otherwise = interesting_args -- Saturated - || interesting_saturated_call + | otherwise = interesting_args -- Saturated or over-saturated + || interesting_call - interesting_saturated_call - = case cont_info of + interesting_call + = case cont_info' of BoringCtxt -> not is_top && uf_arity > 0 -- Note [Nested functions] CaseCtxt -> not (lone_variable && is_wf) -- Note [Lone variables] ArgCtxt {} -> uf_arity > 0 -- Note [Inlining in ArgCtxt] @@ -996,7 +992,7 @@ tryUnfolding dflags id lone_variable discounted_size = size - discount small_enough = discounted_size <= ufUseThreshold dflags discount = computeDiscount dflags uf_arity arg_discounts - res_discount arg_infos cont_info + res_discount arg_infos cont_info' \end{code} Note [RHS of lets] @@ -1116,7 +1112,7 @@ AND then we should not inline it (unless there is some other reason, e.g. is is the sole occurrence). That is what is happening at -the use of 'lone_variable' in 'interesting_saturated_call'. +the use of 'lone_variable' in 'interesting_call'. Why? At least in the case-scrutinee situation, turning let x = (a,b) in case x of y -> ... @@ -1187,9 +1183,9 @@ This kind of thing can occur if you have which Roman did. \begin{code} -computeDiscount :: DynFlags -> Int -> [Int] -> Int -> [ArgSummary] -> CallCtxt +computeDiscount :: DynFlags -> Arity -> [Int] -> Int -> [ArgSummary] -> CallCtxt -> Int -computeDiscount dflags n_vals_wanted arg_discounts res_discount arg_infos cont_info +computeDiscount dflags uf_arity arg_discounts res_discount arg_infos cont_info -- We multiple the raw discounts (args_discount and result_discount) -- ty opt_UnfoldingKeenessFactor because the former have to do with -- *size* whereas the discounts imply that there's some extra @@ -1199,7 +1195,7 @@ computeDiscount dflags n_vals_wanted arg_discounts res_discount arg_infos cont_i = 10 -- Discount of 1 because the result replaces the call -- so we count 1 for the function itself - + 10 * length (take n_vals_wanted arg_infos) + + 10 * length (take uf_arity arg_infos) -- Discount of (un-scaled) 1 for each arg supplied, -- because the result replaces the call @@ -1214,8 +1210,9 @@ computeDiscount dflags n_vals_wanted arg_discounts res_discount arg_infos cont_i res_discount' = case cont_info of BoringCtxt -> 0 - CaseCtxt -> res_discount - _other -> 40 `min` res_discount + CaseCtxt -> res_discount -- Presumably a constructor + ValAppCtxt -> res_discount -- Presumably a function + ArgCtxt {} -> 40 `min` res_discount -- res_discount can be very large when a function returns -- constructors; but we only want to invoke that large discount -- when there's a case continuation. diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 4e45da4b4b..ddf4406081 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -30,9 +30,6 @@ module CoreUtils ( coreBindsSize, exprSize, CoreStats(..), coreBindsStats, - -- * Hashing - hashExpr, - -- * Equality cheapEqExpr, eqExpr, eqExprX, @@ -48,6 +45,7 @@ module CoreUtils ( import CoreSyn import PprCore +import CoreFVs( exprFreeVars ) import Var import SrcLoc import VarEnv @@ -70,8 +68,6 @@ import Maybes import Platform import Util import Pair -import Data.Word -import Data.Bits import Data.List \end{code} @@ -192,9 +188,12 @@ mkCast (Coercion e_co) co = Coercion (mkCoCast e_co co) mkCast (Cast expr co2) co - = ASSERT(let { Pair from_ty _to_ty = coercionKind co; - Pair _from_ty2 to_ty2 = coercionKind co2} in - from_ty `eqType` to_ty2 ) + = WARN(let { Pair from_ty _to_ty = coercionKind co; + Pair _from_ty2 to_ty2 = coercionKind co2} in + not (from_ty `eqType` to_ty2), + vcat ([ ptext (sLit "expr:") <+> ppr expr + , ptext (sLit "co2:") <+> ppr co2 + , ptext (sLit "co:") <+> ppr co ]) ) mkCast expr (mkTransCo co2 co) mkCast expr co @@ -567,8 +566,8 @@ getIdFromTrivialExpr e = go e \end{code} exprIsBottom is a very cheap and cheerful function; it may return -False for bottoming expressions, but it never costs much to ask. -See also CoreArity.exprBotStrictness_maybe, but that's a bit more +False for bottoming expressions, but it never costs much to ask. See +also CoreArity.exprBotStrictness_maybe, but that's a bit more expensive. \begin{code} @@ -1519,81 +1518,6 @@ altSize (c,bs,e) = c `seq` bndrsSize bs + exprSize e %************************************************************************ %* * -\subsection{Hashing} -%* * -%************************************************************************ - -\begin{code} -hashExpr :: CoreExpr -> Int --- ^ Two expressions that hash to the same @Int@ may be equal (but may not be) --- Two expressions that hash to the different Ints are definitely unequal. --- --- The emphasis is on a crude, fast hash, rather than on high precision. --- --- But unequal here means \"not identical\"; two alpha-equivalent --- expressions may hash to the different Ints. --- --- We must be careful that @\\x.x@ and @\\y.y@ map to the same hash code, --- (at least if we want the above invariant to be true). - -hashExpr e = fromIntegral (hash_expr (1,emptyVarEnv) e .&. 0x7fffffff) - -- UniqFM doesn't like negative Ints - -type HashEnv = (Int, VarEnv Int) -- Hash code for bound variables - -hash_expr :: HashEnv -> CoreExpr -> Word32 --- Word32, because we're expecting overflows here, and overflowing --- signed types just isn't cool. In C it's even undefined. -hash_expr env (Tick _ e) = hash_expr env e -hash_expr env (Cast e _) = hash_expr env e -hash_expr env (Var v) = hashVar env v -hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit) -hash_expr env (App f e) = hash_expr env f * fast_hash_expr env e -hash_expr env (Let (NonRec b r) e) = hash_expr (extend_env env b) e * fast_hash_expr env r -hash_expr env (Let (Rec ((b,_):_)) e) = hash_expr (extend_env env b) e -hash_expr _ (Let (Rec []) _) = panic "hash_expr: Let (Rec []) _" -hash_expr env (Case e _ _ _) = hash_expr env e -hash_expr env (Lam b e) = hash_expr (extend_env env b) e -hash_expr env (Coercion co) = fast_hash_co env co -hash_expr _ (Type _) = WARN(True, text "hash_expr: type") 1 --- Shouldn't happen. Better to use WARN than trace, because trace --- prevents the CPR optimisation kicking in for hash_expr. - -fast_hash_expr :: HashEnv -> CoreExpr -> Word32 -fast_hash_expr env (Var v) = hashVar env v -fast_hash_expr env (Type t) = fast_hash_type env t -fast_hash_expr env (Coercion co) = fast_hash_co env co -fast_hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit) -fast_hash_expr env (Cast e _) = fast_hash_expr env e -fast_hash_expr env (Tick _ e) = fast_hash_expr env e -fast_hash_expr env (App _ a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')! -fast_hash_expr _ _ = 1 - -fast_hash_type :: HashEnv -> Type -> Word32 -fast_hash_type env ty - | Just tv <- getTyVar_maybe ty = hashVar env tv - | Just (tc,tys) <- splitTyConApp_maybe ty = let hash_tc = fromIntegral (hashName (tyConName tc)) - in foldr (\t n -> fast_hash_type env t + n) hash_tc tys - | otherwise = 1 - -fast_hash_co :: HashEnv -> Coercion -> Word32 -fast_hash_co env co - | Just cv <- getCoVar_maybe co = hashVar env cv - | Just (tc,cos) <- splitTyConAppCo_maybe co = let hash_tc = fromIntegral (hashName (tyConName tc)) - in foldr (\c n -> fast_hash_co env c + n) hash_tc cos - | otherwise = 1 - -extend_env :: HashEnv -> Var -> (Int, VarEnv Int) -extend_env (n,env) b = (n+1, extendVarEnv env b n) - -hashVar :: HashEnv -> Var -> Word32 -hashVar (_,env) v - = fromIntegral (lookupVarEnv env v `orElse` hashName (idName v)) -\end{code} - - -%************************************************************************ -%* * Eta reduction %* * %************************************************************************ @@ -1606,6 +1530,11 @@ are going to avoid allocating this thing altogether. There are some particularly delicate points here: +* We want to eta-reduce if doing so leaves a trivial expression, + *including* a cast. For example + \x. f |> co --> f |> co + (provided co doesn't mention x) + * Eta reduction is not valid in general: \x. bot /= bot This matters, partly for old-fashioned correctness reasons but, @@ -1622,7 +1551,7 @@ There are some particularly delicate points here: Result: seg-fault because the boolean case actually gets a function value. See Trac #1947. - So it's important to to the right thing. + So it's important to do the right thing. * Note [Arity care]: we need to be careful if we just look at f's arity. Currently (Dec07), f's arity is visible in its own RHS (see @@ -1682,7 +1611,7 @@ need to address that here. \begin{code} tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr tryEtaReduce bndrs body - = go (reverse bndrs) body (mkReflCo (exprType body)) + = go (reverse bndrs) body (mkReflCo Representational (exprType body)) where incoming_arity = count isId bndrs @@ -1693,7 +1622,11 @@ tryEtaReduce bndrs body -- See Note [Eta reduction with casted arguments] -- for why we have an accumulating coercion go [] fun co - | ok_fun fun = Just (mkCast fun co) + | ok_fun fun + , let result = mkCast fun co + , not (any (`elemVarSet` exprFreeVars result) bndrs) + = Just result -- Check for any of the binders free in the result + -- including the accumulated coercion go (b : bs) (App fun arg) co | Just co' <- ok_arg b arg co @@ -1703,13 +1636,10 @@ tryEtaReduce bndrs body --------------- -- Note [Eta reduction conditions] - ok_fun (App fun (Type ty)) - | not (any (`elemVarSet` tyVarsOfType ty) bndrs) - = ok_fun fun - ok_fun (Var fun_id) - = not (fun_id `elem` bndrs) - && (ok_fun_id fun_id || all ok_lam bndrs) - ok_fun _fun = False + ok_fun (App fun (Type {})) = ok_fun fun + ok_fun (Cast fun _) = ok_fun fun + ok_fun (Var fun_id) = ok_fun_id fun_id || all ok_lam bndrs + ok_fun _fun = False --------------- ok_fun_id fun = fun_arity fun >= incoming_arity @@ -1739,9 +1669,10 @@ tryEtaReduce bndrs body | Just tv <- getTyVar_maybe ty , bndr == tv = Just (mkForAllCo tv co) ok_arg bndr (Var v) co - | bndr == v = Just (mkFunCo (mkReflCo (idType bndr)) co) + | bndr == v = Just (mkFunCo Representational + (mkReflCo Representational (idType bndr)) co) ok_arg bndr (Cast (Var v) co_arg) co - | bndr == v = Just (mkFunCo (mkSymCo co_arg) co) + | bndr == v = Just (mkFunCo Representational (mkSymCo co_arg) co) -- The simplifier combines multiple casts into one, -- so we can have a simple-minded pattern match here ok_arg _ _ _ = Nothing diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs index f002c3a3e5..ecc24b1155 100644 --- a/compiler/coreSyn/ExternalCore.lhs +++ b/compiler/coreSyn/ExternalCore.lhs @@ -34,7 +34,7 @@ data Exp | Lam Bind Exp | Let Vdefg Exp | Case Exp Vbind Ty [Alt] {- non-empty list -} - | Cast Exp Ty + | Cast Exp Coercion | Tick String Exp {- XXX probably wrong -} | External String String Ty {- target name, convention, and type -} | DynExternal String Ty {- convention and type (incl. Addr# of target as first arg) -} @@ -52,23 +52,30 @@ data Alt type Vbind = (Var,Ty) type Tbind = (Tvar,Kind) --- Internally, we represent types and coercions separately; but for --- the purposes of external core (at least for now) it's still --- convenient to collapse them into a single type. data Ty = Tvar Tvar | Tcon (Qual Tcon) | Tapp Ty Ty | Tforall Tbind Ty + +data Coercion -- We distinguish primitive coercions because External Core treats -- them specially, so we have to print them out with special syntax. - | TransCoercion Ty Ty - | SymCoercion Ty - | UnsafeCoercion Ty Ty - | InstCoercion Ty Ty - | NthCoercion Int Ty - | AxiomCoercion (Qual Tcon) Int [Ty] - | LRCoercion LeftOrRight Ty + = ReflCoercion Role Ty + | SymCoercion Coercion + | TransCoercion Coercion Coercion + | TyConAppCoercion Role (Qual Tcon) [Coercion] + | AppCoercion Coercion Coercion + | ForAllCoercion Tbind Coercion + | CoVarCoercion Var + | UnivCoercion Role Ty Ty + | InstCoercion Coercion Ty + | NthCoercion Int Coercion + | AxiomCoercion (Qual Tcon) Int [Coercion] + | LRCoercion LeftOrRight Coercion + | SubCoercion Coercion + +data Role = Nominal | Representational | Phantom data LeftOrRight = CLeft | CRight diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index 4cc199853b..c6fc2be21f 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -53,7 +53,8 @@ module MkCore ( mkRuntimeErrorApp, mkImpossibleExpr, errorIds, 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, aBSENT_ERROR_ID + pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID, + uNDEFINED_ID, undefinedName ) where #include "HsVersions.h" @@ -659,6 +660,9 @@ errorIds -- import its type from the interface file; we just get -- the Id defined here. Which has an 'open-tyvar' type. + uNDEFINED_ID, -- Ditto for 'undefined'. The big deal is to give it + -- an 'open-tyvar' type. + rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID, @@ -700,7 +704,7 @@ nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName aBSENT_ERROR_ID = mkRuntimeErrorId absentErrorName mkRuntimeErrorId :: Name -> Id -mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy +mkRuntimeErrorId name = pc_bottoming_Id1 name runtimeErrorTy runtimeErrorTy :: Type -- The runtime error Ids take a UTF8-encoded string as argument @@ -712,15 +716,33 @@ errorName :: Name errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID eRROR_ID :: Id -eRROR_ID = pc_bottoming_Id errorName errorTy +eRROR_ID = pc_bottoming_Id1 errorName errorTy -errorTy :: Type +errorTy :: Type -- See Note [Error and friends have an "open-tyvar" forall] 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. + +undefinedName :: Name +undefinedName = mkWiredInIdName gHC_ERR (fsLit "undefined") undefinedKey uNDEFINED_ID + +uNDEFINED_ID :: Id +uNDEFINED_ID = pc_bottoming_Id0 undefinedName undefinedTy + +undefinedTy :: Type -- See Note [Error and friends have an "open-tyvar" forall] +undefinedTy = mkSigmaTy [openAlphaTyVar] [] openAlphaTy \end{code} +Note [Error and friends have an "open-tyvar" forall] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'error' and 'undefined' have types + error :: forall (a::OpenKind). String -> a + undefined :: forall (a::OpenKind). a +Notice the 'OpenKind' (manifested as openAlphaTyVar in the code). This ensures that +"error" can be instantiated at + * unboxed as well as boxed types + * polymorphic types +This is OK because it never returns, so the return type is irrelevant. +See Note [OpenTypeKind accepts foralls] in TcUnify. + %************************************************************************ %* * @@ -729,9 +751,9 @@ errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy %************************************************************************ \begin{code} -pc_bottoming_Id :: Name -> Type -> Id +pc_bottoming_Id1 :: Name -> Type -> Id -- Function of arity 1, which diverges after being given one argument -pc_bottoming_Id name ty +pc_bottoming_Id1 name ty = mkVanillaGlobalWithInfo name ty bottoming_info where bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig @@ -749,5 +771,13 @@ pc_bottoming_Id name ty strict_sig = mkStrictSig (mkTopDmdType [evalDmd] botRes) -- These "bottom" out, no matter what their arguments + +pc_bottoming_Id0 :: Name -> Type -> Id +-- Same but arity zero +pc_bottoming_Id0 name ty + = mkVanillaGlobalWithInfo name ty bottoming_info + where + bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig + strict_sig = mkStrictSig (mkTopDmdType [] botRes) \end{code} diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index aa5e365be9..a0776af218 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -2,15 +2,8 @@ % (c) The University of Glasgow 2001-2006 % \begin{code} -{-# 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 MkExternalCore ( - emitExternalCore + emitExternalCore ) where #include "HsVersions.h" @@ -18,7 +11,7 @@ module MkExternalCore ( import qualified ExternalCore as C import Module import CoreSyn -import HscTypes +import HscTypes import TyCon import CoAxiom -- import Class @@ -44,16 +37,15 @@ import qualified Data.ByteString as BS import Data.Char import System.IO -emitExternalCore :: DynFlags -> CgGuts -> IO () -emitExternalCore dflags cg_guts +emitExternalCore :: DynFlags -> FilePath -> CgGuts -> IO () +emitExternalCore dflags extCore_filename cg_guts | gopt Opt_EmitExternalCore dflags - = (do handle <- openFile corename WriteMode + = (do handle <- openFile extCore_filename WriteMode hPutStrLn handle (show (mkExternalCore dflags cg_guts)) hClose handle) `catchIO` (\_ -> pprPanic "Failed to open or write external core output file" - (text corename)) - where corename = extCoreName dflags -emitExternalCore _ _ + (text extCore_filename)) +emitExternalCore _ _ _ | otherwise = return () @@ -98,14 +90,14 @@ collect_tdefs :: DynFlags -> TyCon -> [C.Tdef] -> [C.Tdef] collect_tdefs dflags tcon tdefs | isAlgTyCon tcon = tdef: tdefs where - tdef | isNewTyCon tcon = - C.Newtype (qtc dflags tcon) + tdef | isNewTyCon tcon = + C.Newtype (qtc dflags tcon) (qcc dflags (newTyConCo tcon)) - (map make_tbind tyvars) + (map make_tbind tyvars) (make_ty dflags (snd (newTyConRhs tcon))) - | otherwise = - C.Data (qtc dflags tcon) (map make_tbind tyvars) - (map (make_cdef dflags) (tyConDataCons tcon)) + | otherwise = + C.Data (qtc dflags tcon) (map make_tbind tyvars) + (map (make_cdef dflags) (tyConDataCons tcon)) tyvars = tyConTyVars tcon collect_tdefs _ _ tdefs = tdefs @@ -118,20 +110,20 @@ qcc dflags = make_con_qid dflags . co_ax_name make_cdef :: DynFlags -> DataCon -> C.Cdef make_cdef dflags dcon = C.Constr dcon_name existentials tys - where + where dcon_name = make_qid dflags False False (dataConName dcon) existentials = map make_tbind ex_tyvars ex_tyvars = dataConExTyVars dcon - tys = map (make_ty dflags) (dataConRepArgTys dcon) + tys = map (make_ty dflags) (dataConRepArgTys dcon) make_tbind :: TyVar -> C.Tbind make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv)) - + make_vbind :: DynFlags -> Var -> C.Vbind make_vbind dflags v = (make_var_id (Var.varName v), make_ty dflags (varType v)) make_vdef :: Bool -> CoreBind -> CoreM C.Vdefg -make_vdef topLevel b = +make_vdef topLevel b = case b of NonRec v e -> f (v,e) >>= (return . C.Nonrec) Rec ves -> mapM f ves >>= (return . C.Rec) @@ -144,7 +136,7 @@ make_vdef topLevel b = -- use local flag to determine where to add the module name dflags <- getDynFlags return (local, make_qid dflags local True vName, make_ty dflags (varType v),rhs) - where vName = Var.varName v + where vName = Var.varName v make_exp :: CoreExpr -> CoreM C.Exp make_exp (Var v) = do @@ -153,11 +145,11 @@ make_exp (Var v) = do dflags <- getDynFlags return $ case idDetails v of - FCallId (CCall (CCallSpec (StaticTarget nm _ True) callconv _)) + FCallId (CCall (CCallSpec (StaticTarget nm _ True) callconv _)) -> C.External (unpackFS nm) (showPpr dflags callconv) (make_ty dflags (varType v)) FCallId (CCall (CCallSpec (StaticTarget _ _ False) _ _)) -> panic "make_exp: FFI values not supported" - FCallId (CCall (CCallSpec DynamicTarget callconv _)) + FCallId (CCall (CCallSpec DynamicTarget callconv _)) -> C.DynExternal (showPpr dflags callconv) (make_ty dflags (varType v)) -- Constructors are always exported, so make sure to declare them -- with qualified names @@ -175,7 +167,7 @@ make_exp (App e1 e2) = do rator <- make_exp e1 rand <- make_exp e2 return $ C.App rator rand -make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b -> +make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b -> return $ C.Lam (C.Tb (make_tbind v)) b) make_exp (Lam v e) | otherwise = do b <- make_exp e dflags <- getDynFlags @@ -202,8 +194,8 @@ make_alt (DataAlt dcon, vs, e) = do return $ C.Acon (make_con_qid dflags (dataConName dcon)) (map make_tbind tbs) (map (make_vbind dflags) vbs) - newE - where (tbs,vbs) = span isTyVar vs + newE + where (tbs,vbs) = span isTyVar vs make_alt (LitAlt l,_,e) = do x <- make_exp e dflags <- getDynFlags return $ C.Alit (make_lit dflags l) x @@ -215,14 +207,14 @@ make_alt a@(DEFAULT,_ ,_) = pprPanic ("MkExternalCore: make_alt: DEFAULT " make_lit :: DynFlags -> Literal -> C.Lit -make_lit dflags l = +make_lit dflags l = case l of -- Note that we need to check whether the character is "big". -- External Core only allows character literals up to '\xff'. MachChar i | i <= chr 0xff -> C.Lchar i t -- For a character bigger than 0xff, we represent it in ext-core -- as an int lit with a char type. - MachChar i -> C.Lint (fromIntegral $ ord i) t + MachChar i -> C.Lint (fromIntegral $ ord i) t MachStr s -> C.Lstring (BS.unpack s) t MachNullAddr -> C.Lint 0 t MachInt i -> C.Lint i t @@ -233,7 +225,7 @@ make_lit dflags l = MachDouble r -> C.Lrational r t LitInteger i _ -> C.Lint i t _ -> pprPanic "MkExternalCore died: make_lit" (ppr l) - where + where t = make_ty dflags (literalType l) -- Expand type synonyms, then convert. @@ -241,32 +233,32 @@ make_ty :: DynFlags -> Type -> C.Ty -- Be sure to expand types recursively! -- example: FilePath ~> String ~> [Char] make_ty dflags t | Just expanded <- tcView t = make_ty dflags expanded make_ty dflags t = make_ty' dflags t - + -- note calls to make_ty so as to expand types recursively make_ty' :: DynFlags -> Type -> C.Ty make_ty' _ (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv)) -make_ty' dflags (AppTy t1 t2) = C.Tapp (make_ty dflags t1) (make_ty dflags t2) -make_ty' dflags (FunTy t1 t2) = make_ty dflags (TyConApp funTyCon [t1,t2]) +make_ty' dflags (AppTy t1 t2) = C.Tapp (make_ty dflags t1) (make_ty dflags t2) +make_ty' dflags (FunTy t1 t2) = make_ty dflags (TyConApp funTyCon [t1,t2]) make_ty' dflags (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty dflags t) make_ty' dflags (TyConApp tc ts) = make_tyConApp dflags tc ts make_ty' _ (LitTy {}) = panic "MkExernalCore can't do literal types yet" -- Newtypes are treated just like any other type constructor; not expanded -- Reason: predTypeRep does substitution and, while substitution deals --- correctly with name capture, it's only correct if you see the uniques! --- If you just see occurrence names, name capture may occur. +-- correctly with name capture, it's only correct if you see the uniques! +-- If you just see occurrence names, name capture may occur. -- Example: newtype A a = A (forall b. b -> a) --- test :: forall q b. q -> A b --- test _ = undefined --- Here the 'a' gets substituted by 'b', which is captured. +-- test :: forall q b. q -> A b +-- test _ = undefined +-- Here the 'a' gets substituted by 'b', which is captured. -- Another solution would be to expand newtypes before tidying; but that would -- expose the representation in interface files, which definitely isn't right. -- Maybe CoreTidy should know whether to expand newtypes or not? make_tyConApp :: DynFlags -> TyCon -> [Type] -> C.Ty make_tyConApp dflags tc ts = - foldl C.Tapp (C.Tcon (qtc dflags tc)) - (map (make_ty dflags) ts) + foldl C.Tapp (C.Tcon (qtc dflags tc)) + (map (make_ty dflags) ts) make_kind :: Kind -> C.Kind make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2) @@ -303,13 +295,13 @@ make_mid dflags m <> text ":" <> (pprEncoded $ pprModuleName $ moduleName m) where pprEncoded = pprCode CStyle - + make_qid :: DynFlags -> Bool -> Bool -> Name -> C.Qual C.Id make_qid dflags force_unqual is_var n = (mname,make_id is_var n) - where mname = + where mname = case nameModule_maybe n of Just m | not force_unqual -> make_mid dflags m - _ -> "" + _ -> "" make_var_qid :: DynFlags -> Bool -> Name -> C.Qual C.Id make_var_qid dflags force_unqual = make_qid dflags force_unqual True @@ -317,29 +309,29 @@ make_var_qid dflags force_unqual = make_qid dflags force_unqual True make_con_qid :: DynFlags -> Name -> C.Qual C.Id make_con_qid dflags = make_qid dflags False False -make_co :: DynFlags -> Coercion -> C.Ty -make_co dflags (Refl ty) = make_ty dflags ty -make_co dflags (TyConAppCo tc cos) = make_conAppCo dflags (qtc dflags tc) cos -make_co dflags (AppCo c1 c2) = C.Tapp (make_co dflags c1) (make_co dflags c2) -make_co dflags (ForAllCo tv co) = C.Tforall (make_tbind tv) (make_co dflags co) -make_co _ (CoVarCo cv) = C.Tvar (make_var_id (coVarName cv)) +make_co :: DynFlags -> Coercion -> C.Coercion +make_co dflags (Refl r ty) = C.ReflCoercion (make_role r) $ make_ty dflags ty +make_co dflags (TyConAppCo r tc cos) = C.TyConAppCoercion (make_role r) (qtc dflags tc) (map (make_co dflags) cos) +make_co dflags (AppCo c1 c2) = C.AppCoercion (make_co dflags c1) (make_co dflags c2) +make_co dflags (ForAllCo tv co) = C.ForAllCoercion (make_tbind tv) (make_co dflags co) +make_co _ (CoVarCo cv) = C.CoVarCoercion (make_var_id (coVarName cv)) make_co dflags (AxiomInstCo cc ind cos) = C.AxiomCoercion (qcc dflags cc) ind (map (make_co dflags) cos) -make_co dflags (UnsafeCo t1 t2) = C.UnsafeCoercion (make_ty dflags t1) (make_ty dflags t2) +make_co dflags (UnivCo r t1 t2) = C.UnivCoercion (make_role r) (make_ty dflags t1) (make_ty dflags t2) make_co dflags (SymCo co) = C.SymCoercion (make_co dflags co) make_co dflags (TransCo c1 c2) = C.TransCoercion (make_co dflags c1) (make_co dflags c2) make_co dflags (NthCo d co) = C.NthCoercion d (make_co dflags co) make_co dflags (LRCo lr co) = C.LRCoercion (make_lr lr) (make_co dflags co) make_co dflags (InstCo co ty) = C.InstCoercion (make_co dflags co) (make_ty dflags ty) +make_co dflags (SubCo co) = C.SubCoercion (make_co dflags co) make_lr :: LeftOrRight -> C.LeftOrRight make_lr CLeft = C.CLeft make_lr CRight = C.CRight --- Used for both tycon app coercions and axiom instantiations. -make_conAppCo :: DynFlags -> C.Qual C.Tcon -> [Coercion] -> C.Ty -make_conAppCo dflags con cos = - foldl C.Tapp (C.Tcon con) - (map (make_co dflags) cos) +make_role :: Role -> C.Role +make_role Nominal = C.Nominal +make_role Representational = C.Representational +make_role Phantom = C.Phantom ------- isALocal :: Name -> CoreM Bool diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 10e8b2830a..64e7d63590 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -429,8 +429,10 @@ instance Outputable UnfoldingSource where instance Outputable Unfolding where ppr NoUnfolding = ptext (sLit "No unfolding") ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs - ppr (DFunUnfolding ar con ops) = ptext (sLit "DFun") <> parens (ptext (sLit "arity=") <> int ar) - <+> ppr con <+> brackets (pprWithCommas ppr ops) + ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) + = hang (ptext (sLit "DFun:") <+> ptext (sLit "\\") + <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) + 2 (ppr con <+> sep (map ppr args)) ppr (CoreUnfolding { uf_src = src , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf , uf_is_conlike=conlike, uf_is_work_free=wf @@ -451,10 +453,6 @@ instance Outputable Unfolding where | otherwise = empty -- Don't print the RHS or we get a quadratic -- blowup in the size of the printout! - -instance Outputable e => Outputable (DFunArg e) where - ppr (DFunPolyArg e) = braces (ppr e) - ppr (DFunLamArg i) = char '<' <> int i <> char '>' \end{code} ----------------------------------------------------- diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs index 24ee560cb1..7fd3ac1d65 100644 --- a/compiler/coreSyn/PprExternalCore.lhs +++ b/compiler/coreSyn/PprExternalCore.lhs @@ -102,22 +102,6 @@ pbty t = paty t pty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = fsep [pbty t1, text "->",pty t2] pty (Tforall tb t) = text "%forall" <+> pforall [tb] t -pty (TransCoercion t1 t2) = - sep [text "%trans", paty t1, paty t2] -pty (SymCoercion t) = - sep [text "%sym", paty t] -pty (UnsafeCoercion t1 t2) = - sep [text "%unsafe", paty t1, paty t2] -pty (NthCoercion n t) = - sep [text "%nth", int n, paty t] -pty (LRCoercion CLeft t) = - sep [text "%left", paty t] -pty (LRCoercion CRight t) = - sep [text "%right", paty t] -pty (InstCoercion t1 t2) = - sep [text "%inst", paty t1, paty t2] -pty (AxiomCoercion tc i cos) = - pqname tc <+> int i <+> sep (map paty cos) pty ty@(Tapp {}) = pappty ty [] pty ty@(Tvar {}) = paty ty pty ty@(Tcon {}) = paty ty @@ -130,6 +114,48 @@ pforall :: [Tbind] -> Ty -> Doc pforall tbs (Tforall tb t) = pforall (tbs ++ [tb]) t pforall tbs t = hsep (map ptbind tbs) <+> char '.' <+> pty t +paco, pbco, pco :: Coercion -> Doc +paco (ReflCoercion r ty) = char '<' <> pty ty <> text ">_" <> prole r +paco (TyConAppCoercion r qtc []) = pqname qtc <> char '_' <> prole r +paco (AxiomCoercion qtc i []) = pqname qtc <> char '[' <> int i <> char ']' +paco (CoVarCoercion cv) = pname cv +paco c = parens (pco c) + +pbco (TyConAppCoercion _ arr [co1, co2]) + | arr == tcArrow + = parens (fsep [pbco co1, text "->", pco co2]) +pbco co = paco co + +pco c@(ReflCoercion {}) = paco c +pco (SymCoercion co) = sep [text "%sub", paco co] +pco (TransCoercion co1 co2) = sep [text "%trans", paco co1, paco co2] +pco (TyConAppCoercion _ arr [co1, co2]) + | arr == tcArrow = fsep [pbco co1, text "->", pco co2] +pco (TyConAppCoercion r qtc cos) = parens (pqname qtc <+> sep (map paco cos)) <> char '_' <> prole r +pco co@(AppCoercion {}) = pappco co [] +pco (ForAllCoercion tb co) = text "%forall" <+> pforallco [tb] co +pco co@(CoVarCoercion {}) = paco co +pco (UnivCoercion r ty1 ty2) = sep [text "%univ", prole r, paty ty1, paty ty2] +pco (InstCoercion co ty) = sep [text "%inst", paco co, paty ty] +pco (NthCoercion i co) = sep [text "%nth", int i, paco co] +pco (AxiomCoercion qtc i cos) = pqname qtc <> char '[' <> int i <> char ']' <+> sep (map paco cos) +pco (LRCoercion CLeft co) = sep [text "%left", paco co] +pco (LRCoercion CRight co) = sep [text "%right", paco co] +pco (SubCoercion co) = sep [text "%sub", paco co] + +pappco :: Coercion -> [Coercion ] -> Doc +pappco (AppCoercion co1 co2) cos = pappco co1 (co2:cos) +pappco co cos = sep (map paco (co:cos)) + +pforallco :: [Tbind] -> Coercion -> Doc +pforallco tbs (ForAllCoercion tb co) = pforallco (tbs ++ [tb]) co +pforallco tbs co = hsep (map ptbind tbs) <+> char '.' <+> pco co + +prole :: Role -> Doc +prole Nominal = char 'N' +prole Representational = char 'R' +prole Phantom = char 'P' + pvdefg :: Vdefg -> Doc pvdefg (Rec vdefs) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvdef vdefs)))) pvdefg (Nonrec vdef) = pvdef vdef @@ -172,7 +198,7 @@ pexp (Let vd e) = (text "%let" <+> pvdefg vd) $$ (text "%in" <+> pexp e) pexp (Case e vb ty alts) = sep [text "%case" <+> paty ty <+> paexp e, text "%of" <+> pvbind vb] $$ (indent (braces (vcat (punctuate (char ';') (map palt alts))))) -pexp (Cast e co) = (text "%cast" <+> parens (pexp e)) $$ paty co +pexp (Cast e co) = (text "%cast" <+> parens (pexp e)) $$ paco co pexp (Tick s e) = (text "%source" <+> pstring s) $$ pexp e pexp (External n cc t) = (text "%external" <+> text cc <+> pstring n) $$ paty t pexp (DynExternal cc t) = (text "%dynexternal" <+> text cc) $$ paty t diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs index c013b5da7a..f8ad8da5f4 100644 --- a/compiler/coreSyn/TrieMap.lhs +++ b/compiler/coreSyn/TrieMap.lhs @@ -14,7 +14,7 @@ {-# LANGUAGE TypeFamilies #-} module TrieMap( CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, - TypeMap, foldTypeMap, -- lookupTypeMap_mod, + TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap, CoercionMap, MaybeMap, ListMap, @@ -458,27 +458,28 @@ fdA k m = foldTM k (am_deflt m) \begin{code} data CoercionMap a = EmptyKM - | KM { km_refl :: TypeMap a - , km_tc_app :: NameEnv (ListMap CoercionMap a) + | KM { km_refl :: RoleMap (TypeMap a) + , km_tc_app :: RoleMap (NameEnv (ListMap CoercionMap a)) , km_app :: CoercionMap (CoercionMap a) , km_forall :: CoercionMap (TypeMap a) , km_var :: VarMap a , km_axiom :: NameEnv (IntMap.IntMap (ListMap CoercionMap a)) - , km_unsafe :: TypeMap (TypeMap a) + , km_univ :: RoleMap (TypeMap (TypeMap a)) , km_sym :: CoercionMap a , km_trans :: CoercionMap (CoercionMap a) , km_nth :: IntMap.IntMap (CoercionMap a) , km_left :: CoercionMap a , km_right :: CoercionMap a - , km_inst :: CoercionMap (TypeMap a) } + , km_inst :: CoercionMap (TypeMap a) + , km_sub :: CoercionMap a } wrapEmptyKM :: CoercionMap a -wrapEmptyKM = KM { km_refl = emptyTM, km_tc_app = emptyNameEnv +wrapEmptyKM = KM { km_refl = emptyTM, km_tc_app = emptyTM , km_app = emptyTM, km_forall = emptyTM , km_var = emptyTM, km_axiom = emptyNameEnv - , km_unsafe = emptyTM, km_sym = emptyTM, km_trans = emptyTM + , km_univ = emptyTM, km_sym = emptyTM, km_trans = emptyTM , km_nth = emptyTM, km_left = emptyTM, km_right = emptyTM - , km_inst = emptyTM } + , km_inst = emptyTM, km_sub = emptyTM } instance TrieMap CoercionMap where type Key CoercionMap = Coercion @@ -493,34 +494,35 @@ mapC _ EmptyKM = EmptyKM mapC f (KM { km_refl = krefl, km_tc_app = ktc , km_app = kapp, km_forall = kforall , km_var = kvar, km_axiom = kax - , km_unsafe = kunsafe, km_sym = ksym, km_trans = ktrans + , km_univ = kuniv , km_sym = ksym, km_trans = ktrans , km_nth = knth, km_left = kml, km_right = kmr - , km_inst = kinst }) - = KM { km_refl = mapTM f krefl - , km_tc_app = mapNameEnv (mapTM f) ktc + , km_inst = kinst, km_sub = ksub }) + = KM { km_refl = mapTM (mapTM f) krefl + , km_tc_app = mapTM (mapNameEnv (mapTM f)) ktc , km_app = mapTM (mapTM f) kapp , km_forall = mapTM (mapTM f) kforall , km_var = mapTM f kvar , km_axiom = mapNameEnv (IntMap.map (mapTM f)) kax - , km_unsafe = mapTM (mapTM f) kunsafe + , km_univ = mapTM (mapTM (mapTM f)) kuniv , km_sym = mapTM f ksym , km_trans = mapTM (mapTM f) ktrans , km_nth = IntMap.map (mapTM f) knth , km_left = mapTM f kml , km_right = mapTM f kmr - , km_inst = mapTM (mapTM f) kinst } + , km_inst = mapTM (mapTM f) kinst + , km_sub = mapTM f ksub } lkC :: CmEnv -> Coercion -> CoercionMap a -> Maybe a lkC env co m | EmptyKM <- m = Nothing | otherwise = go co m where - go (Refl ty) = km_refl >.> lkT env ty - go (TyConAppCo tc cs) = km_tc_app >.> lkNamed tc >=> lkList (lkC env) cs + go (Refl r ty) = km_refl >.> lookupTM r >=> lkT env ty + go (TyConAppCo r tc cs) = km_tc_app >.> lookupTM r >=> lkNamed tc >=> lkList (lkC env) cs go (AxiomInstCo ax ind cs) = km_axiom >.> lkNamed ax >=> lookupTM ind >=> lkList (lkC env) cs go (AppCo c1 c2) = km_app >.> lkC env c1 >=> lkC env c2 go (TransCo c1 c2) = km_trans >.> lkC env c1 >=> lkC env c2 - go (UnsafeCo t1 t2) = km_unsafe >.> lkT env t1 >=> lkT env t2 + go (UnivCo r t1 t2) = km_univ >.> lookupTM r >=> lkT env t1 >=> lkT env t2 go (InstCo c t) = km_inst >.> lkC env c >=> lkT env t go (ForAllCo v c) = km_forall >.> lkC (extendCME env v) c >=> lkBndr env v go (CoVarCo v) = km_var >.> lkVar env v @@ -528,15 +530,16 @@ lkC env co m go (NthCo n c) = km_nth >.> lookupTM n >=> lkC env c go (LRCo CLeft c) = km_left >.> lkC env c go (LRCo CRight c) = km_right >.> lkC env c + go (SubCo c) = km_sub >.> lkC env c xtC :: CmEnv -> Coercion -> XT a -> CoercionMap a -> CoercionMap a xtC env co f EmptyKM = xtC env co f wrapEmptyKM -xtC env (Refl ty) f m = m { km_refl = km_refl m |> xtT env ty f } -xtC env (TyConAppCo tc cs) f m = m { km_tc_app = km_tc_app m |> xtNamed tc |>> xtList (xtC env) cs f } +xtC env (Refl r ty) f m = m { km_refl = km_refl m |> xtR r |>> xtT env ty f } +xtC env (TyConAppCo r tc cs) f m = m { km_tc_app = km_tc_app m |> xtR r |>> xtNamed tc |>> xtList (xtC env) cs f } xtC env (AxiomInstCo ax ind cs) f m = m { km_axiom = km_axiom m |> xtNamed ax |>> xtInt ind |>> xtList (xtC env) cs f } xtC env (AppCo c1 c2) f m = m { km_app = km_app m |> xtC env c1 |>> xtC env c2 f } xtC env (TransCo c1 c2) f m = m { km_trans = km_trans m |> xtC env c1 |>> xtC env c2 f } -xtC env (UnsafeCo t1 t2) f m = m { km_unsafe = km_unsafe m |> xtT env t1 |>> xtT env t2 f } +xtC env (UnivCo r t1 t2) f m = m { km_univ = km_univ m |> xtR r |>> xtT env t1 |>> xtT env t2 f } xtC env (InstCo c t) f m = m { km_inst = km_inst m |> xtC env c |>> xtT env t f } xtC env (ForAllCo v c) f m = m { km_forall = km_forall m |> xtC (extendCME env v) c |>> xtBndr env v f } @@ -544,23 +547,56 @@ xtC env (CoVarCo v) f m = m { km_var = km_var m |> xtVar env v f xtC env (SymCo c) f m = m { km_sym = km_sym m |> xtC env c f } xtC env (NthCo n c) f m = m { km_nth = km_nth m |> xtInt n |>> xtC env c f } xtC env (LRCo CLeft c) f m = m { km_left = km_left m |> xtC env c f } -xtC env (LRCo CRight c) f m = m { km_right = km_right m |> xtC env c f } +xtC env (LRCo CRight c) f m = m { km_right = km_right m |> xtC env c f } +xtC env (SubCo c) f m = m { km_sub = km_sub m |> xtC env c f } fdC :: (a -> b -> b) -> CoercionMap a -> b -> b fdC _ EmptyKM = \z -> z -fdC k m = foldTM k (km_refl m) - . foldTM (foldTM k) (km_tc_app m) +fdC k m = foldTM (foldTM k) (km_refl m) + . foldTM (foldTM (foldTM k)) (km_tc_app m) . foldTM (foldTM k) (km_app m) . foldTM (foldTM k) (km_forall m) . foldTM k (km_var m) . foldTM (foldTM (foldTM k)) (km_axiom m) - . foldTM (foldTM k) (km_unsafe m) + . foldTM (foldTM (foldTM k)) (km_univ m) . foldTM k (km_sym m) . foldTM (foldTM k) (km_trans m) . foldTM (foldTM k) (km_nth m) . foldTM k (km_left m) . foldTM k (km_right m) . foldTM (foldTM k) (km_inst m) + . foldTM k (km_sub m) + +\end{code} + +\begin{code} + +newtype RoleMap a = RM { unRM :: (IntMap.IntMap a) } + +instance TrieMap RoleMap where + type Key RoleMap = Role + emptyTM = RM emptyTM + lookupTM = lkR + alterTM = xtR + foldTM = fdR + mapTM = mapR + +lkR :: Role -> RoleMap a -> Maybe a +lkR Nominal = lookupTM 1 . unRM +lkR Representational = lookupTM 2 . unRM +lkR Phantom = lookupTM 3 . unRM + +xtR :: Role -> XT a -> RoleMap a -> RoleMap a +xtR Nominal f = RM . alterTM 1 f . unRM +xtR Representational f = RM . alterTM 2 f . unRM +xtR Phantom f = RM . alterTM 3 f . unRM + +fdR :: (a -> b -> b) -> RoleMap a -> b -> b +fdR f (RM m) = foldTM f m + +mapR :: (a -> b) -> RoleMap a -> RoleMap b +mapR f = RM . mapTM f . unRM + \end{code} @@ -588,6 +624,15 @@ instance Outputable a => Outputable (TypeMap a) where foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b foldTypeMap k z m = fdT k m z +emptyTypeMap :: TypeMap a +emptyTypeMap = EmptyTM + +lookupTypeMap :: TypeMap a -> Type -> Maybe a +lookupTypeMap cm t = lkT emptyCME t cm + +extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a +extendTypeMap m t v = xtT emptyCME t (\_ -> Just v) m + wrapEmptyTypeMap :: TypeMap a wrapEmptyTypeMap = TM { tm_var = emptyTM , tm_app = EmptyTM diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index ea6e7b5768..b65304a118 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -6,13 +6,6 @@ The Desugarer: turning HsSyn into Core. \begin{code} -{-# 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 Desugar ( deSugar, deSugarExpr ) where import DynFlags @@ -34,15 +27,13 @@ import DsMonad import DsExpr import DsBinds import DsForeign -import DsExpr () -- Forces DsExpr to be compiled; DsBinds only - -- depends on DsExpr.hi-boot. import Module import RdrName import NameSet import NameEnv import Rules import BasicTypes ( Activation(.. ) ) -import CoreMonad ( endPass, CoreToDo(..) ) +import CoreMonad ( endPass, CoreToDo(..) ) import FastString import ErrUtils import Outputable @@ -57,9 +48,9 @@ import Control.Monad( when ) \end{code} %************************************************************************ -%* * -%* The main function: deSugar -%* * +%* * +%* The main function: deSugar +%* * %************************************************************************ \begin{code} @@ -67,14 +58,14 @@ import Control.Monad( when ) deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts) -- Can modify PCS by faulting in more declarations -deSugar hsc_env +deSugar hsc_env mod_loc tcg_env@(TcGblEnv { tcg_mod = mod, tcg_src = hsc_src, tcg_type_env = type_env, tcg_imports = imports, tcg_exports = exports, - tcg_keep = keep_var, + tcg_keep = keep_var, tcg_th_splice_used = tc_splice_used, tcg_rdr_env = rdr_env, tcg_fix_env = fix_env, @@ -97,16 +88,11 @@ deSugar hsc_env = do { let dflags = hsc_dflags hsc_env ; showPass dflags "Desugar" - -- Desugar the program + -- Desugar the program ; let export_set = availsToNameSet exports ; let target = hscTarget dflags ; let hpcInfo = emptyHpcInfo other_hpc_info - ; (msgs, mb_res) - <- case target of - HscNothing -> - return (emptyMessages, - Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks)) - _ -> do + ; (msgs, mb_res) <- do let want_ticks = gopt Opt_Hpc dflags || target == HscInterpreted @@ -143,7 +129,7 @@ deSugar hsc_env { -- Add export flags to bindings keep_alive <- readIORef keep_var - ; let (rules_for_locals, rules_for_imps) + ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules final_prs = addExportFlagsAndRules target export_set keep_alive rules_for_locals (fromOL all_prs) @@ -157,11 +143,11 @@ deSugar hsc_env #ifdef DEBUG -- Debug only as pre-simple-optimisation program may be really big - ; endPass dflags CoreDesugar final_pgm rules_for_imps + ; endPass dflags CoreDesugar final_pgm rules_for_imps #endif - ; (ds_binds, ds_rules_for_imps, ds_vects) + ; (ds_binds, ds_rules_for_imps, ds_vects) <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0 - -- The simpleOptPgm gets rid of type + -- The simpleOptPgm gets rid of type -- bindings plus any stupid dead code ; endPass dflags CoreDesugarOpt ds_binds ds_rules_for_imps @@ -175,9 +161,9 @@ deSugar hsc_env ; let mod_guts = ModGuts { mg_module = mod, - mg_boot = isHsBoot hsc_src, + mg_boot = isHsBoot hsc_src, mg_exports = exports, - mg_deps = deps, + mg_deps = deps, mg_used_names = used_names, mg_used_th = used_th, mg_dir_imps = imp_mods imports, @@ -202,7 +188,7 @@ deSugar hsc_env mg_dependent_files = dep_files } ; return (msgs, Just mod_guts) - }}} + }}} dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule]) dsImpSpecs imp_specs @@ -213,12 +199,12 @@ dsImpSpecs imp_specs combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind] -- Top-level bindings can include coercion bindings, but not via superclasses -- See Note [Top-level evidence] -combineEvBinds [] val_prs +combineEvBinds [] val_prs = [Rec val_prs] combineEvBinds (NonRec b r : bs) val_prs | isId b = combineEvBinds bs ((b,r):val_prs) | otherwise = NonRec b r : combineEvBinds bs val_prs -combineEvBinds (Rec prs : bs) val_prs +combineEvBinds (Rec prs : bs) val_prs = combineEvBinds bs (prs ++ val_prs) \end{code} @@ -227,7 +213,7 @@ Note [Top-level evidence] Top-level evidence bindings may be mutually recursive with the top-level value bindings, so we must put those in a Rec. But we can't put them *all* in a Rec because the occurrence analyser doesn't teke account of type/coercion variables -when computing dependencies. +when computing dependencies. So we pull out the type/coercion variables (which are in dependency order), and Rec the rest. @@ -235,9 +221,9 @@ and Rec the rest. \begin{code} deSugarExpr :: HscEnv - -> Module -> GlobalRdrEnv -> TypeEnv - -> LHsExpr Id - -> IO (Messages, Maybe CoreExpr) + -> Module -> GlobalRdrEnv -> TypeEnv + -> LHsExpr Id + -> IO (Messages, Maybe CoreExpr) -- Prints its own errors; returns Nothing if error occurred deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do @@ -259,13 +245,13 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do \end{code} %************************************************************************ -%* * -%* Add rules and export flags to binders -%* * +%* * +%* Add rules and export flags to binders +%* * %************************************************************************ \begin{code} -addExportFlagsAndRules +addExportFlagsAndRules :: HscTarget -> NameSet -> NameSet -> [CoreRule] -> [(Id, t)] -> [(Id, t)] addExportFlagsAndRules target exports keep_alive rules prs @@ -276,33 +262,33 @@ addExportFlagsAndRules target exports keep_alive rules prs name = idName bndr ---------- Rules -------- - -- See Note [Attach rules to local ids] - -- NB: the binder might have some existing rules, - -- arising from specialisation pragmas + -- See Note [Attach rules to local ids] + -- NB: the binder might have some existing rules, + -- arising from specialisation pragmas add_rules name bndr - | Just rules <- lookupNameEnv rule_base name - = bndr `addIdSpecialisations` rules - | otherwise - = bndr + | Just rules <- lookupNameEnv rule_base name + = bndr `addIdSpecialisations` rules + | otherwise + = bndr rule_base = extendRuleBaseList emptyRuleBase rules ---------- Export flag -------- -- See Note [Adding export flags] add_export name bndr - | dont_discard name = setIdExported bndr - | otherwise = bndr + | dont_discard name = setIdExported bndr + | otherwise = bndr dont_discard :: Name -> Bool dont_discard name = is_exported name - || name `elemNameSet` keep_alive - - -- In interactive mode, we don't want to discard any top-level - -- entities at all (eg. do not inline them away during - -- simplification), and retain them all in the TypeEnv so they are - -- available from the command line. - -- - -- isExternalName separates the user-defined top-level names from those - -- introduced by the type checker. + || name `elemNameSet` keep_alive + + -- In interactive mode, we don't want to discard any top-level + -- entities at all (eg. do not inline them away during + -- simplification), and retain them all in the TypeEnv so they are + -- available from the command line. + -- + -- isExternalName separates the user-defined top-level names from those + -- introduced by the type checker. is_exported :: Name -> Bool is_exported | targetRetainsAllBindings target = isExternalName | otherwise = (`elemNameSet` exports) @@ -311,13 +297,13 @@ addExportFlagsAndRules target exports keep_alive rules prs Note [Adding export flags] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -Set the no-discard flag if either - a) the Id is exported - b) it's mentioned in the RHS of an orphan rule - c) it's in the keep-alive set +Set the no-discard flag if either + a) the Id is exported + b) it's mentioned in the RHS of an orphan rule + c) it's in the keep-alive set It means that the binding won't be discarded EVEN if the binding -ends up being trivial (v = w) -- the simplifier would usually just +ends up being trivial (v = w) -- the simplifier would usually just substitute w for v throughout, but we don't apply the substitution to the rules (maybe we should?), so this substitution would make the rule bogus. @@ -346,37 +332,37 @@ Reason %************************************************************************ -%* * -%* Desugaring transformation rules -%* * +%* * +%* Desugaring transformation rules +%* * %************************************************************************ \begin{code} dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule) dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) - = putSrcSpanDs loc $ - do { let bndrs' = [var | RuleBndr (L _ var) <- vars] + = putSrcSpanDs loc $ + do { let bndrs' = [var | RuleBndr (L _ var) <- vars] ; lhs' <- unsetGOptM Opt_EnableRewriteRules $ unsetWOptM Opt_WarnIdentities $ dsLExpr lhs -- Note [Desugaring RULE left hand sides] - ; rhs' <- dsLExpr rhs + ; rhs' <- dsLExpr rhs ; dflags <- getDynFlags - -- Substitute the dict bindings eagerly, - -- and take the body apart into a (f args) form - ; case decomposeRuleLhs bndrs' lhs' of { - Left msg -> do { warnDs msg; return Nothing } ; - Right (final_bndrs, fn_id, args) -> do - - { let is_local = isLocalId fn_id - -- NB: isLocalId is False of implicit Ids. This is good because - -- we don't want to attach rules to the bindings of implicit Ids, - -- because they don't show up in the bindings until just before code gen - fn_name = idName fn_id - final_rhs = simpleOptExpr rhs' -- De-crap it - rule = mkRule False {- Not auto -} is_local + -- Substitute the dict bindings eagerly, + -- and take the body apart into a (f args) form + ; case decomposeRuleLhs bndrs' lhs' of { + Left msg -> do { warnDs msg; return Nothing } ; + Right (final_bndrs, fn_id, args) -> do + + { let is_local = isLocalId fn_id + -- NB: isLocalId is False of implicit Ids. This is good because + -- we don't want to attach rules to the bindings of implicit Ids, + -- because they don't show up in the bindings until just before code gen + fn_name = idName fn_id + final_rhs = simpleOptExpr rhs' -- De-crap it + rule = mkRule False {- Not auto -} is_local name act fn_name final_bndrs args final_rhs inline_shadows_rule -- Function can be inlined before rule fires @@ -399,8 +385,8 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) , ptext (sLit "Probable fix: add an INLINE[n] or NOINLINE[n] pragma on") <+> quotes (ppr fn_id) ]) - ; return (Just rule) - } } } + ; return (Just rule) + } } } \end{code} Note [Desugaring RULE left hand sides] @@ -429,7 +415,7 @@ the rule is precisly to optimise them: \begin{code} dsVect :: LVectDecl Id -> DsM CoreVect dsVect (L loc (HsVect (L _ v) rhs)) - = putSrcSpanDs loc $ + = putSrcSpanDs loc $ do { rhs' <- dsLExpr rhs ; return $ Vect v rhs' } diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 41172e1dd7..617516bd97 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -65,6 +65,7 @@ import Maybes import OrdList import Bag import BasicTypes hiding ( TopLevel ) +import Pair import DynFlags import FastString import ErrUtils( MsgDoc ) @@ -447,24 +448,24 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) = putSrcSpanDs loc $ do { uniq <- newUnique ; let poly_name = idName poly_id - spec_name = mkClonedInternalName uniq poly_name + spec_occ = mkSpecOcc (getOccName poly_name) + spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name) ; (bndrs, ds_lhs) <- liftM collectBinders (dsHsWrapper spec_co (Var poly_id)) ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs) ; case decomposeRuleLhs bndrs ds_lhs of { Left msg -> do { warnDs msg; return Nothing } ; - Right (final_bndrs, _fn, args) -> do + Right (rule_bndrs, _fn, args) -> do - { (spec_unf, unf_pairs) <- specUnfolding spec_co spec_ty (realIdUnfolding poly_id) - - ; dflags <- getDynFlags - ; let spec_id = mkLocalId spec_name spec_ty + { dflags <- getDynFlags + ; let spec_unf = specUnfolding bndrs args (realIdUnfolding poly_id) + spec_id = mkLocalId spec_name spec_ty `setInlinePragma` inl_prag `setIdUnfolding` spec_unf rule = mkRule False {- Not auto -} is_local_id (mkFastString ("SPEC " ++ showPpr dflags poly_name)) rule_act poly_name - final_bndrs args + rule_bndrs args (mkVarApps (Var spec_id) bndrs) ; spec_rhs <- dsHsWrapper spec_co poly_rhs @@ -472,7 +473,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) ; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags) (warnDs (specOnInline poly_name)) - ; return (Just (spec_pair `consOL` unf_pairs, rule)) + ; return (Just (unitOL spec_pair, rule)) } } } where is_local_id = isJust mb_poly_rhs @@ -509,18 +510,15 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) | otherwise = spec_prag_act -- Specified by user -specUnfolding :: HsWrapper -> Type - -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr)) -{- [Dec 10: TEMPORARILY commented out, until we can straighten out how to - generate unfoldings for specialised DFuns +specUnfolding :: [Var] -> [CoreExpr] -> Unfolding -> Unfolding +specUnfolding new_bndrs new_args df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = ASSERT2( equalLength new_args bndrs, ppr df $$ ppr new_args $$ ppr new_bndrs ) + df { df_bndrs = new_bndrs, df_args = map (substExpr (text "specUnfolding") subst) args } + where + subst = mkOpenSubst (mkInScopeSet fvs) (bndrs `zip` new_args) + fvs = (exprsFreeVars args `delVarSetList` bndrs) `extendVarSetList` new_bndrs -specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops) - = do { let spec_rhss = map wrap_fn ops - ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss - ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) } --} -specUnfolding _ _ _ - = return (noUnfolding, nilOL) +specUnfolding _ _ _ = noUnfolding specOnInline :: Name -> MsgDoc specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:") @@ -598,8 +596,8 @@ decomposeRuleLhs bndrs lhs opt_lhs = simpleOptExpr lhs check_bndrs fn args - | null (dead_bndrs) = Right (extra_dict_bndrs ++ bndrs, fn, args) - | otherwise = Left (vcat (map dead_msg dead_bndrs)) + | null dead_bndrs = Right (extra_dict_bndrs ++ bndrs, fn, args) + | otherwise = Left (vcat (map dead_msg dead_bndrs)) where arg_fvs = exprsFreeVars args @@ -708,7 +706,7 @@ dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty) dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds return (mkCoreLets bs e) dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 =<< dsHsWrapper c2 e -dsHsWrapper (WpCast co) e = dsTcCoercion co (mkCast e) +dsHsWrapper (WpCast co) e = dsTcCoercion Representational co (mkCast e) dsHsWrapper (WpEvLam ev) e = return $ Lam ev e dsHsWrapper (WpTyLam tv) e = return $ Lam tv e dsHsWrapper (WpEvApp evtrm) e = liftM (App e) (dsEvTerm evtrm) @@ -742,13 +740,16 @@ dsEvTerm (EvId v) = return (Var v) dsEvTerm (EvCast tm co) = do { tm' <- dsEvTerm tm - ; dsTcCoercion co $ mkCast tm' } + ; dsTcCoercion Representational co $ mkCast tm' } -- 'v' is always a lifted evidence variable so it is -- unnecessary to call varToCoreExpr v here. dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms ; return (Var df `mkTyApps` tys `mkApps` tms') } -dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox + +dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v) -- See Note [Simple coercions] +dsEvTerm (EvCoercion co) = dsTcCoercion Nominal co mkEqBox + dsEvTerm (EvTupleSel v n) = do { tm' <- dsEvTerm v ; let scrut_ty = exprType tm' @@ -785,24 +786,24 @@ dsEvTerm (EvLit l) = EvStr s -> mkStringExprFS s --------------------------------------- -dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr +dsTcCoercion :: Role -> TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr -- This is the crucial function that moves -- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion -- e.g. dsTcCoercion (trans g1 g2) k -- = case g1 of EqBox g1# -> -- case g2 of EqBox g2# -> -- k (trans g1# g2#) -dsTcCoercion co thing_inside +-- thing_inside will get a coercion at the role requested +dsTcCoercion role co thing_inside = do { us <- newUniqueSupply ; let eqvs_covs :: [(EqVar,CoVar)] eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co)) (uniqsFromSupply us) subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs] - result_expr = thing_inside (ds_tc_coercion subst co) + result_expr = thing_inside (ds_tc_coercion subst role co) result_ty = exprType result_expr - ; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) } where mk_co_var :: Id -> Unique -> (Id, Id) @@ -811,36 +812,41 @@ dsTcCoercion co thing_inside eq_nm = idName eqv occ = nameOccName eq_nm loc = nameSrcSpan eq_nm - ty = mkCoercionType ty1 ty2 + ty = mkCoercionType Nominal ty1 ty2 (ty1, ty2) = getEqPredTys (evVarPred eqv) wrap_in_case result_ty (eqv, cov) body = Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)] -ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion +ds_tc_coercion :: CvSubst -> Role -> TcCoercion -> Coercion -- If the incoming TcCoercion if of type (a ~ b), -- the result is of type (a ~# b) -- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b) -- No need for InScope set etc because the -ds_tc_coercion subst tc_co - = go tc_co +ds_tc_coercion subst role tc_co + = go role tc_co where - go (TcRefl ty) = Refl (Coercion.substTy subst ty) - go (TcTyConAppCo tc cos) = mkTyConAppCo tc (map go cos) - go (TcAppCo co1 co2) = mkAppCo (go co1) (go co2) - go (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' co) + go Phantom co + = mkUnivCo Phantom ty1 ty2 + where Pair ty1 ty2 = tcCoercionKind co + + go r (TcRefl ty) = Refl r (Coercion.substTy subst ty) + go r (TcTyConAppCo tc cos) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) cos) + go r (TcAppCo co1 co2) = mkAppCo (go r co1) (go Nominal co2) + go r (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' r co) where (subst', tv') = Coercion.substTyVarBndr subst tv - go (TcAxiomInstCo ax ind tys) - = mkAxInstCo ax ind (map (Coercion.substTy subst) tys) - go (TcSymCo co) = mkSymCo (go co) - go (TcTransCo co1 co2) = mkTransCo (go co1) (go co2) - go (TcNthCo n co) = mkNthCo n (go co) - go (TcLRCo lr co) = mkLRCo lr (go co) - go (TcInstCo co ty) = mkInstCo (go co) ty - go (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) co - go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2) - go (TcCoVarCo v) = ds_ev_id subst v + go r (TcAxiomInstCo ax ind tys) + = mkAxInstCo r ax ind (map (Coercion.substTy subst) tys) + go r (TcSymCo co) = mkSymCo (go r co) + go r (TcTransCo co1 co2) = mkTransCo (go r co1) (go r co2) + go r (TcNthCo n co) = mkNthCoRole r n (go r co) -- the 2nd r is a harmless lie + go r (TcLRCo lr co) = maybeSubCo r $ mkLRCo lr (go Nominal co) + go r (TcInstCo co ty) = mkInstCo (go r co) ty + go r (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) r co + go r (TcCastCo co1 co2) = maybeSubCo r $ mkCoCast (go Nominal co1) + (go Nominal co2) + go r (TcCoVarCo v) = maybeSubCo r $ ds_ev_id subst v ds_co_binds :: TcEvBinds -> CvSubst ds_co_binds (EvBinds bs) = foldl ds_scc subst (sccEvBinds bs) @@ -852,9 +858,9 @@ ds_tc_coercion subst tc_co ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co) ds_co_term :: CvSubst -> EvTerm -> Coercion - ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co + ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst Nominal tc_co ds_co_term subst (EvId v) = ds_ev_id subst v - ds_co_term subst (EvCast tm co) = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst co) + ds_co_term subst (EvCast tm co) = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst Nominal co) ds_co_term _ other = pprPanic "ds_co_term" (ppr other $$ ppr tc_co) ds_ev_id :: CvSubst -> EqVar -> Coercion @@ -862,3 +868,30 @@ ds_tc_coercion subst tc_co | Just co <- Coercion.lookupCoVar subst v = co | otherwise = pprPanic "ds_tc_coercion" (ppr v $$ ppr tc_co) \end{code} + +Note [Simple coercions] +~~~~~~~~~~~~~~~~~~~~~~~ +We have a special case for coercions that are simple variables. +Suppose cv :: a ~ b is in scope +Lacking the special case, if we see + f a b cv +we'd desguar to + f a b (case cv of EqBox (cv# :: a ~# b) -> EqBox cv#) +which is a bit stupid. The special case does the obvious thing. + +This turns out to be important when desugaring the LHS of a RULE +(see Trac #7837). Suppose we have + normalise :: (a ~ Scalar a) => a -> a + normalise_Double :: Double -> Double + {-# RULES "normalise" normalise = normalise_Double #-} + +Then the RULE we want looks like + forall a, (cv:a~Scalar a). + normalise a cv = normalise_Double +But without the special case we generate the redundant box/unbox, +which simpleOpt (currently) doesn't remove. So the rule never matches. + +Maybe simpleOpt should be smarter. But it seems like a good plan +to simply never generate the redundant box/unbox in the first place. + + diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 226eee27bd..6945cf38e0 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -54,9 +54,15 @@ import SrcLoc import Util import Bag import Outputable +import Literal +import TyCon import FastString import Control.Monad +import Data.Int +import Data.Traversable (traverse) +import Data.Typeable (typeOf) +import Data.Word \end{code} @@ -211,7 +217,10 @@ dsExpr (HsLamCase arg matches) ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code } dsExpr (HsApp fun arg) - = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg + = do ds <- mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg + warn_overflowed_literals <- woptM Opt_WarnOverflowedLiterals + when warn_overflowed_literals $ warnAboutOverflowedLiterals ds + return ds dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar" \end{code} @@ -710,11 +719,24 @@ dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr dsArithSeq expr (From from) = App <$> dsExpr expr <*> dsLExpr from dsArithSeq expr (FromTo from to) - = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to] + = do expr' <- dsExpr expr + from' <- dsLExpr from + to' <- dsLExpr to + warn_empty_enumerations <- woptM Opt_WarnEmptyEnumerations + when warn_empty_enumerations $ + warnAboutEmptyEnumerations from' Nothing to' + return $ mkApps expr' [from', to'] dsArithSeq expr (FromThen from thn) = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn] dsArithSeq expr (FromThenTo from thn to) - = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to] + = do expr' <- dsExpr expr + from' <- dsLExpr from + thn' <- dsLExpr thn + to' <- dsLExpr to + warn_empty_enumerations <- woptM Opt_WarnEmptyEnumerations + when warn_empty_enumerations $ + warnAboutEmptyEnumerations from' (Just thn') to' + return $ mkApps expr' [from', thn', to'] \end{code} Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're @@ -760,8 +782,7 @@ dsDo stmts , recS_rec_ids = rec_ids, recS_ret_fn = return_op , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts - = ASSERT( length rec_ids > 0 ) - goL (new_bind_stmt : stmts) + = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' } where new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTup later_pats) mfix_app bind_op @@ -806,7 +827,7 @@ mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ %************************************************************************ %* * - Warning about identities + Warnings %* * %************************************************************************ @@ -835,6 +856,72 @@ conversionNames -- because they are generated by literals \end{code} +\begin{code} +warnAboutOverflowedLiterals :: CoreExpr -> DsM () +warnAboutOverflowedLiterals (App (App (App (Var f) (Type t)) _) (Lit (LitInteger i _))) + | idName f == fromIntegerName, + Just tc <- tyConAppTyCon_maybe t, + let t = tyConName tc + = let checkOverflow proxy + = when (i < fromIntegral (minBound `asTypeOf` proxy) || + i > fromIntegral (maxBound `asTypeOf` proxy)) $ + warnDs (ptext (sLit "Literal") <+> integer i <+> + ptext (sLit "of type") <+> + text (show (typeOf proxy)) <+> + ptext (sLit "overflows")) + in if t == intTyConName then checkOverflow (undefined :: Int) + else if t == int8TyConName then checkOverflow (undefined :: Int8) + else if t == int16TyConName then checkOverflow (undefined :: Int16) + else if t == int32TyConName then checkOverflow (undefined :: Int32) + else if t == int64TyConName then checkOverflow (undefined :: Int64) + else if t == wordTyConName then checkOverflow (undefined :: Word) + else if t == word8TyConName then checkOverflow (undefined :: Word8) + else if t == word16TyConName then checkOverflow (undefined :: Word16) + else if t == word32TyConName then checkOverflow (undefined :: Word32) + else if t == word64TyConName then checkOverflow (undefined :: Word64) + else return () +warnAboutOverflowedLiterals _ = return () +\end{code} + +\begin{code} +warnAboutEmptyEnumerations :: CoreExpr -> Maybe CoreExpr -> CoreExpr -> DsM () +warnAboutEmptyEnumerations fromExpr mThnExpr toExpr + | Just from <- getVal fromExpr + , Just mThn <- traverse getVal mThnExpr + , Just to <- getVal toExpr + , Just t <- getType fromExpr + = let check proxy + = let enumeration + = case mThn of + Nothing -> [(fromInteger from `asTypeOf` proxy) .. fromInteger to] + Just thn -> [fromInteger from, fromInteger thn .. fromInteger to] + in when (null enumeration) $ + warnDs (ptext (sLit "Enumeration is empty")) + + in if t == intTyConName then check (undefined :: Int) + else if t == int8TyConName then check (undefined :: Int8) + else if t == int16TyConName then check (undefined :: Int16) + else if t == int32TyConName then check (undefined :: Int32) + else if t == int64TyConName then check (undefined :: Int64) + else if t == wordTyConName then check (undefined :: Word) + else if t == word8TyConName then check (undefined :: Word8) + else if t == word16TyConName then check (undefined :: Word16) + else if t == word32TyConName then check (undefined :: Word32) + else if t == word64TyConName then check (undefined :: Word64) + else return () + + where getVal (App (App (App (Var f) (Type _)) _) (Lit (LitInteger i _))) + | idName f == fromIntegerName = Just i + getVal _ = Nothing + + getType (App (App (App (Var f) (Type t)) _) (Lit (LitInteger _ _))) + | idName f == fromIntegerName, + Just tc <- tyConAppTyCon_maybe t = Just (tyConName tc) + getType _ = Nothing + +warnAboutEmptyEnumerations _ _ _ = return () +\end{code} + %************************************************************************ %* * \subsection{Errors and contexts} diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 9be8e96615..1053b91aaa 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -418,7 +418,7 @@ dsFExportDynamic id co0 cconv = do export_ty = mkFunTy stable_ptr_ty arg_ty bindIOId <- dsLookupGlobalId bindIOName stbl_value <- newSysLocalDs stable_ptr_ty - (h_code, c_code, typestring, args_size) <- dsFExport id (Refl export_ty) fe_nm cconv True + (h_code, c_code, typestring, args_size) <- dsFExport id (mkReflCo Representational export_ty) fe_nm cconv True let {- The arguments to the external function which will diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index ae7a3cc271..7a8fd2da70 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -13,24 +13,17 @@ -- a Royal Pain (triggers other recompilation). ----------------------------------------------------------------------------- -{-# 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 DsMeta( dsBracket, - templateHaskellNames, qTyConName, nameTyConName, - liftName, liftStringName, expQTyConName, patQTyConName, + templateHaskellNames, qTyConName, nameTyConName, + liftName, liftStringName, expQTyConName, patQTyConName, decQTyConName, decsQTyConName, typeQTyConName, - decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName, - quoteExpName, quotePatName, quoteDecName, quoteTypeName - ) where + decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName, + quoteExpName, quotePatName, quoteDecName, quoteTypeName + ) where #include "HsVersions.h" -import {-# SOURCE #-} DsExpr ( dsExpr ) +import {-# SOURCE #-} DsExpr ( dsExpr ) import MatchLit import DsMonad @@ -105,7 +98,7 @@ dsBracket brack splices ------------------------------------------------------- --- Declarations +-- Declarations ------------------------------------------------------- repTopP :: LPat Name -> DsM (Core TH.PatQ) @@ -117,34 +110,34 @@ repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec])) repTopDs group = do { let { tv_bndrs = hsSigTvBinders (hs_valds group) ; bndrs = tv_bndrs ++ hsGroupBinders group } ; - ss <- mkGenSyms bndrs ; + ss <- mkGenSyms bndrs ; - -- Bind all the names mainly to avoid repeated use of explicit strings. - -- Thus we get - -- do { t :: String <- genSym "T" ; - -- return (Data t [] ...more t's... } - -- The other important reason is that the output must mention - -- only "T", not "Foo:T" where Foo is the current module + -- Bind all the names mainly to avoid repeated use of explicit strings. + -- Thus we get + -- do { t :: String <- genSym "T" ; + -- return (Data t [] ...more t's... } + -- The other important reason is that the output must mention + -- only "T", not "Foo:T" where Foo is the current module - decls <- addBinds ss (do { + decls <- addBinds ss (do { fix_ds <- mapM repFixD (hs_fixds group) ; - val_ds <- rep_val_binds (hs_valds group) ; - tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ; - inst_ds <- mapM repInstD (hs_instds group) ; - rule_ds <- mapM repRuleD (hs_ruleds group) ; - for_ds <- mapM repForD (hs_fords group) ; - -- more needed - return (de_loc $ sort_by_loc $ + val_ds <- rep_val_binds (hs_valds group) ; + tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ; + inst_ds <- mapM repInstD (hs_instds group) ; + rule_ds <- mapM repRuleD (hs_ruleds group) ; + for_ds <- mapM repForD (hs_fords group) ; + -- more needed + return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ fix_ds ++ inst_ds ++ rule_ds ++ for_ds) }) ; - decl_ty <- lookupType decQTyConName ; - let { core_list = coreList' decl_ty decls } ; + decl_ty <- lookupType decQTyConName ; + let { core_list = coreList' decl_ty decls } ; - dec_ty <- lookupType decTyConName ; - q_decs <- repSequenceQ dec_ty core_list ; + dec_ty <- lookupType decTyConName ; + q_decs <- repSequenceQ dec_ty core_list ; - wrapGenSyms ss q_decs + wrapGenSyms ss q_decs } @@ -155,8 +148,8 @@ hsSigTvBinders binds , tv <- hsQTvBndrs qtvs] where sigs = case binds of - ValBindsIn _ sigs -> sigs - ValBindsOut _ sigs -> sigs + ValBindsIn _ sigs -> sigs + ValBindsOut _ sigs -> sigs {- Notes @@ -180,19 +173,19 @@ Note [Binders and occurrences] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we desugar [d| data T = MkT |] we want to get - Data "T" [] [Con "MkT" []] [] + Data "T" [] [Con "MkT" []] [] and *not* - Data "Foo:T" [] [Con "Foo:MkT" []] [] + Data "Foo:T" [] [Con "Foo:MkT" []] [] That is, the new data decl should fit into whatever new module it is asked to fit in. We do *not* clone, though; no need for this: - Data "T79" .... + Data "T79" .... But if we see this: - data T = MkT - foo = reifyDecl T + data T = MkT + foo = reifyDecl T then we must desugar to - foo = Data "Foo:T" [] [Con "Foo:MkT" []] [] + foo = Data "Foo:T" [] [Con "Foo:MkT" []] [] So in repTopDs we bring the binders into scope with mkGenSyms and addBinds. And we use lookupOcc, rather than lookupBinder @@ -207,39 +200,39 @@ repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam) repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) - = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; dec <- addTyClTyVarBinds tvs $ \bndrs -> - repSynDecl tc1 bndrs rhs + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + ; dec <- addTyClTyVarBinds tvs $ \bndrs -> + repSynDecl tc1 bndrs rhs ; return (Just (loc, dec)) } repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn })) - = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; tc_tvs <- mk_extra_tvs tc tvs defn - ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs -> - repDataDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn + ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs -> + repDataDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn ; return (Just (loc, dec)) } -repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, - tcdTyVars = tvs, tcdFDs = fds, - tcdSigs = sigs, tcdMeths = meth_binds, +repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, + tcdTyVars = tvs, tcdFDs = fds, + tcdSigs = sigs, tcdMeths = meth_binds, tcdATs = ats, tcdATDefs = [] })) - = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences] - ; dec <- addTyVarBinds tvs $ \bndrs -> + = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences] + ; dec <- addTyVarBinds tvs $ \bndrs -> do { cxt1 <- repLContext cxt - ; sigs1 <- rep_sigs sigs - ; binds1 <- rep_binds meth_binds - ; fds1 <- repLFunDeps fds + ; sigs1 <- rep_sigs sigs + ; binds1 <- rep_binds meth_binds + ; fds1 <- repLFunDeps fds ; ats1 <- repFamilyDecls ats - ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1) - ; repClass cxt1 cls1 bndrs fds1 decls1 + ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1) + ; repClass cxt1 cls1 bndrs fds1 decls1 } - ; return $ Just (loc, dec) + ; return $ Just (loc, dec) } -- Un-handled cases repTyClD (L loc d) = putSrcSpanDs loc $ - do { warnDs (hang ds_msg 4 (ppr d)) - ; return Nothing } + do { warnDs (hang ds_msg 4 (ppr d)) + ; return Nothing } ------------------------- repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr] @@ -248,7 +241,7 @@ repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr] -> DsM (Core TH.DecQ) repDataDefn tc bndrs opt_tys tv_names (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt - , dd_cons = cons, dd_derivs = mb_derivs }) + , dd_cons = cons, dd_derivs = mb_derivs }) = do { cxt1 <- repLContext cxt ; derivs1 <- repDerivs mb_derivs ; case new_or_data of @@ -265,18 +258,29 @@ repSynDecl tc bndrs ty ; repTySyn tc bndrs ty1 } repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ) -repFamilyDecl (L loc (FamilyDecl { fdFlavour = flavour, +repFamilyDecl (L loc (FamilyDecl { fdInfo = info, fdLName = tc, - fdTyVars = tvs, - fdKindSig = opt_kind })) - = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] + fdTyVars = tvs, + fdKindSig = opt_kind })) + = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; dec <- addTyClTyVarBinds tvs $ \bndrs -> - do { flav <- repFamilyFlavour flavour - ; case opt_kind of - Nothing -> repFamilyNoKind flav tc1 bndrs - Just ki -> do { ki1 <- repLKind ki - ; repFamilyKind flav tc1 bndrs ki1 } - } + case (opt_kind, info) of + (Nothing, ClosedTypeFamily eqns) -> + do { eqns1 <- mapM repTyFamEqn eqns + ; eqns2 <- coreList tySynEqnQTyConName eqns1 + ; repClosedFamilyNoKind tc1 bndrs eqns2 } + (Just ki, ClosedTypeFamily eqns) -> + do { eqns1 <- mapM repTyFamEqn eqns + ; eqns2 <- coreList tySynEqnQTyConName eqns1 + ; ki1 <- repLKind ki + ; repClosedFamilyKind tc1 bndrs ki1 eqns2 } + (Nothing, _) -> + do { info' <- repFamilyInfo info + ; repFamilyNoKind info' tc1 bndrs } + (Just ki, _) -> + do { info' <- repFamilyInfo info + ; ki1 <- repLKind ki + ; repFamilyKind info' tc1 bndrs ki1 } ; return (loc, dec) } @@ -284,7 +288,7 @@ repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ] repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds) ------------------------- -mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name +mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name) -- If there is a kind signature it must be of form -- k1 -> .. -> kn -> * @@ -301,7 +305,7 @@ mk_extra_tvs tc tvs defn = do { uniq <- newUnique ; let { occ = mkTyVarOccFS (fsLit "t") ; nm = mkInternalName uniq occ loc - ; hs_tv = L loc (KindedTyVar nm kind) } + ; hs_tv = L loc (HsTyVarBndr nm (Just kind) Nothing) } ; hs_tvs <- go rest ; return (hs_tv : hs_tvs) } @@ -324,9 +328,10 @@ repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs -- represent family declaration flavours -- -repFamilyFlavour :: FamilyFlavour -> DsM (Core TH.FamFlavour) -repFamilyFlavour TypeFamily = rep2 typeFamName [] -repFamilyFlavour DataFamily = rep2 dataFamName [] +repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour) +repFamilyInfo OpenTypeFamily = rep2 typeFamName [] +repFamilyInfo DataFamily = rep2 dataFamName [] +repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo" -- Represent instance declarations -- @@ -346,15 +351,15 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds , cid_sigs = prags, cid_tyfam_insts = ats , cid_datafam_insts = adts }) = addTyVarBinds tvs $ \_ -> - -- We must bring the type variables into scope, so their - -- occurrences don't fail, even though the binders don't + -- We must bring the type variables into scope, so their + -- occurrences don't fail, even though the binders don't -- appear in the resulting data structure - -- - -- But we do NOT bring the binders of 'binds' into scope - -- because they are properly regarded as occurrences - -- For example, the method names should be bound to - -- the selector Ids, not to fresh names (Trac #5410) - -- + -- + -- But we do NOT bring the binders of 'binds' into scope + -- because they are properly regarded as occurrences + -- For example, the method names should be bound to + -- the selector Ids, not to fresh names (Trac #5410) + -- do { cxt1 <- repContext cxt ; cls_tcon <- repTy (HsTyVar (unLoc cls)) ; cls_tys <- repLTys tys @@ -369,12 +374,11 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ) -repTyFamInstD decl@(TyFamInstDecl { tfid_eqns = eqns }) +repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) = do { let tc_name = tyFamInstDeclLName decl - ; tc <- lookupLOcc tc_name -- See note [Binders and occurrences] - ; eqns1 <- mapM repTyFamEqn eqns - ; eqns2 <- coreList tySynEqnQTyConName eqns1 - ; repTySynInst tc eqns2 } + ; tc <- lookupLOcc tc_name -- See note [Binders and occurrences] + ; eqn1 <- repTyFamEqn eqn + ; repTySynInst tc eqn1 } repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ) repTyFamEqn (L loc (TyFamInstEqn { tfie_pats = HsWB { hswb_cts = tys @@ -393,7 +397,7 @@ repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ) repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name , dfid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names } , dfid_defn = defn }) - = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] + = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] ; let loc = getLoc tc_name hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk ; addTyClTyVarBinds hs_tvs $ \ bndrs -> @@ -461,7 +465,7 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) ruleBndrNames :: RuleBndr Name -> [Name] ruleBndrNames (RuleBndr n) = [unLoc n] -ruleBndrNames (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs })) +ruleBndrNames (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs })) = unLoc n : kvs ++ tvs repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ) @@ -477,14 +481,14 @@ ds_msg :: SDoc ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") ------------------------------------------------------- --- Constructors +-- Constructors ------------------------------------------------------- repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ) repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ [] , con_details = details, con_res = ResTyH98 })) | null (hsQTvBndrs con_tvs) - = do { con1 <- lookupLOcc con -- See Note [Binders and occurrences] + = do { con1 <- lookupLOcc con -- See Note [Binders and occurrences] ; repConstr con1 details } repC tvs (L _ (ConDecl { con_name = con @@ -495,10 +499,10 @@ repC tvs (L _ (ConDecl { con_name = con ; let ex_tvs = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) (hsq_kvs con_tvs) , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) } - ; binds <- mapM dupBinder con_tv_subst + ; binds <- mapM dupBinder con_tv_subst ; dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs - do { con1 <- lookupLOcc con -- See Note [Binders and occurrences] + do { con1 <- lookupLOcc con -- See Note [Binders and occurrences] ; c' <- repConstr con1 details ; ctxt' <- repContext (eq_ctxt ++ ctxt) ; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } } @@ -507,9 +511,9 @@ in_subst :: [(Name,Name)] -> Name -> Bool in_subst [] _ = False in_subst ((n',_):ns) n = n==n' || in_subst ns n -mkGadtCtxt :: [Name] -- Tyvars of the data type +mkGadtCtxt :: [Name] -- Tyvars of the data type -> ResType (LHsType Name) - -> DsM (HsContext Name, [(Name,Name)]) + -> DsM (HsContext Name, [(Name,Name)]) -- Given a data type in GADT syntax, figure out the equality -- context, so that we can represent it with an explicit -- equality context, because that is the only way to express @@ -525,8 +529,7 @@ mkGadtCtxt :: [Name] -- Tyvars of the data type mkGadtCtxt _ ResTyH98 = return ([], []) mkGadtCtxt data_tvs (ResTyGADT res_ty) - | let (head_ty, tys) = splitHsAppTys res_ty [] - , Just _ <- is_hs_tyvar head_ty + | Just (_, tys) <- hsTyGetAppHead_maybe res_ty , data_tvs `equalLength` tys = return (go [] [] (data_tvs `zip` tys)) @@ -557,12 +560,12 @@ repBangTy ty= do rep2 strictTypeName [s, t] where (str, ty') = case ty of - L _ (HsBangTy (HsUserBang (Just True) True) ty) -> (unpackedName, ty) - L _ (HsBangTy (HsUserBang _ True) ty) -> (isStrictName, ty) - _ -> (notStrictName, ty) + L _ (HsBangTy (HsUserBang (Just True) True) ty) -> (unpackedName, ty) + L _ (HsBangTy (HsUserBang _ True) ty) -> (isStrictName, ty) + _ -> (notStrictName, ty) ------------------------------------------------------- --- Deriving clause +-- Deriving clause ------------------------------------------------------- repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name]) @@ -571,7 +574,7 @@ repDerivs (Just ctxt) = repList nameTyConName rep_deriv ctxt where rep_deriv :: LHsType Name -> DsM (Core TH.Name) - -- Deriving clauses must have the simple H98 form + -- Deriving clauses must have the simple H98 form rep_deriv ty | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty) = lookupOcc cls @@ -588,13 +591,13 @@ rep_sigs sigs = do locs_cores <- rep_sigs' sigs return $ de_loc $ sort_by_loc locs_cores rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)] - -- We silently ignore ones we don't recognise + -- We silently ignore ones we don't recognise rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; - return (concat sigs1) } + return (concat sigs1) } rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] - -- Singleton => Ok - -- Empty => Too hard, signature ignored + -- Singleton => Ok + -- Empty => Too hard, signature ignored rep_sig (L loc (TypeSig nms ty)) = mapM (rep_ty_sig loc ty) nms rep_sig (L _ (GenericSig nm _)) = failWithDs msg where msg = vcat [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm) @@ -627,7 +630,7 @@ rep_ty_sig loc (L _ ty) nm rep_inline :: Located Name - -> InlinePragma -- Never defaultInlinePragma + -> InlinePragma -- Never defaultInlinePragma -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_inline nm ispec loc @@ -679,10 +682,10 @@ repPhases (ActiveAfter i) = do { MkC arg <- coreIntLit i repPhases _ = dataCon allPhasesDataConName ------------------------------------------------------- --- Types +-- Types ------------------------------------------------------- -addTyVarBinds :: LHsTyVarBndrs Name -- the binders to be added +addTyVarBinds :: LHsTyVarBndrs Name -- the binders to be added -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env -> DsM (Core (TH.Q a)) -- gensym a list of type variables and enter them into the meta environment; @@ -691,9 +694,9 @@ addTyVarBinds :: LHsTyVarBndrs Name -- the binders to be addTyVarBinds tvs m = do { freshNames <- mkGenSyms (hsLKiTyVarNames tvs) - ; term <- addBinds freshNames $ - do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames) - ; m kbs } + ; term <- addBinds freshNames $ + do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames) + ; m kbs } ; wrapGenSyms freshNames term } where mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) @@ -711,12 +714,12 @@ addTyClTyVarBinds tvs m = do { let tv_names = hsLKiTyVarNames tvs ; env <- dsGetMetaEnv ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names) - -- Make fresh names for the ones that are not already in scope + -- Make fresh names for the ones that are not already in scope -- This makes things work for family declarations - ; term <- addBinds freshNames $ - do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs) - ; m kbs } + ; term <- addBinds freshNames $ + do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs) + ; m kbs } ; wrapGenSyms freshNames term } where @@ -725,12 +728,18 @@ addTyClTyVarBinds tvs m -- Produce kinded binder constructors from the Haskell tyvar binders -- -repTyVarBndrWithKind :: LHsTyVarBndr Name +repTyVarBndrWithKind :: LHsTyVarBndr Name -> Core TH.Name -> DsM (Core TH.TyVarBndr) -repTyVarBndrWithKind (L _ (UserTyVar {})) nm +repTyVarBndrWithKind (L _ (HsTyVarBndr _ Nothing Nothing)) nm = repPlainTV nm -repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm +repTyVarBndrWithKind (L _ (HsTyVarBndr _ (Just ki) Nothing)) nm = repLKind ki >>= repKindedTV nm +repTyVarBndrWithKind (L _ (HsTyVarBndr _ Nothing (Just r))) nm + = repRole r >>= repRoledTV nm +repTyVarBndrWithKind (L _ (HsTyVarBndr _ (Just ki) (Just r))) nm + = do { ki' <- repLKind ki + ; r' <- repRole r + ; repKindedRoledTV nm ki' r' } -- represent a type context -- @@ -739,7 +748,7 @@ repLContext (L _ ctxt) = repContext ctxt repContext :: HsContext Name -> DsM (Core TH.CxtQ) repContext ctxt = do preds <- repList predQTyConName repLPred ctxt - repCtxt preds + repCtxt preds -- represent a type predicate -- @@ -780,41 +789,41 @@ repTy (HsForAllTy _ tvs ctxt ty) = repTy (HsTyVar n) | isTvOcc occ = do tv1 <- lookupOcc n - repTvar tv1 + repTvar tv1 | isDataOcc occ = do tc1 <- lookupOcc n repPromotedTyCon tc1 - | otherwise = do tc1 <- lookupOcc n - repNamedTyCon tc1 + | otherwise = do tc1 <- lookupOcc n + repNamedTyCon tc1 where occ = nameOccName n repTy (HsAppTy f a) = do - f1 <- repLTy f - a1 <- repLTy a - repTapp f1 a1 + f1 <- repLTy f + a1 <- repLTy a + repTapp f1 a1 repTy (HsFunTy f a) = do - f1 <- repLTy f - a1 <- repLTy a - tcon <- repArrowTyCon - repTapps tcon [f1, a1] -repTy (HsListTy t) = do - t1 <- repLTy t - tcon <- repListTyCon - repTapp tcon t1 + f1 <- repLTy f + a1 <- repLTy a + tcon <- repArrowTyCon + repTapps tcon [f1, a1] +repTy (HsListTy t) = do + t1 <- repLTy t + tcon <- repListTyCon + repTapp tcon t1 repTy (HsPArrTy t) = do - t1 <- repLTy t - tcon <- repTy (HsTyVar (tyConName parrTyCon)) - repTapp tcon t1 + t1 <- repLTy t + tcon <- repTy (HsTyVar (tyConName parrTyCon)) + repTapp tcon t1 repTy (HsTupleTy HsUnboxedTuple tys) = do - tys1 <- repLTys tys - tcon <- repUnboxedTupleTyCon (length tys) - repTapps tcon tys1 + tys1 <- repLTys tys + tcon <- repUnboxedTupleTyCon (length tys) + repTapps tcon tys1 repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys tcon <- repTupleTyCon (length tys) repTapps tcon tys1 repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) - `nlHsAppTy` ty2) -repTy (HsParTy t) = repLTy t + `nlHsAppTy` ty2) +repTy (HsParTy t) = repLTy t repTy (HsKindSig t k) = do t1 <- repLTy t k1 <- repLKind k @@ -830,7 +839,7 @@ repTy (HsExplicitTupleTy _ tys) = do repTy (HsTyLit lit) = do lit' <- repTyLit lit repTLit lit' -repTy ty = notHandled "Exotic form of type" (ppr ty) +repTy ty = notHandled "Exotic form of type" (ppr ty) repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ) repTyLit (HsNumTy i) = do dflags <- getDynFlags @@ -874,8 +883,13 @@ repNonArrowKind (HsTupleTy _ ks) = do { ks' <- mapM repLKind ks } repNonArrowKind k = notHandled "Exotic form of kind" (ppr k) +repRole :: Role -> DsM (Core TH.Role) +repRole Nominal = rep2 nominalName [] +repRole Representational = rep2 representationalName [] +repRole Phantom = rep2 phantomName [] + ----------------------------------------------------------------------------- --- Splices +-- Splices ----------------------------------------------------------------------------- repSplice :: HsSplice Name -> DsM (Core a) @@ -884,21 +898,21 @@ repSplice :: HsSplice Name -> DsM (Core a) repSplice (HsSplice n _) = do { mb_val <- dsLookupMetaEnv n ; case mb_val of - Just (Splice e) -> do { e' <- dsExpr e - ; return (MkC e') } - _ -> pprPanic "HsSplice" (ppr n) } - -- Should not happen; statically checked + Just (Splice e) -> do { e' <- dsExpr e + ; return (MkC e') } + _ -> pprPanic "HsSplice" (ppr n) } + -- Should not happen; statically checked ----------------------------------------------------------------------------- --- Expressions +-- Expressions ----------------------------------------------------------------------------- repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ]) repLEs es = repList expQTyConName repLE es -- FIXME: some of these panics should be converted into proper error messages --- unless we can make sure that constructs, which are plainly not --- supported in TH already lead to error messages at an earlier stage +-- unless we can make sure that constructs, which are plainly not +-- supported in TH already lead to error messages at an earlier stage repLE :: LHsExpr Name -> DsM (Core TH.ExpQ) repLE (L loc e) = putSrcSpanDs loc (repE e) @@ -906,15 +920,15 @@ repE :: HsExpr Name -> DsM (Core TH.ExpQ) repE (HsVar x) = do { mb_val <- dsLookupMetaEnv x ; case mb_val of - Nothing -> do { str <- globalVar x - ; repVarOrCon x str } - Just (Bound y) -> repVarOrCon x (coreVar y) - Just (Splice e) -> do { e' <- dsExpr e - ; return (MkC e') } } + Nothing -> do { str <- globalVar x + ; repVarOrCon x str } + Just (Bound y) -> repVarOrCon x (coreVar y) + Just (Splice e) -> do { e' <- dsExpr e + ; return (MkC e') } } repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e) - -- Remember, we're desugaring renamer output here, so - -- HsOverlit can definitely occur + -- Remember, we're desugaring renamer output here, so + -- HsOverlit can definitely occur repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a } repE (HsLit l) = do { a <- repLiteral l; repLit a } repE (HsLam (MG { mg_alts = [m] })) = repLambda m @@ -930,9 +944,9 @@ repE (OpApp e1 op _ e2) = the_op <- repLE op ; repInfixApp arg1 the_op arg2 } repE (NegApp x _) = do - a <- repLE x - negateVar <- lookupOcc negateName >>= repVar - negateVar `repApp` a + a <- repLE x + negateVar <- lookupOcc negateName >>= repVar + negateVar `repApp` a repE (HsPar x) = repLE x repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } @@ -942,18 +956,18 @@ repE (HsCase e (MG { mg_alts = ms })) ; core_ms2 <- coreList matchQTyConName ms2 ; repCaseE arg core_ms2 } repE (HsIf _ x y z) = do - a <- repLE x - b <- repLE y - c <- repLE z - repCond a b c + a <- repLE x + b <- repLE y + c <- repLE z + repCond a b c repE (HsMultiIf _ alts) = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts ; expr' <- repMultiIf (nonEmptyCoreList alts') ; wrapGenSyms (concat binds) expr' } repE (HsLet bs e) = do { (ss,ds) <- repBinds bs - ; e2 <- addBinds ss (repLE e) - ; z <- repLetE ds e2 - ; wrapGenSyms ss z } + ; e2 <- addBinds ss (repLE e) + ; z <- repLetE ds e2 + ; wrapGenSyms ss z } -- FIXME: I haven't got the types here right yet repE e@(HsDo ctxt sts _) @@ -991,18 +1005,18 @@ repE (ArithSeq _ _ aseq) = case aseq of From e -> do { ds1 <- repLE e; repFrom ds1 } FromThen e1 e2 -> do - ds1 <- repLE e1 - ds2 <- repLE e2 - repFromThen ds1 ds2 + ds1 <- repLE e1 + ds2 <- repLE e2 + repFromThen ds1 ds2 FromTo e1 e2 -> do - ds1 <- repLE e1 - ds2 <- repLE e2 - repFromTo ds1 ds2 + ds1 <- repLE e1 + ds2 <- repLE e2 + repFromTo ds1 ds2 FromThenTo e1 e2 e3 -> do - ds1 <- repLE e1 - ds2 <- repLE e2 - ds3 <- repLE e3 - repFromThenTo ds1 ds2 ds3 + ds1 <- repLE e1 + ds2 <- repLE e2 + ds3 <- repLE e3 + repFromThenTo ds1 ds2 ds3 repE (HsSpliceE splice) = repSplice splice repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e) @@ -1010,7 +1024,7 @@ repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e) repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e) repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e) repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e) -repE e = notHandled "Expression form" (ppr e) +repE e = notHandled "Expression form" (ppr e) ----------------------------------------------------------------------------- -- Building representations of auxillary structures like Match, Clause, Stmt, @@ -1122,41 +1136,41 @@ repSts other = notHandled "Exotic statement" (ppr other) ----------------------------------------------------------- --- Bindings +-- Bindings ----------------------------------------------------------- repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ]) repBinds EmptyLocalBinds - = do { core_list <- coreList decQTyConName [] - ; return ([], core_list) } + = do { core_list <- coreList decQTyConName [] + ; return ([], core_list) } repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b) repBinds (HsValBinds decs) - = do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs } - -- No need to worrry about detailed scopes within - -- the binding group, because we are talking Names - -- here, so we can safely treat it as a mutually - -- recursive group + = do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs } + -- No need to worrry about detailed scopes within + -- the binding group, because we are talking Names + -- here, so we can safely treat it as a mutually + -- recursive group -- For hsSigTvBinders see Note [Scoped type variables in bindings] - ; ss <- mkGenSyms bndrs - ; prs <- addBinds ss (rep_val_binds decs) - ; core_list <- coreList decQTyConName - (de_loc (sort_by_loc prs)) - ; return (ss, core_list) } + ; ss <- mkGenSyms bndrs + ; prs <- addBinds ss (rep_val_binds decs) + ; core_list <- coreList decQTyConName + (de_loc (sort_by_loc prs)) + ; return (ss, core_list) } rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] -- Assumes: all the binders of the binding are alrady in the meta-env rep_val_binds (ValBindsOut binds sigs) = do { core1 <- rep_binds' (unionManyBags (map snd binds)) - ; core2 <- rep_sigs' sigs - ; return (core1 ++ core2) } + ; core2 <- rep_sigs' sigs + ; return (core1 ++ core2) } rep_val_binds (ValBindsIn _ _) = panic "rep_val_binds: ValBindsIn" rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ] rep_binds binds = do { binds_w_locs <- rep_binds' binds - ; return (de_loc (sort_by_loc binds_w_locs)) } + ; return (de_loc (sort_by_loc binds_w_locs)) } rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] rep_binds' binds = mapM rep_bind (bagToList binds) @@ -1168,35 +1182,35 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match -- with an empty list of patterns rep_bind (L loc (FunBind { fun_id = fn, - fun_matches = MG { mg_alts = [L _ (Match [] _ (GRHSs guards wheres))] } })) + fun_matches = MG { mg_alts = [L _ (Match [] _ (GRHSs guards wheres))] } })) = do { (ss,wherecore) <- repBinds wheres - ; guardcore <- addBinds ss (repGuards guards) - ; fn' <- lookupLBinder fn - ; p <- repPvar fn' - ; ans <- repVal p guardcore wherecore - ; ans' <- wrapGenSyms ss ans - ; return (loc, ans') } + ; guardcore <- addBinds ss (repGuards guards) + ; fn' <- lookupLBinder fn + ; p <- repPvar fn' + ; ans <- repVal p guardcore wherecore + ; ans' <- wrapGenSyms ss ans + ; return (loc, ans') } rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts = ms } })) = do { ms1 <- mapM repClauseTup ms - ; fn' <- lookupLBinder fn + ; fn' <- lookupLBinder fn ; ans <- repFun fn' (nonEmptyCoreList ms1) ; return (loc, ans) } rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres })) = do { patcore <- repLP pat ; (ss,wherecore) <- repBinds wheres - ; guardcore <- addBinds ss (repGuards guards) + ; guardcore <- addBinds ss (repGuards guards) ; ans <- repVal patcore guardcore wherecore - ; ans' <- wrapGenSyms ss ans + ; ans' <- wrapGenSyms ss ans ; return (loc, ans') } rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) = do { v' <- lookupBinder v - ; e2 <- repLE e + ; e2 <- repLE e ; x <- repNormal e2 ; patcore <- repPvar v' - ; empty_decls <- coreList decQTyConName [] + ; empty_decls <- coreList decQTyConName [] ; ans <- repVal patcore x empty_decls ; return (srcLocSpan (getSrcLoc v), ans) } @@ -1231,14 +1245,14 @@ repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( - do { xs <- repLPs ps; body <- repLE e; repLam xs body }) + do { xs <- repLPs ps; body <- repLE e; repLam xs body }) ; wrapGenSyms ss lam } repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m) ----------------------------------------------------------------------------- --- Patterns +-- Patterns -- repP deals with patterns. It assumes that we have already -- walked over the pattern(s) once to collect the binders, and -- have extended the environment. So every pattern-bound @@ -1278,17 +1292,17 @@ repP (ConPatIn dc details) rep_fld fld = do { MkC v <- lookupLOcc (hsRecFieldId fld) ; MkC p <- repLP (hsRecFieldArg fld) ; rep2 fieldPatName [v,p] } - + repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a } repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p) - -- The problem is to do with scoped type variables. - -- To implement them, we have to implement the scoping rules - -- here in DsMeta, and I don't want to do that today! - -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' } - -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ) - -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t] + -- The problem is to do with scoped type variables. + -- To implement them, we have to implement the scoping rules + -- here in DsMeta, and I don't want to do that today! + -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' } + -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ) + -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t] repP other = notHandled "Exotic pattern" (ppr other) @@ -1303,20 +1317,20 @@ de_loc :: [(a, b)] -> [b] de_loc = map snd ---------------------------------------------------------- --- The meta-environment +-- The meta-environment -- A name/identifier association for fresh names of locally bound entities -type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id - -- I.e. (x, x_id) means - -- let x_id = gensym "x" in ... +type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id + -- I.e. (x, x_id) means + -- let x_id = gensym "x" in ... -- Generate a fresh name for a locally bound entity mkGenSyms :: [Name] -> DsM [GenSymBind] -- We can use the existing name. For example: --- [| \x_77 -> x_77 + x_77 |] +-- [| \x_77 -> x_77 + x_77 |] -- desugars to --- do { x_77 <- genSym "x"; .... } +-- do { x_77 <- genSym "x"; .... } -- We use the same x_77 in the desugared program, but with the type Bndr -- instead of Int -- @@ -1324,7 +1338,7 @@ mkGenSyms :: [Name] -> DsM [GenSymBind] -- -- Nevertheless, it's monadic because we have to generate nameTy mkGenSyms ns = do { var_ty <- lookupType nameTyConName - ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] } + ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] } addBinds :: [GenSymBind] -> DsM a -> DsM a @@ -1366,73 +1380,73 @@ lookupOcc :: Name -> DsM (Core TH.Name) lookupOcc n = do { mb_val <- dsLookupMetaEnv n ; case mb_val of - Nothing -> globalVar n - Just (Bound x) -> return (coreVar x) - Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n) + Nothing -> globalVar n + Just (Bound x) -> return (coreVar x) + Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n) } globalVar :: Name -> DsM (Core TH.Name) -- Not bound by the meta-env -- Could be top-level; or could be local --- f x = $(g [| x |]) +-- f x = $(g [| x |]) -- Here the x will be local globalVar name | isExternalName name - = do { MkC mod <- coreStringLit name_mod + = do { MkC mod <- coreStringLit name_mod ; MkC pkg <- coreStringLit name_pkg - ; MkC occ <- occNameLit name - ; rep2 mk_varg [pkg,mod,occ] } + ; MkC occ <- occNameLit name + ; rep2 mk_varg [pkg,mod,occ] } | otherwise - = do { MkC occ <- occNameLit name - ; MkC uni <- coreIntLit (getKey (getUnique name)) - ; rep2 mkNameLName [occ,uni] } + = do { MkC occ <- occNameLit name + ; MkC uni <- coreIntLit (getKey (getUnique name)) + ; rep2 mkNameLName [occ,uni] } where mod = ASSERT( isExternalName name) nameModule name name_mod = moduleNameString (moduleName mod) name_pkg = packageIdString (modulePackageId mod) name_occ = nameOccName name mk_varg | OccName.isDataOcc name_occ = mkNameG_dName - | OccName.isVarOcc name_occ = mkNameG_vName - | OccName.isTcOcc name_occ = mkNameG_tcName - | otherwise = pprPanic "DsMeta.globalVar" (ppr name) + | OccName.isVarOcc name_occ = mkNameG_vName + | OccName.isTcOcc name_occ = mkNameG_tcName + | otherwise = pprPanic "DsMeta.globalVar" (ppr name) -lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ) - -> DsM Type -- The type +lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ) + -> DsM Type -- The type lookupType tc_name = do { tc <- dsLookupTyCon tc_name ; - return (mkTyConApp tc []) } + return (mkTyConApp tc []) } wrapGenSyms :: [GenSymBind] - -> Core (TH.Q a) -> DsM (Core (TH.Q a)) + -> Core (TH.Q a) -> DsM (Core (TH.Q a)) -- wrapGenSyms [(nm1,id1), (nm2,id2)] y --- --> bindQ (gensym nm1) (\ id1 -> --- bindQ (gensym nm2 (\ id2 -> --- y)) +-- --> bindQ (gensym nm1) (\ id1 -> +-- bindQ (gensym nm2 (\ id2 -> +-- y)) wrapGenSyms binds body@(MkC b) = do { var_ty <- lookupType nameTyConName - ; go var_ty binds } + ; go var_ty binds } where [elt_ty] = tcTyConAppArgs (exprType b) - -- b :: Q a, so we can get the type 'a' by looking at the - -- argument type. NB: this relies on Q being a data/newtype, - -- not a type synonym + -- b :: Q a, so we can get the type 'a' by looking at the + -- argument type. NB: this relies on Q being a data/newtype, + -- not a type synonym go _ [] = return body go var_ty ((name,id) : binds) = do { MkC body' <- go var_ty binds - ; lit_str <- occNameLit name - ; gensym_app <- repGensym lit_str - ; repBindQ var_ty elt_ty - gensym_app (MkC (Lam id body')) } + ; lit_str <- occNameLit name + ; gensym_app <- repGensym lit_str + ; repBindQ var_ty elt_ty + gensym_app (MkC (Lam id body')) } occNameLit :: Name -> DsM (Core String) occNameLit n = coreStringLit (occNameString (nameOccName n)) -- %********************************************************************* --- %* * --- Constructing code --- %* * +-- %* * +-- Constructing code +-- %* * -- %********************************************************************* ----------------------------------------------------------------------------- @@ -1459,9 +1473,9 @@ dataCon n = dataCon' n [] -- %********************************************************************* --- %* * --- The 'smart constructors' --- %* * +-- %* * +-- The 'smart constructors' +-- %* * -- %********************************************************************* --------------- Patterns ----------------- @@ -1507,7 +1521,7 @@ repPview (MkC e) (MkC p) = rep2 viewPName [e,p] --------------- Expressions ----------------- repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ) repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str - | otherwise = repVar str + | otherwise = repVar str repVar :: Core TH.Name -> DsM (Core TH.ExpQ) repVar (MkC s) = rep2 varEName [s] @@ -1695,9 +1709,24 @@ repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki) = rep2 familyKindDName [flav, nm, tvs, ki] -repTySynInst :: Core TH.Name -> Core [TH.TySynEqnQ] -> DsM (Core TH.DecQ) -repTySynInst (MkC nm) (MkC eqns) - = rep2 tySynInstDName [nm, eqns] +repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ) +repTySynInst (MkC nm) (MkC eqn) + = rep2 tySynInstDName [nm, eqn] + +repClosedFamilyNoKind :: Core TH.Name + -> Core [TH.TyVarBndr] + -> Core [TH.TySynEqnQ] + -> DsM (Core TH.DecQ) +repClosedFamilyNoKind (MkC nm) (MkC tvs) (MkC eqns) + = rep2 closedTypeFamilyNoKindDName [nm, tvs, eqns] + +repClosedFamilyKind :: Core TH.Name + -> Core [TH.TyVarBndr] + -> Core TH.Kind + -> Core [TH.TySynEqnQ] + -> DsM (Core TH.DecQ) +repClosedFamilyKind (MkC nm) (MkC tvs) (MkC ki) (MkC eqns) + = rep2 closedTypeFamilyKindDName [nm, tvs, ki, eqns] repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ) repTySynEqn (MkC lhs) (MkC rhs) @@ -1809,6 +1838,13 @@ repPlainTV (MkC nm) = rep2 plainTVName [nm] repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr) repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki] +repRoledTV :: Core TH.Name -> Core TH.Role -> DsM (Core TH.TyVarBndr) +repRoledTV (MkC nm) (MkC r) = rep2 roledTVName [nm, r] + +repKindedRoledTV :: Core TH.Name -> Core TH.Kind -> Core TH.Role + -> DsM (Core TH.TyVarBndr) +repKindedRoledTV (MkC nm) (MkC k) (MkC r) = rep2 kindedRoledTVName [nm, k, r] + repKVar :: Core TH.Name -> DsM (Core TH.Kind) repKVar (MkC s) = rep2 varKName [s] @@ -1839,7 +1875,7 @@ repKConstraint :: DsM (Core TH.Kind) repKConstraint = rep2 constraintKName [] ---------------------------------------------------------- --- Literals +-- Literals repLiteral :: HsLit -> DsM (Core TH.Lit) repLiteral lit @@ -1852,20 +1888,20 @@ repLiteral lit _ -> return lit lit_expr <- dsLit lit' case mb_lit_name of - Just lit_name -> rep2 lit_name [lit_expr] - Nothing -> notHandled "Exotic literal" (ppr lit) + Just lit_name -> rep2 lit_name [lit_expr] + Nothing -> notHandled "Exotic literal" (ppr lit) where mb_lit_name = case lit of - HsInteger _ _ -> Just integerLName - HsInt _ -> Just integerLName - HsIntPrim _ -> Just intPrimLName - HsWordPrim _ -> Just wordPrimLName - HsFloatPrim _ -> Just floatPrimLName - HsDoublePrim _ -> Just doublePrimLName - HsChar _ -> Just charLName - HsString _ -> Just stringLName - HsRat _ _ -> Just rationalLName - _ -> Nothing + HsInteger _ _ -> Just integerLName + HsInt _ -> Just integerLName + HsIntPrim _ -> Just intPrimLName + HsWordPrim _ -> Just wordPrimLName + HsFloatPrim _ -> Just floatPrimLName + HsDoublePrim _ -> Just doublePrimLName + HsChar _ -> Just charLName + HsString _ -> Just stringLName + HsRat _ _ -> Just rationalLName + _ -> Nothing mk_integer :: Integer -> DsM HsLit mk_integer i = do integer_ty <- lookupType integerTyConName @@ -1879,9 +1915,9 @@ mk_string s = return $ HsString s repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit) repOverloadedLiteral (OverLit { ol_val = val}) = do { lit <- mk_lit val; repLiteral lit } - -- The type Rational will be in the environment, because - -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, - -- and rationalL is sucked in when any TH stuff is used + -- The type Rational will be in the environment, because + -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, + -- and rationalL is sucked in when any TH stuff is used mk_lit :: OverLitVal -> DsM HsLit mk_lit (HsIntegral i) = mk_integer i @@ -1893,8 +1929,8 @@ mk_lit (HsIsString s) = mk_string s repGensym :: Core String -> DsM (Core (TH.Q TH.Name)) repGensym (MkC lit_str) = rep2 newNameName [lit_str] -repBindQ :: Type -> Type -- a and b - -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b)) +repBindQ :: Type -> Type -- a and b + -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b)) repBindQ ty_a ty_b (MkC x) (MkC y) = rep2 bindQName [Type ty_a, Type ty_b, x, y] @@ -1905,25 +1941,25 @@ repSequenceQ ty_a (MkC list) ------------ Lists and Tuples ------------------- -- turn a list of patterns into a single pattern matching a list -repList :: Name -> (a -> DsM (Core b)) +repList :: Name -> (a -> DsM (Core b)) -> [a] -> DsM (Core [b]) repList tc_name f args = do { args1 <- mapM f args ; coreList tc_name args1 } -coreList :: Name -- Of the TyCon of the element type - -> [Core a] -> DsM (Core [a]) +coreList :: Name -- Of the TyCon of the element type + -> [Core a] -> DsM (Core [a]) coreList tc_name es = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) } -coreList' :: Type -- The element type - -> [Core a] -> Core [a] +coreList' :: Type -- The element type + -> [Core a] -> Core [a] coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es )) nonEmptyCoreList :: [Core a] -> Core [a] -- The list must be non-empty so we can get the element type -- Otherwise use coreList -nonEmptyCoreList [] = panic "coreList: empty argument" +nonEmptyCoreList [] = panic "coreList: empty argument" nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) coreStringLit :: String -> DsM (Core String) @@ -1935,7 +1971,7 @@ coreIntLit :: Int -> DsM (Core Int) coreIntLit i = do dflags <- getDynFlags return (MkC (mkIntExprInt dflags i)) -coreVar :: Id -> Core TH.Name -- The Id has type Name +coreVar :: Id -> Core TH.Name -- The Id has type Name coreVar id = MkC (Var id) ----------------- Failure ----------------------- @@ -1943,13 +1979,13 @@ notHandled :: String -> SDoc -> DsM a notHandled what doc = failWithDs msg where msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell")) - 2 doc + 2 doc -- %************************************************************************ --- %* * --- The known-key names for Template Haskell --- %* * +-- %* * +-- The known-key names for Template Haskell +-- %* * -- %************************************************************************ -- To add a name, do three things @@ -2001,7 +2037,8 @@ templateHaskellNames = [ pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName, - tySynInstDName, infixLDName, infixRDName, infixNDName, + tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName, + infixLDName, infixRDName, infixNDName, -- Cxt cxtName, -- Pred @@ -2021,7 +2058,9 @@ templateHaskellNames = [ -- TyLit numTyLitName, strTyLitName, -- TyVarBndr - plainTVName, kindedTVName, + plainTVName, kindedTVName, roledTVName, kindedRoledTVName, + -- Role + nominalName, representationalName, phantomName, -- Kind varKName, conKName, tupleKName, arrowKName, listKName, appKName, starKName, constraintKName, @@ -2214,6 +2253,7 @@ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName, + closedTypeFamilyKindDName, closedTypeFamilyNoKindDName, infixLDName, infixRDName, infixNDName :: Name funDName = libFun (fsLit "funD") funDIdKey valDName = libFun (fsLit "valD") valDIdKey @@ -2234,6 +2274,10 @@ familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey +closedTypeFamilyKindDName + = libFun (fsLit "closedTypeFamilyKindD") closedTypeFamilyKindDIdKey +closedTypeFamilyNoKindDName + = libFun (fsLit "closedTypeFamilyNoKindD") closedTypeFamilyNoKindDIdKey infixLDName = libFun (fsLit "infixLD") infixLDIdKey infixRDName = libFun (fsLit "infixRD") infixRDIdKey infixNDName = libFun (fsLit "infixND") infixNDIdKey @@ -2294,9 +2338,17 @@ numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey -- data TyVarBndr = ... -plainTVName, kindedTVName :: Name -plainTVName = libFun (fsLit "plainTV") plainTVIdKey -kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey +plainTVName, kindedTVName, roledTVName, kindedRoledTVName :: Name +plainTVName = libFun (fsLit "plainTV") plainTVIdKey +kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey +roledTVName = libFun (fsLit "roledTV") roledTVIdKey +kindedRoledTVName = libFun (fsLit "kindedRoledTV") kindedRoledTVIdKey + +-- data Role = ... +nominalName, representationalName, phantomName :: Name +nominalName = libFun (fsLit "nominal") nominalIdKey +representationalName = libFun (fsLit "representational") representationalIdKey +phantomName = libFun (fsLit "phantom") phantomIdKey -- data Kind = ... varKName, conKName, tupleKName, arrowKName, listKName, appKName, @@ -2380,10 +2432,10 @@ tySynEqnQTyConName = libTc (fsLit "TySynEqnQ") tySynEqnQTyConKey -- quasiquoting quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name -quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey -quotePatName = qqFun (fsLit "quotePat") quotePatKey -quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey -quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey +quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey +quotePatName = qqFun (fsLit "quotePat") quotePatKey +quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey +quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey -- TyConUniques available: 200-299 -- Check in PrelNames if you want to change this @@ -2550,29 +2602,32 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey, familyNoKindDIdKey, familyKindDIdKey, dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, + closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey, infixLDIdKey, infixRDIdKey, infixNDIdKey :: Unique -funDIdKey = mkPreludeMiscIdUnique 330 -valDIdKey = mkPreludeMiscIdUnique 331 -dataDIdKey = mkPreludeMiscIdUnique 332 -newtypeDIdKey = mkPreludeMiscIdUnique 333 -tySynDIdKey = mkPreludeMiscIdUnique 334 -classDIdKey = mkPreludeMiscIdUnique 335 -instanceDIdKey = mkPreludeMiscIdUnique 336 -sigDIdKey = mkPreludeMiscIdUnique 337 -forImpDIdKey = mkPreludeMiscIdUnique 338 -pragInlDIdKey = mkPreludeMiscIdUnique 339 -pragSpecDIdKey = mkPreludeMiscIdUnique 340 -pragSpecInlDIdKey = mkPreludeMiscIdUnique 341 -pragSpecInstDIdKey = mkPreludeMiscIdUnique 412 -pragRuleDIdKey = mkPreludeMiscIdUnique 413 -familyNoKindDIdKey = mkPreludeMiscIdUnique 342 -familyKindDIdKey = mkPreludeMiscIdUnique 343 -dataInstDIdKey = mkPreludeMiscIdUnique 344 -newtypeInstDIdKey = mkPreludeMiscIdUnique 345 -tySynInstDIdKey = mkPreludeMiscIdUnique 346 -infixLDIdKey = mkPreludeMiscIdUnique 347 -infixRDIdKey = mkPreludeMiscIdUnique 348 -infixNDIdKey = mkPreludeMiscIdUnique 349 +funDIdKey = mkPreludeMiscIdUnique 330 +valDIdKey = mkPreludeMiscIdUnique 331 +dataDIdKey = mkPreludeMiscIdUnique 332 +newtypeDIdKey = mkPreludeMiscIdUnique 333 +tySynDIdKey = mkPreludeMiscIdUnique 334 +classDIdKey = mkPreludeMiscIdUnique 335 +instanceDIdKey = mkPreludeMiscIdUnique 336 +sigDIdKey = mkPreludeMiscIdUnique 337 +forImpDIdKey = mkPreludeMiscIdUnique 338 +pragInlDIdKey = mkPreludeMiscIdUnique 339 +pragSpecDIdKey = mkPreludeMiscIdUnique 340 +pragSpecInlDIdKey = mkPreludeMiscIdUnique 341 +pragSpecInstDIdKey = mkPreludeMiscIdUnique 416 +pragRuleDIdKey = mkPreludeMiscIdUnique 417 +familyNoKindDIdKey = mkPreludeMiscIdUnique 342 +familyKindDIdKey = mkPreludeMiscIdUnique 343 +dataInstDIdKey = mkPreludeMiscIdUnique 344 +newtypeInstDIdKey = mkPreludeMiscIdUnique 345 +tySynInstDIdKey = mkPreludeMiscIdUnique 346 +closedTypeFamilyKindDIdKey = mkPreludeMiscIdUnique 347 +closedTypeFamilyNoKindDIdKey = mkPreludeMiscIdUnique 348 +infixLDIdKey = mkPreludeMiscIdUnique 349 +infixRDIdKey = mkPreludeMiscIdUnique 350 +infixNDIdKey = mkPreludeMiscIdUnique 351 -- type Cxt = ... cxtIdKey :: Unique @@ -2630,32 +2685,40 @@ numTyLitIdKey = mkPreludeMiscIdUnique 394 strTyLitIdKey = mkPreludeMiscIdUnique 395 -- data TyVarBndr = ... -plainTVIdKey, kindedTVIdKey :: Unique -plainTVIdKey = mkPreludeMiscIdUnique 396 -kindedTVIdKey = mkPreludeMiscIdUnique 397 +plainTVIdKey, kindedTVIdKey, roledTVIdKey, kindedRoledTVIdKey :: Unique +plainTVIdKey = mkPreludeMiscIdUnique 396 +kindedTVIdKey = mkPreludeMiscIdUnique 397 +roledTVIdKey = mkPreludeMiscIdUnique 398 +kindedRoledTVIdKey = mkPreludeMiscIdUnique 399 + +-- data Role = ... +nominalIdKey, representationalIdKey, phantomIdKey :: Unique +nominalIdKey = mkPreludeMiscIdUnique 400 +representationalIdKey = mkPreludeMiscIdUnique 401 +phantomIdKey = mkPreludeMiscIdUnique 402 -- data Kind = ... varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey, starKIdKey, constraintKIdKey :: Unique -varKIdKey = mkPreludeMiscIdUnique 398 -conKIdKey = mkPreludeMiscIdUnique 399 -tupleKIdKey = mkPreludeMiscIdUnique 400 -arrowKIdKey = mkPreludeMiscIdUnique 401 -listKIdKey = mkPreludeMiscIdUnique 402 -appKIdKey = mkPreludeMiscIdUnique 403 -starKIdKey = mkPreludeMiscIdUnique 404 -constraintKIdKey = mkPreludeMiscIdUnique 405 +varKIdKey = mkPreludeMiscIdUnique 403 +conKIdKey = mkPreludeMiscIdUnique 404 +tupleKIdKey = mkPreludeMiscIdUnique 405 +arrowKIdKey = mkPreludeMiscIdUnique 406 +listKIdKey = mkPreludeMiscIdUnique 407 +appKIdKey = mkPreludeMiscIdUnique 408 +starKIdKey = mkPreludeMiscIdUnique 409 +constraintKIdKey = mkPreludeMiscIdUnique 410 -- data Callconv = ... cCallIdKey, stdCallIdKey :: Unique -cCallIdKey = mkPreludeMiscIdUnique 406 -stdCallIdKey = mkPreludeMiscIdUnique 407 +cCallIdKey = mkPreludeMiscIdUnique 411 +stdCallIdKey = mkPreludeMiscIdUnique 412 -- data Safety = ... unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique -unsafeIdKey = mkPreludeMiscIdUnique 408 -safeIdKey = mkPreludeMiscIdUnique 409 -interruptibleIdKey = mkPreludeMiscIdUnique 411 +unsafeIdKey = mkPreludeMiscIdUnique 413 +safeIdKey = mkPreludeMiscIdUnique 414 +interruptibleIdKey = mkPreludeMiscIdUnique 415 -- data Inline = ... noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique @@ -2676,25 +2739,25 @@ beforePhaseDataConKey = mkPreludeDataConUnique 47 -- data FunDep = ... funDepIdKey :: Unique -funDepIdKey = mkPreludeMiscIdUnique 414 +funDepIdKey = mkPreludeMiscIdUnique 418 -- data FamFlavour = ... typeFamIdKey, dataFamIdKey :: Unique -typeFamIdKey = mkPreludeMiscIdUnique 415 -dataFamIdKey = mkPreludeMiscIdUnique 416 +typeFamIdKey = mkPreludeMiscIdUnique 419 +dataFamIdKey = mkPreludeMiscIdUnique 420 -- data TySynEqn = ... tySynEqnIdKey :: Unique -tySynEqnIdKey = mkPreludeMiscIdUnique 417 +tySynEqnIdKey = mkPreludeMiscIdUnique 421 -- quasiquoting quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique -quoteExpKey = mkPreludeMiscIdUnique 418 -quotePatKey = mkPreludeMiscIdUnique 419 -quoteDecKey = mkPreludeMiscIdUnique 420 -quoteTypeKey = mkPreludeMiscIdUnique 421 +quoteExpKey = mkPreludeMiscIdUnique 422 +quotePatKey = mkPreludeMiscIdUnique 423 +quoteDecKey = mkPreludeMiscIdUnique 424 +quoteTypeKey = mkPreludeMiscIdUnique 425 -- data RuleBndr = ... ruleVarIdKey, typedRuleVarIdKey :: Unique -ruleVarIdKey = mkPreludeMiscIdUnique 422 -typedRuleVarIdKey = mkPreludeMiscIdUnique 423 +ruleVarIdKey = mkPreludeMiscIdUnique 426 +typedRuleVarIdKey = mkPreludeMiscIdUnique 427 diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 43a3af7a4c..fe28e01f3c 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -6,13 +6,6 @@ The @match@ function \begin{code} -{-# 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 Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where #include "HsVersions.h" @@ -20,7 +13,7 @@ module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat import {-#SOURCE#-} DsExpr (dsLExpr, dsExpr) import DynFlags -import HsSyn +import HsSyn import TcHsSyn import TcEvidence import TcRnMonad @@ -52,7 +45,7 @@ import Control.Monad( when ) import qualified Data.Map as Map \end{code} -This function is a wrapper of @match@, it must be called from all the parts where +This function is a wrapper of @match@, it must be called from all the parts where it was called match, but only substitutes the first call, .... if the associated flags are declared, warnings will be issued. It can not be called matchWrapper because this name already exists :-( @@ -61,7 +54,7 @@ JJCQ 30-Nov-1997 \begin{code} matchCheck :: DsMatchContext - -> [Id] -- Vars rep'ing the exprs we're matching with + -> [Id] -- Vars rep'ing the exprs we're matching with -> Type -- Type of the case expression -> [EquationInfo] -- Info about patterns, etc. (type synonym below) -> DsM MatchResult -- Desugared result! @@ -80,11 +73,11 @@ matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs = do { when shadow (dsShadowWarn ctx eqns_shadow) ; when incomplete (dsIncompleteWarn ctx pats) ; match vars ty qs } - where + where (pats, eqns_shadow) = check qs incomplete = incomplete_flag hs_ctx && (notNull pats) shadow = wopt Opt_WarnOverlappingPatterns dflags - && notNull eqns_shadow + && notNull eqns_shadow incomplete_flag :: HsMatchContext id -> Bool incomplete_flag (FunRhs {}) = wopt Opt_WarnIncompletePatterns dflags @@ -99,9 +92,9 @@ matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs incomplete_flag ThPatQuote = False incomplete_flag (StmtCtxt {}) = False -- Don't warn about incomplete patterns - -- in list comprehensions, pattern guards - -- etc. They are often *supposed* to be - -- incomplete + -- in list comprehensions, pattern guards + -- etc. They are often *supposed* to be + -- incomplete \end{code} This variable shows the maximum number of lines of output generated for warnings. @@ -123,34 +116,34 @@ dsShadowWarn ctx@(DsMatchContext kind loc) qs where warn | qs `lengthExceeds` maximum_output = pp_context ctx (ptext (sLit "are overlapped")) - (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ - ptext (sLit "...")) - | otherwise + (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$ + ptext (sLit "...")) + | otherwise = pp_context ctx (ptext (sLit "are overlapped")) - (\ f -> vcat $ map (ppr_eqn f kind) qs) + (\ f -> vcat $ map (ppr_eqn f kind) qs) dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM () -dsIncompleteWarn ctx@(DsMatchContext kind loc) pats +dsIncompleteWarn ctx@(DsMatchContext kind loc) pats = putSrcSpanDs loc (warnDs warn) - where - warn = pp_context ctx (ptext (sLit "are non-exhaustive")) + where + warn = pp_context ctx (ptext (sLit "are non-exhaustive")) (\_ -> hang (ptext (sLit "Patterns not matched:")) - 4 ((vcat $ map (ppr_incomplete_pats kind) - (take maximum_output pats)) - $$ dots)) + 4 ((vcat $ map (ppr_incomplete_pats kind) + (take maximum_output pats)) + $$ dots)) - dots | pats `lengthExceeds` maximum_output = ptext (sLit "...") - | otherwise = empty + dots | pats `lengthExceeds` maximum_output = ptext (sLit "...") + | otherwise = empty pp_context :: DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun = vcat [ptext (sLit "Pattern match(es)") <+> msg, - sep [ptext (sLit "In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]] + sep [ptext (sLit "In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]] where (ppr_match, pref) - = case kind of - FunRhs fun _ -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) + = case kind of + FunRhs fun _ -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) _ -> (pprMatchContext kind, \ pp -> pp) ppr_pats :: Outputable a => [a] -> SDoc @@ -163,8 +156,8 @@ ppr_shadow_pats kind pats ppr_incomplete_pats :: HsMatchContext Name -> ExhaustivePat -> SDoc ppr_incomplete_pats _ (pats,[]) = ppr_pats pats ppr_incomplete_pats _ (pats,constraints) = - sep [ppr_pats pats, ptext (sLit "with"), - sep (map ppr_constraint constraints)] + sep [ppr_pats pats, ptext (sLit "with"), + sep (map ppr_constraint constraints)] ppr_constraint :: (Name,[HsLit]) -> SDoc ppr_constraint (var,pats) = sep [ppr var, ptext (sLit "`notElem`"), ppr pats] @@ -175,9 +168,9 @@ ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn)) %************************************************************************ -%* * - The main matching function -%* * +%* * + The main matching function +%* * %************************************************************************ The function @match@ is basically the same as in the Wadler chapter, @@ -278,34 +271,34 @@ Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@ corresponds roughly to @matchVarCon@. \begin{code} -match :: [Id] -- Variables rep\'ing the exprs we\'re matching with +match :: [Id] -- Variables rep\'ing the exprs we\'re matching with -> Type -- Type of the case expression - -> [EquationInfo] -- Info about patterns, etc. (type synonym below) + -> [EquationInfo] -- Info about patterns, etc. (type synonym below) -> DsM MatchResult -- Desugared result! match [] ty eqns = ASSERT2( not (null eqns), ppr ty ) return (foldr1 combineMatchResults match_results) where - match_results = [ ASSERT( null (eqn_pats eqn) ) - eqn_rhs eqn - | eqn <- eqns ] + match_results = [ ASSERT( null (eqn_pats eqn) ) + eqn_rhs eqn + | eqn <- eqns ] match vars@(v:_) ty eqns -- Eqns *can* be empty - = do { dflags <- getDynFlags - ; -- Tidy the first pattern, generating - -- auxiliary bindings if necessary + = do { dflags <- getDynFlags + ; -- Tidy the first pattern, generating + -- auxiliary bindings if necessary (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns - -- Group the equations and match each group in turn + -- Group the equations and match each group in turn ; let grouped = groupEquations dflags tidy_eqns -- print the view patterns that are commoned up to help debug ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped) - ; match_results <- match_groups grouped - ; return (adjustMatchResult (foldr (.) id aux_binds) $ - foldr1 combineMatchResults match_results) } + ; match_results <- match_groups grouped + ; return (adjustMatchResult (foldr (.) id aux_binds) $ + foldr1 combineMatchResults match_results) } where dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo] dropGroup = map snd @@ -328,19 +321,19 @@ match vars@(v:_) ty eqns -- Eqns *can* be empty PgCo _ -> matchCoercion vars ty (dropGroup eqns) PgView _ _ -> matchView vars ty (dropGroup eqns) PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns) - + -- FIXME: we should also warn about view patterns that should be -- commoned up but are not -- print some stuff to see what's getting grouped -- use -dppr-debug to see the resolution of overloaded literals - debug eqns = - let gs = map (\group -> foldr (\ (p,_) -> \acc -> - case p of PgView e _ -> e:acc + debug eqns = + let gs = map (\group -> foldr (\ (p,_) -> \acc -> + case p of PgView e _ -> e:acc _ -> acc) [] group) eqns maybeWarn [] = return () maybeWarn l = warnDs (vcat l) - in + in maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g)) (filter (not . null) gs)) @@ -349,7 +342,7 @@ matchEmpty :: Id -> Type -> DsM [MatchResult] matchEmpty var res_ty = return [MatchResult CanFail mk_seq] where - mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty + mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty [(DEFAULT, [], fail)] matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult @@ -360,45 +353,45 @@ matchVariables [] _ _ = panic "matchVariables" matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult matchBangs (var:vars) ty eqns - = do { match_result <- match (var:vars) ty $ + = do { match_result <- match (var:vars) ty $ map (decomposeFirstPat getBangPat) eqns - ; return (mkEvalMatchResult var ty match_result) } + ; return (mkEvalMatchResult var ty match_result) } matchBangs [] _ _ = panic "matchBangs" matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- Apply the coercion to the match variable and then match that matchCoercion (var:vars) ty (eqns@(eqn1:_)) - = do { let CoPat co pat _ = firstPat eqn1 - ; var' <- newUniqueId var (hsPatType pat) - ; match_result <- match (var':vars) ty $ + = do { let CoPat co pat _ = firstPat eqn1 + ; var' <- newUniqueId var (hsPatType pat) + ; match_result <- match (var':vars) ty $ map (decomposeFirstPat getCoPat) eqns ; rhs' <- dsHsWrapper co (Var var) - ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) } + ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) } matchCoercion _ _ _ = panic "matchCoercion" matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- Apply the view function to the match variable and then match that matchView (var:vars) ty (eqns@(eqn1:_)) - = do { -- we could pass in the expr from the PgView, - -- but this needs to extract the pat anyway + = do { -- we could pass in the expr from the PgView, + -- but this needs to extract the pat anyway -- to figure out the type of the fresh variable let ViewPat viewExpr (L _ pat) _ = firstPat eqn1 - -- do the rest of the compilation - ; var' <- newUniqueId var (hsPatType pat) - ; match_result <- match (var':vars) ty $ + -- do the rest of the compilation + ; var' <- newUniqueId var (hsPatType pat) + ; match_result <- match (var':vars) ty $ map (decomposeFirstPat getViewPat) eqns -- compile the view expressions ; viewExpr' <- dsLExpr viewExpr - ; return (mkViewMatchResult var' viewExpr' var match_result) } + ; return (mkViewMatchResult var' viewExpr' var match_result) } matchView _ _ _ = panic "matchView" matchOverloadedList :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult matchOverloadedList (var:vars) ty (eqns@(eqn1:_)) --- Since overloaded list patterns are treated as view patterns, +-- Since overloaded list patterns are treated as view patterns, -- the code is roughly the same as for matchView - = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1 + = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1 ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand - ; match_result <- match (var':vars) ty $ + ; match_result <- match (var':vars) ty $ map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern ; e' <- dsExpr e ; return (mkViewMatchResult var' e' var match_result) } @@ -407,7 +400,7 @@ matchOverloadedList _ _ _ = panic "matchOverloadedList" -- decompose the first pattern and leave the rest alone decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) - = eqn { eqn_pats = extractpat pat : pats} + = eqn { eqn_pats = extractpat pat : pats} decomposeFirstPat _ _ = panic "decomposeFirstPat" getCoPat, getBangPat, getViewPat, getOLPat :: Pat Id -> Pat Id @@ -432,17 +425,17 @@ alternatives, so it adds a default case, as it always does. A later pass may remove it if it's inaccessible. (See also Note [Empty case alternatives] in CoreSyn.) -We do *not* deugar simply to - error "empty case" +We do *not* desugar simply to + error "empty case" or some such, because 'x' might be bound to (error "hello"), in which case we want to see that "hello" exception, not (error "empty case"). See also Note [Case elimination: lifted case] in Simplify. %************************************************************************ -%* * - Tidying patterns -%* * +%* * + Tidying patterns +%* * %************************************************************************ Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@ @@ -457,7 +450,7 @@ Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@. Removing lazy (irrefutable) patterns (you don't want to know...). \item Converting explicit tuple-, list-, and parallel-array-pats into ordinary -@ConPats@. +@ConPats@. \item Convert the literal pat "" to []. \end{itemize} @@ -473,7 +466,7 @@ The @VarPat@ information isn't needed any more after this. \item[@LitPats@ and @NPats@:] @LitPats@/@NPats@ of ``known friendly types'' (Int, Char, -Float, Double, at least) are converted to unboxed form; e.g., +Float, Double, at least) are converted to unboxed form; e.g., \tr{(NPat (HsInt i) _ _)} is converted to: \begin{verbatim} (ConPat I# _ _ [LitPat (HsIntPrim i)]) @@ -482,62 +475,62 @@ Float, Double, at least) are converted to unboxed form; e.g., \begin{code} tidyEqnInfo :: Id -> EquationInfo - -> DsM (DsWrapper, EquationInfo) - -- DsM'd because of internal call to dsLHsBinds - -- and mkSelectorBinds. - -- "tidy1" does the interesting stuff, looking at - -- one pattern and fiddling the list of bindings. - -- - -- POST CONDITION: head pattern in the EqnInfo is - -- WildPat - -- ConPat - -- NPat - -- LitPat - -- NPlusKPat - -- but no other - -tidyEqnInfo _ (EqnInfo { eqn_pats = [] }) + -> DsM (DsWrapper, EquationInfo) + -- DsM'd because of internal call to dsLHsBinds + -- and mkSelectorBinds. + -- "tidy1" does the interesting stuff, looking at + -- one pattern and fiddling the list of bindings. + -- + -- POST CONDITION: head pattern in the EqnInfo is + -- WildPat + -- ConPat + -- NPat + -- LitPat + -- NPlusKPat + -- but no other + +tidyEqnInfo _ (EqnInfo { eqn_pats = [] }) = panic "tidyEqnInfo" tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats }) = do { (wrap, pat') <- tidy1 v pat ; return (wrap, eqn { eqn_pats = do pat' : pats }) } -tidy1 :: Id -- The Id being scrutinised - -> Pat Id -- The pattern against which it is to be matched - -> DsM (DsWrapper, -- Extra bindings to do before the match - Pat Id) -- Equivalent pattern +tidy1 :: Id -- The Id being scrutinised + -> Pat Id -- The pattern against which it is to be matched + -> DsM (DsWrapper, -- Extra bindings to do before the match + Pat Id) -- Equivalent pattern ------------------------------------------------------- --- (pat', mr') = tidy1 v pat mr +-- (pat', mr') = tidy1 v pat mr -- tidies the *outer level only* of pat, giving pat' -- It eliminates many pattern forms (as-patterns, variable patterns, -- list patterns, etc) yielding one of: --- WildPat --- ConPatOut --- LitPat --- NPat --- NPlusKPat - -tidy1 v (ParPat pat) = tidy1 v (unLoc pat) -tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat) +-- WildPat +-- ConPatOut +-- LitPat +-- NPat +-- NPlusKPat + +tidy1 v (ParPat pat) = tidy1 v (unLoc pat) +tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat) tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty) tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p - -- case v of { x -> mr[] } - -- = case v of { _ -> let x=v in mr[] } + -- case v of { x -> mr[] } + -- = case v of { _ -> let x=v in mr[] } tidy1 v (VarPat var) - = return (wrapBind var v, WildPat (idType var)) + = return (wrapBind var v, WildPat (idType var)) - -- case v of { x@p -> mr[] } - -- = case v of { p -> let x=v in mr[] } + -- case v of { x@p -> mr[] } + -- = case v of { p -> let x=v in mr[] } tidy1 v (AsPat (L _ var) pat) - = do { (wrap, pat') <- tidy1 v (unLoc pat) - ; return (wrapBind var v . wrap, pat') } + = do { (wrap, pat') <- tidy1 v (unLoc pat) + ; return (wrapBind var v . wrap, pat') } {- now, here we handle lazy patterns: tidy1 v ~p bs = (v, v1 = case v of p -> v1 : - v2 = case v of p -> v2 : ... : bs ) + v2 = case v of p -> v2 : ... : bs ) where the v_i's are the binders in the pattern. @@ -548,16 +541,16 @@ tidy1 v (AsPat (L _ var) pat) tidy1 v (LazyPat pat) = do { sel_prs <- mkSelectorBinds [] pat (Var v) - ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] - ; return (mkCoreLets sel_binds, WildPat (idType v)) } + ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] + ; return (mkCoreLets sel_binds, WildPat (idType v)) } tidy1 _ (ListPat pats ty Nothing) = return (idDsWrapper, unLoc list_ConPat) where list_ty = mkListTy ty list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty) - (mkNilPat list_ty) - pats + (mkNilPat list_ty) + pats -- Introduce fake parallel array constructors to be able to handle parallel -- arrays with the existing machinery for constructor pattern @@ -604,7 +597,7 @@ tidy_bang_pat v _ (ParPat (L l p)) = tidy_bang_pat v l p tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p -- Push the bang-pattern inwards, in the hope that --- it may disappear next time +-- it may disappear next time tidy_bang_pat v l (AsPat v' p) = tidy1 v (AsPat v' (L l (BangPat p))) tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t) @@ -640,9 +633,9 @@ evaluation of \tr{e}. An alternative translation (No.~2): \end{verbatim} %************************************************************************ -%* * +%* * \subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing} -%* * +%* * %************************************************************************ We might be able to optimise unmixing when confronted by @@ -680,9 +673,9 @@ Presumably just a variant on the constructor case (as it is now). \end{description} %************************************************************************ -%* * -%* matchWrapper: a convenient way to call @match@ * -%* * +%* * +%* matchWrapper: a convenient way to call @match@ * +%* * %************************************************************************ \subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@} @@ -724,9 +717,9 @@ Call @match@ with all of this information! \end{enumerate} \begin{code} -matchWrapper :: HsMatchContext Name -- For shadowing warning messages - -> MatchGroup Id (LHsExpr Id) -- Matches being desugared - -> DsM ([Id], CoreExpr) -- Results +matchWrapper :: HsMatchContext Name -- For shadowing warning messages + -> MatchGroup Id (LHsExpr Id) -- Matches being desugared + -> DsM ([Id], CoreExpr) -- Results \end{code} There is one small problem with the Lambda Patterns, when somebody @@ -734,7 +727,7 @@ matchWrapper :: HsMatchContext Name -- For shadowing warning message \begin{verbatim} (\ (x:xs) -> ...) \end{verbatim} - he/she don't want a warning about incomplete patterns, that is done with + he/she don't want a warning about incomplete patterns, that is done with the flag @opt_WarnSimplePatterns@. This problem also appears in the: \begin{itemize} @@ -755,37 +748,37 @@ JJQC 30-Nov-1997 matchWrapper ctxt (MG { mg_alts = matches , mg_arg_tys = arg_tys , mg_res_ty = rhs_ty }) - = do { eqns_info <- mapM mk_eqn_info matches - ; new_vars <- case matches of + = do { eqns_info <- mapM mk_eqn_info matches + ; new_vars <- case matches of [] -> mapM newSysLocalDs arg_tys (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m)) - ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty - ; return (new_vars, result_expr) } + ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty + ; return (new_vars, result_expr) } where mk_eqn_info (L _ (Match pats _ grhss)) = do { let upats = map unLoc pats - ; match_result <- dsGRHSs ctxt upats grhss rhs_ty - ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) } + ; match_result <- dsGRHSs ctxt upats grhss rhs_ty + ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) } matchEquations :: HsMatchContext Name - -> [Id] -> [EquationInfo] -> Type - -> DsM CoreExpr + -> [Id] -> [EquationInfo] -> Type + -> DsM CoreExpr matchEquations ctxt vars eqns_info rhs_ty - = do { locn <- getSrcSpanDs - ; let ds_ctxt = DsMatchContext ctxt locn - error_doc = matchContextErrString ctxt + = do { locn <- getSrcSpanDs + ; let ds_ctxt = DsMatchContext ctxt locn + error_doc = matchContextErrString ctxt - ; match_result <- matchCheck ds_ctxt vars rhs_ty eqns_info + ; match_result <- matchCheck ds_ctxt vars rhs_ty eqns_info - ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc - ; extractMatchResult match_result fail_expr } + ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc + ; extractMatchResult match_result fail_expr } \end{code} %************************************************************************ -%* * +%* * \subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern} -%* * +%* * %************************************************************************ @mkSimpleMatch@ is a wrapper for @match@ which deals with the @@ -793,12 +786,12 @@ situation where we want to match a single expression against a single pattern. It returns an expression. \begin{code} -matchSimply :: CoreExpr -- Scrutinee - -> HsMatchContext Name -- Match kind - -> LPat Id -- Pattern it should match - -> CoreExpr -- Return this if it matches - -> CoreExpr -- Return this if it doesn't - -> DsM CoreExpr +matchSimply :: CoreExpr -- Scrutinee + -> HsMatchContext Name -- Match kind + -> LPat Id -- Pattern it should match + -> CoreExpr -- Return this if it matches + -> CoreExpr -- Return this if it doesn't + -> DsM CoreExpr -- Do not warn about incomplete patterns; see matchSinglePat comments matchSimply scrut hs_ctx pat result_expr fail_expr = do let @@ -809,14 +802,14 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do extractMatchResult match_result' fail_expr matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id - -> Type -> MatchResult -> DsM MatchResult + -> Type -> MatchResult -> DsM MatchResult -- Do not warn about incomplete patterns --- Used for things like [ e | pat <- stuff ], where +-- Used for things like [ e | pat <- stuff ], where -- incomplete patterns are just fine -matchSinglePat (Var var) ctx (L _ pat) ty match_result +matchSinglePat (Var var) ctx (L _ pat) ty match_result = do { locn <- getSrcSpanDs ; matchCheck (DsMatchContext ctx locn) - [var] ty + [var] ty [EqnInfo { eqn_pats = [pat], eqn_rhs = match_result }] } matchSinglePat scrut hs_ctx pat ty match_result @@ -827,29 +820,29 @@ matchSinglePat scrut hs_ctx pat ty match_result %************************************************************************ -%* * - Pattern classification -%* * +%* * + Pattern classification +%* * %************************************************************************ \begin{code} data PatGroup - = PgAny -- Immediate match: variables, wildcards, - -- lazy patterns - | PgCon DataCon -- Constructor patterns (incl list, tuple) - | PgLit Literal -- Literal patterns - | PgN Literal -- Overloaded literals - | PgNpK Literal -- n+k patterns - | PgBang -- Bang patterns - | PgCo Type -- Coercion patterns; the type is the type - -- of the pattern *inside* + = PgAny -- Immediate match: variables, wildcards, + -- lazy patterns + | PgCon DataCon -- Constructor patterns (incl list, tuple) + | PgLit Literal -- Literal patterns + | PgN Literal -- Overloaded literals + | PgNpK Literal -- n+k patterns + | PgBang -- Bang patterns + | PgCo Type -- Coercion patterns; the type is the type + -- of the pattern *inside* | PgView (LHsExpr Id) -- view pattern (e -> p): -- the LHsExpr is the expression e Type -- the Type is the type of p (equivalently, the result type of e) | PgOverloadedList - + groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]] --- If the result is of form [g1, g2, g3], +-- If the result is of form [g1, g2, g3], -- (a) all the (pg,eq) pairs in g1 have the same pg -- (b) none of the gi are empty -- The ordering of equations is unchanged @@ -860,11 +853,11 @@ groupEquations dflags eqns (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2 subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]] --- Input is a particular group. The result sub-groups the +-- Input is a particular group. The result sub-groups the -- equations by with particular constructor, literal etc they match. -- Each sub-list in the result has the same PatGroup -- See Note [Take care with pattern order] -subGroup group +subGroup group = map reverse $ Map.elems $ foldl accumulate Map.empty group where accumulate pg_map (pg, eqn) @@ -880,27 +873,27 @@ Note [Take care with pattern order] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the subGroup function we must be very careful about pattern re-ordering, Consider the patterns [ (True, Nothing), (False, x), (True, y) ] -Then in bringing together the patterns for True, we must not +Then in bringing together the patterns for True, we must not swap the Nothing and y! \begin{code} sameGroup :: PatGroup -> PatGroup -> Bool --- Same group means that a single case expression +-- Same group means that a single case expression -- or test will suffice to match both, *and* the order -- of testing within the group is insignificant. sameGroup PgAny PgAny = True sameGroup PgBang PgBang = True -sameGroup (PgCon _) (PgCon _) = True -- One case expression -sameGroup (PgLit _) (PgLit _) = True -- One case expression -sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant -sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns] -sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2 - -- CoPats are in the same goup only if the type of the - -- enclosed pattern is the same. The patterns outside the CoPat - -- always have the same type, so this boils down to saying that - -- the two coercions are identical. -sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) +sameGroup (PgCon _) (PgCon _) = True -- One case expression +sameGroup (PgLit _) (PgLit _) = True -- One case expression +sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant +sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns] +sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2 + -- CoPats are in the same goup only if the type of the + -- enclosed pattern is the same. The patterns outside the CoPat + -- always have the same type, so this boils down to saying that + -- the two coercions are identical. +sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2) -- ViewPats are in the same group iff the expressions -- are "equal"---conservatively, we use syntactic equality sameGroup _ _ = False @@ -926,17 +919,17 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 --------- exp :: HsExpr Id -> HsExpr Id -> Bool -- real comparison is on HsExpr's - -- strip parens + -- strip parens exp (HsPar (L _ e)) e' = exp e e' exp e (HsPar (L _ e')) = exp e e' -- because the expressions do not necessarily have the same type, -- we have to compare the wrappers exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e' - exp (HsVar i) (HsVar i') = i == i' + exp (HsVar i) (HsVar i') = i == i' -- the instance for IPName derives using the id, so this works if the -- above does - exp (HsIPVar i) (HsIPVar i') = i == i' - exp (HsOverLit l) (HsOverLit l') = + exp (HsIPVar i) (HsIPVar i') = i == i' + exp (HsOverLit l) (HsOverLit l') = -- Overloaded lits are equal if they have the same type -- and the data is the same. -- this is coarser than comparing the SyntaxExpr's in l and l', @@ -947,12 +940,12 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2' -- the fixities have been straightened out by now, so it's safe -- to ignore them? - exp (OpApp l o _ ri) (OpApp l' o' _ ri') = + exp (OpApp l o _ ri) (OpApp l' o' _ ri') = lexp l l' && lexp o o' && lexp ri ri' exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n' - exp (SectionL e1 e2) (SectionL e1' e2') = + exp (SectionL e1 e2) (SectionL e1' e2') = lexp e1 e1' && lexp e2 e2' - exp (SectionR e1 e2) (SectionR e1' e2') = + exp (SectionR e1 e2) (SectionR e1' e2') = lexp e1 e1' && lexp e2 e2' exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) = eq_list tup_arg es1 es2 @@ -961,7 +954,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 -- Enhancement: could implement equality for more expressions -- if it seems useful - -- But no need for HsLit, ExplicitList, ExplicitTuple, + -- But no need for HsLit, ExplicitList, ExplicitTuple, -- because they cannot be functions exp _ _ = False @@ -991,7 +984,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 ev_term :: EvTerm -> EvTerm -> Bool ev_term (EvId a) (EvId b) = a==b ev_term (EvCoercion a) (EvCoercion b) = a `eq_co` b - ev_term _ _ = False + ev_term _ _ = False --------- eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool @@ -1001,11 +994,11 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2 eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys --------- - eq_co :: TcCoercion -> TcCoercion -> Bool + eq_co :: TcCoercion -> TcCoercion -> Bool -- Just some simple cases eq_co (TcRefl t1) (TcRefl t2) = eqType t1 t2 - eq_co (TcCoVarCo v1) (TcCoVarCo v2) = v1==v2 - eq_co (TcSymCo co1) (TcSymCo co2) = co1 `eq_co` co2 + eq_co (TcCoVarCo v1) (TcCoVarCo v2) = v1==v2 + eq_co (TcSymCo co1) (TcSymCo co2) = co1 `eq_co` co2 eq_co (TcTyConAppCo tc1 cos1) (TcTyConAppCo tc2 cos2) = tc1==tc2 && eq_list eq_co cos1 cos2 eq_co _ _ = False @@ -1026,15 +1019,15 @@ Note [Grouping overloaded literal patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ WATCH OUT! Consider - f (n+1) = ... - f (n+2) = ... - f (n+1) = ... + f (n+1) = ... + f (n+2) = ... + f (n+1) = ... -We can't group the first and third together, because the second may match +We can't group the first and third together, because the second may match the same thing as the first. Same goes for *overloaded* literal patterns - f 1 True = ... - f 2 False = ... - f 1 False = ... + f 1 True = ... + f 2 False = ... + f 1 False = ... If the first arg matches '1' but the second does not match 'True', we cannot jump to the third equation! Because the same argument might match '2'! diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index f3c9894b57..23538bec82 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -6,16 +6,9 @@ Pattern-matching literal patterns \begin{code} -{-# 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 MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey, - tidyLitPat, tidyNPat, - matchLiterals, matchNPlusKPats, matchNPats ) where + tidyLitPat, tidyNPat, + matchLiterals, matchNPlusKPats, matchNPats ) where #include "HsVersions.h" @@ -32,7 +25,7 @@ import CoreSyn import MkCore import TyCon import DataCon -import TcHsSyn ( shortCutLit ) +import TcHsSyn ( shortCutLit ) import TcType import PrelNames import TysWiredIn @@ -48,11 +41,11 @@ import FastString \end{code} %************************************************************************ -%* * - Desugaring literals - [used to be in DsExpr, but DsMeta needs it, - and it's nice to avoid a loop] -%* * +%* * + Desugaring literals + [used to be in DsExpr, but DsMeta needs it, + and it's nice to avoid a loop] +%* * %************************************************************************ We give int/float literals type @Integer@ and @Rational@, respectively. @@ -90,7 +83,7 @@ dsLit (HsRat r ty) = do denom <- mkIntegerExpr (denominator (fl_value r)) return (mkConApp ratio_data_con [Type integer_ty, num, denom]) where - (ratio_data_con, integer_ty) + (ratio_data_con, integer_ty) = case tcSplitTyConApp ty of (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) (head (tyConDataCons tycon), i_ty) @@ -101,29 +94,29 @@ dsOverLit lit = do dflags <- getDynFlags dsOverLit' dflags lit dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr --- Post-typechecker, the SyntaxExpr field of an OverLit contains +-- Post-typechecker, the SyntaxExpr field of an OverLit contains -- (an expression for) the literal value itself dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable , ol_witness = witness, ol_type = ty }) | not rebindable - , Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut] - | otherwise = dsExpr witness + , Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut] + | otherwise = dsExpr witness \end{code} Note [Literal short cut] ~~~~~~~~~~~~~~~~~~~~~~~~ -The type checker tries to do this short-cutting as early as possible, but +The type checker tries to do this short-cutting as early as possible, but because of unification etc, more information is available to the desugarer. And where it's possible to generate the correct literal right away, it's -much better do do so. +much better to do so. \begin{code} hsLitKey :: DynFlags -> HsLit -> Literal -- Get a Core literal to use (only) a grouping key -- Hence its type doesn't need to match the type of the original literal --- (and doesn't for strings) --- It only works for primitive types and strings; +-- (and doesn't for strings) +-- It only works for primitive types and strings; -- others have been removed by tidy hsLitKey dflags (HsIntPrim i) = mkMachInt dflags i hsLitKey dflags (HsWordPrim w) = mkMachWord dflags w @@ -149,46 +142,46 @@ litValKey (HsIsString s) neg = ASSERT( not neg) MachStr (fastStringToByteStr \end{code} %************************************************************************ -%* * - Tidying lit pats -%* * +%* * + Tidying lit pats +%* * %************************************************************************ \begin{code} tidyLitPat :: HsLit -> Pat Id -- Result has only the following HsLits: --- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim --- HsDoublePrim, HsStringPrim, HsString +-- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim +-- HsDoublePrim, HsStringPrim, HsString -- * HsInteger, HsRat, HsInt can't show up in LitPats -- * We get rid of HsChar right here tidyLitPat (HsChar c) = unLoc (mkCharLitPat c) tidyLitPat (HsString s) - | lengthFS s <= 1 -- Short string literals only + | lengthFS s <= 1 -- Short string literals only = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy) - (mkNilPat stringTy) (unpackFS s) - -- The stringTy is the type of the whole pattern, not - -- the type to instantiate (:) or [] with! + (mkNilPat stringTy) (unpackFS s) + -- The stringTy is the type of the whole pattern, not + -- the type to instantiate (:) or [] with! tidyLitPat lit = LitPat lit ---------------- -tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat - -- We need this argument because tidyNPat is called - -- both by Match and by Check, but they tidy LitPats - -- slightly differently; and we must desugar - -- literals consistently (see Trac #5117) - -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id +tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat + -- We need this argument because tidyNPat is called + -- both by Match and by Check, but they tidy LitPats + -- slightly differently; and we must desugar + -- literals consistently (see Trac #5117) + -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _ - -- False: Take short cuts only if the literal is not using rebindable syntax - -- - -- Once that is settled, look for cases where the type of the - -- entire overloaded literal matches the type of the underlying literal, - -- and in that case take the short cut - -- NB: Watch out for wierd cases like Trac #3382 - -- f :: Int -> Int - -- f "blah" = 4 - -- which might be ok if we hvae 'instance IsString Int' - -- + -- False: Take short cuts only if the literal is not using rebindable syntax + -- + -- Once that is settled, look for cases where the type of the + -- entire overloaded literal matches the type of the underlying literal, + -- and in that case take the short cut + -- NB: Watch out for wierd cases like Trac #3382 + -- f :: Int -> Int + -- f "blah" = 4 + -- which might be ok if we hvae 'instance IsString Int' + -- | isIntTy ty, Just int_lit <- mb_int_lit = mk_con_pat intDataCon (HsIntPrim int_lit) | isWordTy ty, Just int_lit <- mb_int_lit = mk_con_pat wordDataCon (HsWordPrim int_lit) @@ -201,55 +194,55 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _ mb_int_lit :: Maybe Integer mb_int_lit = case (mb_neg, val) of - (Nothing, HsIntegral i) -> Just i - (Just _, HsIntegral i) -> Just (-i) - _ -> Nothing - + (Nothing, HsIntegral i) -> Just i + (Just _, HsIntegral i) -> Just (-i) + _ -> Nothing + mb_rat_lit :: Maybe FractionalLit mb_rat_lit = case (mb_neg, val) of - (Nothing, HsIntegral i) -> Just (integralFractionalLit (fromInteger i)) - (Just _, HsIntegral i) -> Just (integralFractionalLit (fromInteger (-i))) - (Nothing, HsFractional f) -> Just f - (Just _, HsFractional f) -> Just (negateFractionalLit f) - _ -> Nothing - + (Nothing, HsIntegral i) -> Just (integralFractionalLit (fromInteger i)) + (Just _, HsIntegral i) -> Just (integralFractionalLit (fromInteger (-i))) + (Nothing, HsFractional f) -> Just f + (Just _, HsFractional f) -> Just (negateFractionalLit f) + _ -> Nothing + mb_str_lit :: Maybe FastString mb_str_lit = case (mb_neg, val) of - (Nothing, HsIsString s) -> Just s - _ -> Nothing + (Nothing, HsIsString s) -> Just s + _ -> Nothing -tidyNPat _ over_lit mb_neg eq +tidyNPat _ over_lit mb_neg eq = NPat over_lit mb_neg eq \end{code} %************************************************************************ -%* * - Pattern matching on LitPat -%* * +%* * + Pattern matching on LitPat +%* * %************************************************************************ \begin{code} matchLiterals :: [Id] - -> Type -- Type of the whole case expression - -> [[EquationInfo]] -- All PgLits - -> DsM MatchResult + -> Type -- Type of the whole case expression + -> [[EquationInfo]] -- All PgLits + -> DsM MatchResult matchLiterals (var:vars) ty sub_groups = ASSERT( notNull sub_groups && all notNull sub_groups ) - do { -- Deal with each group - ; alts <- mapM match_group sub_groups - - -- Combine results. For everything except String - -- we can use a case expression; for String we need - -- a chain of if-then-else - ; if isStringTy (idType var) then - do { eq_str <- dsLookupGlobalId eqStringName - ; mrs <- mapM (wrap_str_guard eq_str) alts - ; return (foldr1 combineMatchResults mrs) } - else - return (mkCoPrimCaseMatchResult var ty alts) - } + do { -- Deal with each group + ; alts <- mapM match_group sub_groups + + -- Combine results. For everything except String + -- we can use a case expression; for String we need + -- a chain of if-then-else + ; if isStringTy (idType var) then + do { eq_str <- dsLookupGlobalId eqStringName + ; mrs <- mapM (wrap_str_guard eq_str) alts + ; return (foldr1 combineMatchResults mrs) } + else + return (mkCoPrimCaseMatchResult var ty alts) + } where match_group :: [EquationInfo] -> DsM (Literal, MatchResult) match_group eqns @@ -259,14 +252,14 @@ matchLiterals (var:vars) ty sub_groups return (hsLitKey dflags hs_lit, match_result) wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult - -- Equality check for string literals + -- Equality check for string literals wrap_str_guard eq_str (MachStr s, mr) - = do { -- We now have to convert back to FastString. Perhaps there - -- should be separate MachBytes and MachStr constructors? - s' <- liftIO $ mkFastStringByteString s - ; lit <- mkStringExprFS s' - ; let pred = mkApps (Var eq_str) [Var var, lit] - ; return (mkGuardedMatchResult pred mr) } + = do { -- We now have to convert back to FastString. Perhaps there + -- should be separate MachBytes and MachStr constructors? + s' <- liftIO $ mkFastStringByteString s + ; lit <- mkStringExprFS s' + ; let pred = mkApps (Var eq_str) [Var var, lit] + ; return (mkGuardedMatchResult pred mr) } wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l) matchLiterals [] _ _ = panic "matchLiterals []" @@ -274,42 +267,42 @@ matchLiterals [] _ _ = panic "matchLiterals []" %************************************************************************ -%* * - Pattern matching on NPat -%* * +%* * + Pattern matching on NPat +%* * %************************************************************************ \begin{code} matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal - = do { let NPat lit mb_neg eq_chk = firstPat eqn1 - ; lit_expr <- dsOverLit lit - ; neg_lit <- case mb_neg of - Nothing -> return lit_expr - Just neg -> do { neg_expr <- dsExpr neg - ; return (App neg_expr lit_expr) } - ; eq_expr <- dsExpr eq_chk - ; let pred_expr = mkApps eq_expr [Var var, neg_lit] - ; match_result <- match vars ty (shiftEqns (eqn1:eqns)) - ; return (mkGuardedMatchResult pred_expr match_result) } +matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal + = do { let NPat lit mb_neg eq_chk = firstPat eqn1 + ; lit_expr <- dsOverLit lit + ; neg_lit <- case mb_neg of + Nothing -> return lit_expr + Just neg -> do { neg_expr <- dsExpr neg + ; return (App neg_expr lit_expr) } + ; eq_expr <- dsExpr eq_chk + ; let pred_expr = mkApps eq_expr [Var var, neg_lit] + ; match_result <- match vars ty (shiftEqns (eqn1:eqns)) + ; return (mkGuardedMatchResult pred_expr match_result) } matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns)) \end{code} %************************************************************************ -%* * - Pattern matching on n+k patterns -%* * +%* * + Pattern matching on n+k patterns +%* * %************************************************************************ For an n+k pattern, we use the various magic expressions we've been given. We generate: \begin{verbatim} if ge var lit then - let n = sub var lit - in <expr-for-a-successful-match> + let n = sub var lit + in <expr-for-a-successful-match> else - <try-next-pattern-or-whatever> + <try-next-pattern-or-whatever> \end{verbatim} @@ -317,22 +310,22 @@ We generate: matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- All NPlusKPats, for the *same* literal k matchNPlusKPats (var:vars) ty (eqn1:eqns) - = do { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1 - ; ge_expr <- dsExpr ge - ; minus_expr <- dsExpr minus - ; lit_expr <- dsOverLit lit - ; let pred_expr = mkApps ge_expr [Var var, lit_expr] - minusk_expr = mkApps minus_expr [Var var, lit_expr] - (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns) - ; match_result <- match vars ty eqns' - ; return (mkGuardedMatchResult pred_expr $ - mkCoLetMatchResult (NonRec n1 minusk_expr) $ - adjustMatchResult (foldr1 (.) wraps) $ - match_result) } + = do { let NPlusKPat (L _ n1) lit ge minus = firstPat eqn1 + ; ge_expr <- dsExpr ge + ; minus_expr <- dsExpr minus + ; lit_expr <- dsOverLit lit + ; let pred_expr = mkApps ge_expr [Var var, lit_expr] + minusk_expr = mkApps minus_expr [Var var, lit_expr] + (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns) + ; match_result <- match vars ty eqns' + ; return (mkGuardedMatchResult pred_expr $ + mkCoLetMatchResult (NonRec n1 minusk_expr) $ + adjustMatchResult (foldr1 (.) wraps) $ + match_result) } where shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats }) - = (wrapBind n n1, eqn { eqn_pats = pats }) - -- The wrapBind is a no-op for the first equation + = (wrapBind n n1, eqn { eqn_pats = pats }) + -- The wrapBind is a no-op for the first equation shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns)) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 7ce0a52fa1..bfcbb87eb9 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -99,6 +99,7 @@ Library c-sources: ghci/keepCAFsForGHCi.c + cbits/genSym.c hs-source-dirs: basicTypes @@ -138,6 +139,7 @@ Library Literal Llvm Llvm.AbsSyn + Llvm.MetaData Llvm.PpLlvm Llvm.Types LlvmCodeGen @@ -206,7 +208,6 @@ Library StgCmmEnv StgCmmExpr StgCmmForeign - StgCmmGran StgCmmHeap StgCmmHpc StgCmmArgRep diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 1a032cc71f..2a7a8c4b87 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -117,6 +117,22 @@ ifeq "$(DYNAMIC_GHC_PROGRAMS)" "YES" else @echo 'cDYNAMIC_GHC_PROGRAMS = False' >> $@ endif +# Note that GhcThreaded just reflects the Makefile variable setting. +# In particular, the stage1 compiler is never actually compiled with +# -threaded, but it will nevertheless have cGhcThreaded = True. +# The "+RTS --info" output will show what RTS GHC is really using. + @echo 'cGhcThreaded :: Bool' >> $@ +ifeq "$(GhcThreaded)" "YES" + @echo 'cGhcThreaded = True' >> $@ +else + @echo 'cGhcThreaded = False' >> $@ +endif + @echo 'cGhcDebugged :: Bool' >> $@ +ifeq "$(GhcDebugged)" "YES" + @echo 'cGhcDebugged = True' >> $@ +else + @echo 'cGhcDebugged = False' >> $@ +endif @echo done. # ----------------------------------------------------------------------------- @@ -405,7 +421,7 @@ compiler_stage3_SplitObjs = NO # We therefore need to split some of the modules off into a separate # DLL. This clump are the modules reachable from DynFlags: compiler_stage2_dll0_START_MODULE = DynFlags -compiler_stage2_dll0_MODULES = Annotations Avail Bag BasicTypes Binary Bitmap BlockId BreakArray BufWrite ByteCodeAsm ByteCodeInstr ByteCodeItbls ByteCodeLink CLabel Class CmdLineParser Cmm CmmCallConv CmmExpr CmmInfo CmmMachOp CmmNode CmmType CmmUtils CoAxiom CodeGen.Platform CodeGen.Platform.ARM CodeGen.Platform.NoRegs CodeGen.Platform.PPC CodeGen.Platform.PPC_Darwin CodeGen.Platform.SPARC CodeGen.Platform.X86 CodeGen.Platform.X86_64 Coercion Config Constants CoreArity CoreFVs CoreSubst CoreSyn CoreTidy CoreUnfold CoreUtils CostCentre DataCon Demand Digraph DriverPhases DynFlags Encoding ErrUtils Exception FamInstEnv FastBool FastFunctions FastMutInt FastString FastTypes Fingerprint FiniteMap ForeignCall Hoopl Hoopl.Dataflow HsBinds HsDecls HsDoc HsExpr HsImpExp HsLit HsPat HsSyn HsTypes HsUtils HscTypes Id IdInfo IfaceSyn IfaceType InstEnv InteractiveEvalTypes Kind ListSetOps Literal Maybes MkCore MkGraph MkId Module MonadUtils Name NameEnv NameSet ObjLink OccName OccurAnal OptCoercion OrdList Outputable PackageConfig Packages Pair Panic Platform PlatformConstants PprCmm PprCmmDecl PprCmmExpr PprCore PrelNames PrelRules Pretty PrimOp RdrName Reg RegClass Rules SMRep Serialized SrcLoc StaticFlags StgCmmArgRep StgCmmClosure StgCmmEnv StgCmmLayout StgCmmMonad StgCmmProf StgCmmTicky StgCmmUtils StgSyn Stream StringBuffer TcEvidence TcType TyCon Type TypeRep TysPrim TysWiredIn Unify UniqFM UniqSet UniqSupply Unique Util Var VarEnv VarSet +compiler_stage2_dll0_MODULES = Annotations Avail Bag BasicTypes Binary Bitmap BlockId BreakArray BufWrite ByteCodeAsm ByteCodeInstr ByteCodeItbls ByteCodeLink CLabel Class CmdLineParser Cmm CmmCallConv CmmExpr CmmInfo CmmMachOp CmmNode CmmType CmmUtils CoAxiom CodeGen.Platform CodeGen.Platform.ARM CodeGen.Platform.NoRegs CodeGen.Platform.PPC CodeGen.Platform.PPC_Darwin CodeGen.Platform.SPARC CodeGen.Platform.X86 CodeGen.Platform.X86_64 Coercion Config Constants CoreArity CoreFVs CoreSubst CoreSyn CoreTidy CoreUnfold CoreUtils CostCentre DataCon Demand Digraph DriverPhases DynFlags Encoding ErrUtils Exception FamInstEnv FastBool FastFunctions FastMutInt FastString FastTypes Fingerprint FiniteMap ForeignCall Hoopl Hoopl.Dataflow HsBinds HsDecls HsDoc HsExpr HsImpExp HsLit HsPat HsSyn HsTypes HsUtils HscTypes Id IdInfo IfaceSyn IfaceType InstEnv InteractiveEvalTypes Kind ListSetOps Literal Maybes MkCore MkGraph MkId Module MonadUtils Name NameEnv NameSet ObjLink OccName OccurAnal OptCoercion OrdList Outputable PackageConfig Packages Pair Panic Platform PlatformConstants PprCmm PprCmmDecl PprCmmExpr PprCore PrelNames PrelRules Pretty PrimOp RdrName Reg RegClass Rules SMRep Serialized SrcLoc StaticFlags StgCmmArgRep StgCmmClosure StgCmmEnv StgCmmLayout StgCmmMonad StgCmmProf StgCmmTicky StgCmmUtils StgSyn Stream StringBuffer TcEvidence TcType TrieMap TyCon Type TypeRep TysPrim TysWiredIn Unify UniqFM UniqSet UniqSupply Unique Util Var VarEnv VarSet compiler_stage2_dll0_HS_OBJS = \ $(patsubst %,compiler/stage2/build/%.$(dyn_osuf),$(subst .,/,$(compiler_stage2_dll0_MODULES))) diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 955119768d..e3119a7842 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -41,8 +41,10 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.State.Strict import Data.Array.MArray -import Data.Array.Unboxed ( listArray ) + +import qualified Data.Array.Unboxed as Array import Data.Array.Base ( UArray(..) ) + import Data.Array.Unsafe( castSTUArray ) import Foreign @@ -156,16 +158,16 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm dflags long_jumps env asm -- precomputed size should be equal to final size - ASSERT (n_insns == sizeSS final_insns) return () + ASSERT(n_insns == sizeSS final_insns) return () let asm_insns = ssElts final_insns barr a = case a of UArray _lo _hi _n b -> b - insns_arr = listArray (0, n_insns - 1) asm_insns + insns_arr = Array.listArray (0, n_insns - 1) asm_insns !insns_barr = barr insns_arr bitmap_arr = mkBitmapArray dflags bsize bitmap - !bitmap_barr = barr bitmap_arr + !bitmap_barr = toByteArray bitmap_arr ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs @@ -176,9 +178,15 @@ assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = d return ul_bco +#if __GLASGOW_HASKELL__ > 706 +mkBitmapArray :: DynFlags -> Word16 -> [StgWord] -> UArrayStgWord Int +mkBitmapArray dflags bsize bitmap + = SMRep.listArray (0, length bitmap) (toStgWord dflags (toInteger bsize) : bitmap) +#else mkBitmapArray :: DynFlags -> Word16 -> [StgWord] -> UArray Int StgWord mkBitmapArray dflags bsize bitmap - = listArray (0, length bitmap) (toStgWord dflags (toInteger bsize) : bitmap) + = Array.listArray (0, length bitmap) (toStgWord dflags (toInteger bsize) : bitmap) +#endif -- instrs nonptrs ptrs type AsmState = (SizedSeq Word16, diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs index 7a03bbcdc2..3d73e69e2b 100644 --- a/compiler/ghci/DebuggerUtils.hs +++ b/compiler/ghci/DebuggerUtils.hs @@ -115,14 +115,14 @@ dataConInfoPtrToName x = do -- Warning: this code assumes that the string is well formed. parse :: [Word8] -> ([Word8], [Word8], [Word8]) parse input - = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ) + = ASSERT(all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ) where dot = fromIntegral (ord '.') (pkg, rest1) = break (== fromIntegral (ord ':')) input (mod, occ) = (concat $ intersperse [dot] $ reverse modWords, occWord) where - (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1)) + (modWords, occWord) = ASSERT(length rest1 > 0) (parseModOcc [] (tail rest1)) parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8]) -- We only look for dots if str could start with a module name, -- i.e. if it starts with an upper case character. diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index ffe43e07ba..192df2ee57 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -291,15 +291,14 @@ reallyInitDynLinker dflags = ; pls <- linkPackages' dflags (preloadPackages (pkgState dflags)) pls0 -- (c) Link libraries from the command-line - ; let optl = getOpts dflags opt_l - ; let minus_ls = [ lib | '-':'l':lib <- optl ] + ; let cmdline_ld_inputs = ldInputs dflags + ; let minus_ls = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] ; let lib_paths = libraryPaths dflags ; libspecs <- mapM (locateLib dflags False lib_paths) minus_ls -- (d) Link .o files from the command-line - ; let cmdline_ld_inputs = ldInputs dflags - - ; classified_ld_inputs <- mapM (classifyLdInput dflags) cmdline_ld_inputs + ; classified_ld_inputs <- mapM (classifyLdInput dflags) + [ f | FileOption _ f <- cmdline_ld_inputs ] -- (e) Link any MacOS frameworks ; let platform = targetPlatform dflags @@ -637,8 +636,8 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods return lnk adjust_ul new_osuf (DotO file) = do - MASSERT (osuf `isSuffixOf` file) - let file_base = reverse (drop (length osuf + 1) (reverse file)) + MASSERT(osuf `isSuffixOf` file) + let file_base = dropTail (length osuf + 1) file new_file = file_base <.> new_osuf ok <- doesFileExist new_file if (not ok) @@ -786,7 +785,7 @@ dynLinkObjs dflags pls objs = do if cDYNAMIC_GHC_PROGRAMS then do dynLoadObjs dflags wanted_objs - return (pls, Succeeded) + return (pls1, Succeeded) else do mapM_ loadObj wanted_objs -- Link them all together @@ -801,6 +800,7 @@ dynLinkObjs dflags pls objs = do return (pls2, Failed) dynLoadObjs :: DynFlags -> [FilePath] -> IO () +dynLoadObjs _ [] = return () dynLoadObjs dflags objs = do let platform = targetPlatform dflags soFile <- newTempName dflags (soExt platform) @@ -896,7 +896,7 @@ linkSomeBCOs dflags toplevs_only ie ce_in ul_bcos else ce_all_additions ce_out = -- make sure we're not inserting duplicate names into the -- closure environment, which leads to trouble. - ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions)) + ASSERT(all (not . (`elemNameEnv` ce_in)) (map fst ce_additions)) extendClosureEnv ce_in ce_additions return (ce_out, hvals) @@ -968,6 +968,9 @@ unload_wkr _ linkables pls maybeUnload :: [Linkable] -> Linkable -> IO Bool maybeUnload keep_linkables lnk | linkableInSet lnk keep_linkables = return True + -- We don't do any cleanup when linking objects with the dynamic linker. + -- Doing so introduces extra complexity for not much benefit. + | cDYNAMIC_GHC_PROGRAMS = return False | otherwise = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk] -- The components of a BCO linkable may contain @@ -1195,7 +1198,7 @@ locateLib dflags is_hs dirs lib mk_arch_path dir = dir </> ("lib" ++ lib <.> "a") hs_dyn_lib_name = lib ++ "-ghc" ++ cProjectVersion - mk_hs_dyn_lib_path dir = dir </> mkSOName platform hs_dyn_lib_name + mk_hs_dyn_lib_path dir = dir </> mkHsSOName platform hs_dyn_lib_name so_name = mkSOName platform lib mk_dyn_lib_path dir = dir </> so_name @@ -1272,12 +1275,13 @@ findFile mk_file_path (dir : dirs) \begin{code} maybePutStr :: DynFlags -> String -> IO () -maybePutStr dflags s | verbosity dflags > 0 = putStr s - | otherwise = return () +maybePutStr dflags s + = when (verbosity dflags > 0) $ + do let act = log_action dflags + act dflags SevInteractive noSrcSpan defaultUserStyle (text s) maybePutStrLn :: DynFlags -> String -> IO () -maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s - | otherwise = return () +maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n") \end{code} %************************************************************************ diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index d6cbf87fcc..746a547a5b 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -1264,7 +1264,7 @@ unlessM condM acc = condM >>= \c -> unless c acc -- Strict application of f at index i appArr :: Ix i => (e -> a) -> Array i e -> Int -> a appArr f a@(Array _ _ _ ptrs#) i@(I# i#) - = ASSERT2 (i < length(elems a), ppr(length$ elems a, i)) + = ASSERT2(i < length(elems a), ppr(length$ elems a, i)) case indexArray# ptrs# i# of (# e #) -> f e diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 8caf987336..383b641262 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -20,6 +20,7 @@ import qualified OccName import OccName import SrcLoc import Type +import qualified Coercion ( Role(..) ) import TysWiredIn import BasicTypes as Hs import ForeignCall @@ -215,7 +216,7 @@ cvtDec (FamilyD flav tc tvs kind) ; kind' <- cvtMaybeKind kind ; returnL $ TyClD (FamDecl (FamilyDecl (cvtFamFlavour flav) tc' tvs' kind')) } where - cvtFamFlavour TypeFam = TypeFamily + cvtFamFlavour TypeFam = OpenTypeFamily cvtFamFlavour DataFam = DataFamily cvtDec (DataInstD ctxt tc tys constrs derivs) @@ -243,13 +244,21 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs) { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats' , dfid_defn = defn, dfid_fvs = placeHolderNames } }} -cvtDec (TySynInstD tc eqns) +cvtDec (TySynInstD tc eqn) = do { tc' <- tconNameL tc - ; eqns' <- mapM (cvtTySynEqn tc') eqns + ; eqn' <- cvtTySynEqn tc' eqn ; returnL $ InstD $ TyFamInstD - { tfid_inst = TyFamInstDecl { tfid_eqns = eqns' - , tfid_group = (length eqns' /= 1) + { tfid_inst = TyFamInstDecl { tfid_eqn = eqn' , tfid_fvs = placeHolderNames } } } + +cvtDec (ClosedTypeFamilyD tc tyvars mkind eqns) + | not $ null eqns + = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tyvars + ; mkind' <- cvtMaybeKind mkind + ; eqns' <- mapM (cvtTySynEqn tc') eqns + ; returnL $ TyClD (FamDecl (FamilyDecl (ClosedTypeFamily eqns') tc' tvs' mkind')) } + | otherwise + = failWith (ptext (sLit "Illegal empty closed type family")) ---------------- cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName) cvtTySynEqn tc (TySynEqn lhs rhs) @@ -839,11 +848,25 @@ cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName) cvt_tv (TH.PlainTV nm) = do { nm' <- tName nm - ; returnL $ UserTyVar nm' } + ; returnL $ HsTyVarBndr nm' Nothing Nothing } cvt_tv (TH.KindedTV nm ki) = do { nm' <- tName nm ; ki' <- cvtKind ki - ; returnL $ KindedTyVar nm' ki' } + ; returnL $ HsTyVarBndr nm' (Just ki') Nothing } +cvt_tv (TH.RoledTV nm r) + = do { nm' <- tName nm + ; r' <- cvtRole r + ; returnL $ HsTyVarBndr nm' Nothing (Just r') } +cvt_tv (TH.KindedRoledTV nm k r) + = do { nm' <- tName nm + ; k' <- cvtKind k + ; r' <- cvtRole r + ; returnL $ HsTyVarBndr nm' (Just k') (Just r') } + +cvtRole :: TH.Role -> CvtM Coercion.Role +cvtRole TH.Nominal = return Coercion.Nominal +cvtRole TH.Representational = return Coercion.Representational +cvtRole TH.Phantom = return Coercion.Phantom cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName) cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' } diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 44e7e399eb..cb2538f574 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -163,9 +163,7 @@ data HsBindLR idL idR -- 2. ftvs is a subset of tvs -- 3. ftvs includes all tyvars free in ds -- - -- See section 9 of static semantics paper for more details. - -- (You can get a PhD for explaining the True Meaning - -- of this last construct.) + -- See Note [AbsBinds] data ABExport id = ABE { abe_poly :: id -- Any INLINE pragmas is attached to this Id @@ -180,9 +178,69 @@ placeHolderNames :: NameSet placeHolderNames = panic "placeHolderNames" \end{code} +Note [AbsBinds] +~~~~~~~~~~~~~~~ +The AbsBinds constructor is used in the output of the type checker, to record +*typechecked* and *generalised* bindings. Consider a module M, with this +top-level binding + M.reverse [] = [] + M.reverse (x:xs) = M.reverse xs ++ [x] + +In Hindley-Milner, a recursive binding is typechecked with the *recursive* uses +being *monomorphic*. So after typechecking *and* desugaring we will get something +like this + + M.reverse :: forall a. [a] -> [a] + = /\a. letrec + reverse :: [a] -> [a] = \xs -> case xs of + [] -> [] + (x:xs) -> reverse xs ++ [x] + in reverse + +Notice that 'M.reverse' is polymorphic as expected, but there is a local +definition for plain 'reverse' which is *monomorphic*. The type variable +'a' scopes over the entire letrec. + +That's after desugaring. What about after type checking but before desugaring? +That's where AbsBinds comes in. It looks like this: + + AbsBinds { abs_tvs = [a] + , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a], + , abe_mono = reverse :: a -> a}] + , abs_binds = { reverse :: [a] -> [a] + = \xs -> case xs of + [] -> [] + (x:xs) -> reverse xs ++ [x] } } + +Here, + * abs_tvs says what type variables are abstracted over the binding group, + just 'a' in this case. + * abs_binds is the *monomorphic* bindings of the group + * abs_exports describes how to get the polymorphic Id 'M.reverse' from the + monomorphic one 'reverse' + +Notice that the *original* function (the polymorphic one you thought +you were defining) appears in the abe_poly field of the +abs_exports. The bindings in abs_binds are for fresh, local, Ids with +a *monomorphic* Id. + +If there is a group of mutually recursive functions without type +signatures, we get one AbsBinds with the monomorphic versions of the +bindings in abs_binds, and one element of abe_exports for each +variable bound in the mutually recursive group. This is true even for +pattern bindings. Example: + (f,g) = (\x -> x, f) +After type checking we get + AbsBinds { abs_tvs = [a] + , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a + , abe_mono = f :: a -> a } + , ABE { abe_poly = M.g :: forall a. a -> a + , abe_mono = g :: a -> a }] + , abs_binds = { (f,g) = (\x -> x, f) } + Note [AbsBinds wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~ -Consdider +Consider (f,g) = (\x.x, \y.y) This ultimately desugars to something like this: tup :: forall a b. (a->a, b->b) @@ -557,7 +615,7 @@ hsSigDoc (TypeSig {}) = ptext (sLit "type signature") hsSigDoc (GenericSig {}) = ptext (sLit "default type signature") hsSigDoc (IdSig {}) = ptext (sLit "id signature") hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma") -hsSigDoc (InlineSig {}) = ptext (sLit "INLINE pragma") +hsSigDoc (InlineSig _ prag) = ppr (inlinePragmaSpec prag) <+> ptext (sLit "pragma") hsSigDoc (SpecInstSig {}) = ptext (sLit "SPECIALISE instance pragma") hsSigDoc (FixSig {}) = ptext (sLit "fixity declaration") \end{code} @@ -575,22 +633,22 @@ ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (GenericSig vars ty) = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty) ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id)) ppr_sig (FixSig fix_sig) = ppr fix_sig -ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr ty) inl) -ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> ppr var) +ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec (unLoc var) (ppr ty) inl) +ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var)) ppr_sig (SpecInstSig ty) = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty) -instance Outputable name => Outputable (FixitySig name) where - ppr (FixitySig name fixity) = sep [ppr fixity, ppr name] +instance OutputableBndr name => Outputable (FixitySig name) where + ppr (FixitySig name fixity) = sep [ppr fixity, pprInfixOcc (unLoc name)] pragBrackets :: SDoc -> SDoc pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}") -pprVarSig :: (Outputable id) => [id] -> SDoc -> SDoc +pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty] where - pprvars = hsep $ punctuate comma (map ppr vars) + pprvars = hsep $ punctuate comma (map pprPrefixOcc vars) -pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc +pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig [var] pp_ty where pp_inl | isDefaultInlinePragma inl = empty diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index ce391c73e2..ee4b0fab34 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -18,13 +18,14 @@ module HsDecls ( TyClDecl(..), LTyClDecl, TyClGroup, isClassDecl, isDataDecl, isSynDecl, tcdName, isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, + isOpenTypeFamilyInfo, isClosedTypeFamilyInfo, tyFamInstDeclName, tyFamInstDeclLName, countTyClDecls, pprTyClDeclFlavour, tyClDeclLName, tyClDeclTyVars, FamilyDecl(..), LFamilyDecl, -- ** Instance declarations - InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..), + InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..), TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts, DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, TyFamInstEqn(..), LTyFamInstEqn, @@ -470,16 +471,19 @@ data TyClDecl name type LFamilyDecl name = Located (FamilyDecl name) data FamilyDecl name = FamilyDecl - { fdFlavour :: FamilyFlavour -- type or data + { fdInfo :: FamilyInfo name -- type or data, closed or open , fdLName :: Located name -- type constructor , fdTyVars :: LHsTyVarBndrs name -- type variables , fdKindSig :: Maybe (LHsKind name) } -- result kind deriving( Data, Typeable ) -data FamilyFlavour - = TypeFamily - | DataFamily - deriving( Data, Typeable, Eq ) +data FamilyInfo name + = DataFamily + | OpenTypeFamily + -- this list might be empty, if we're in an hs-boot file and the user + -- said "type family Foo x where .." + | ClosedTypeFamily [LTyFamInstEqn name] + deriving( Data, Typeable ) \end{code} @@ -510,13 +514,27 @@ isFamilyDecl _other = False -- | type family declaration isTypeFamilyDecl :: TyClDecl name -> Bool -isTypeFamilyDecl (FamDecl d) = fdFlavour d == TypeFamily -isTypeFamilyDecl _other = False +isTypeFamilyDecl (FamDecl (FamilyDecl { fdInfo = info })) = case info of + OpenTypeFamily -> True + ClosedTypeFamily {} -> True + _ -> False +isTypeFamilyDecl _ = False + +-- | open type family info +isOpenTypeFamilyInfo :: FamilyInfo name -> Bool +isOpenTypeFamilyInfo OpenTypeFamily = True +isOpenTypeFamilyInfo _ = False + +-- | closed type family info +isClosedTypeFamilyInfo :: FamilyInfo name -> Bool +isClosedTypeFamilyInfo (ClosedTypeFamily {}) = True +isClosedTypeFamilyInfo _ = False -- | data family declaration isDataFamilyDecl :: TyClDecl name -> Bool -isDataFamilyDecl (FamDecl d) = fdFlavour d == DataFamily +isDataFamilyDecl (FamDecl (FamilyDecl { fdInfo = DataFamily })) = True isDataFamilyDecl _other = False + \end{code} Dealing with names @@ -528,11 +546,9 @@ tyFamInstDeclName = unLoc . tyFamInstDeclLName tyFamInstDeclLName :: OutputableBndr name => TyFamInstDecl name -> Located name -tyFamInstDeclLName (TyFamInstDecl { tfid_eqns = - (L _ (TyFamInstEqn { tfie_tycon = ln })) : _ }) - -- there may be more than one equation, but grab the name from the first +tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = + (L _ (TyFamInstEqn { tfie_tycon = ln })) }) = ln -tyFamInstDeclLName decl = pprPanic "tyFamInstDeclLName" (ppr decl) tyClDeclLName :: TyClDecl name -> Located name tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln @@ -598,17 +614,28 @@ instance OutputableBndr name <+> pprFundeps (map unLoc fds) instance (OutputableBndr name) => Outputable (FamilyDecl name) where - ppr (FamilyDecl { fdFlavour = flavour, fdLName = ltycon, + ppr (FamilyDecl { fdInfo = info, fdLName = ltycon, fdTyVars = tyvars, fdKindSig = mb_kind}) - = ppr flavour <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind + = vcat [ pprFlavour info <+> pp_vanilla_decl_head ltycon tyvars [] <+> pp_kind <+> pp_where + , nest 2 $ pp_eqns ] where pp_kind = case mb_kind of Nothing -> empty Just kind -> dcolon <+> ppr kind + (pp_where, pp_eqns) = case info of + ClosedTypeFamily eqns -> ( ptext (sLit "where") + , if null eqns + then ptext (sLit "..") + else vcat $ map ppr eqns ) + _ -> (empty, empty) + +pprFlavour :: FamilyInfo name -> SDoc +pprFlavour DataFamily = ptext (sLit "data family") +pprFlavour OpenTypeFamily = ptext (sLit "type family") +pprFlavour (ClosedTypeFamily {}) = ptext (sLit "type family") -instance Outputable FamilyFlavour where - ppr TypeFamily = ptext (sLit "type family") - ppr DataFamily = ptext (sLit "data family") +instance Outputable (FamilyInfo name) where + ppr = pprFlavour pp_vanilla_decl_head :: OutputableBndr name => Located name @@ -838,10 +865,9 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT { \begin{code} ----------------- Type synonym family instances ------------- --- See note [Family instance equation groups] type LTyFamInstEqn name = Located (TyFamInstEqn name) --- | One equation in a family instance declaration +-- | One equation in a type family instance declaration data TyFamInstEqn name = TyFamInstEqn { tfie_tycon :: Located name @@ -854,15 +880,10 @@ data TyFamInstEqn name type LTyFamInstDecl name = Located (TyFamInstDecl name) data TyFamInstDecl name = TyFamInstDecl - { tfid_eqns :: [LTyFamInstEqn name] -- ^ list of (possibly-overlapping) eqns - -- Always non-empty - , tfid_group :: Bool -- Was this declared with the "where" syntax? - , tfid_fvs :: NameSet } -- The group is type-checked as one, - -- so one NameSet will do - -- INVARIANT: tfid_group == False --> length tfid_eqns == 1 + { tfid_eqn :: LTyFamInstEqn name + , tfid_fvs :: NameSet } deriving( Typeable, Data ) - ----------------- Data family instances ------------- type LDataFamInstDecl name = Located (DataFamInstDecl name) @@ -925,24 +946,13 @@ tvs are fv(pat_tys), *including* ones that are already in scope so that we can compare the type patter in the 'instance' decl and in the associated 'type' decl -Note [Family instance equation groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A TyFamInstDecl contains a list of FamInstEqn's, one for each -equation defined in the instance group. For a standalone -instance declaration, this list contains exactly one element. -It is not possible for this list to have 0 elements -- -'type instance where' without anything else is not allowed. - \begin{code} instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where ppr = pprTyFamInstDecl TopLevel pprTyFamInstDecl :: OutputableBndr name => TopLevelFlag -> TyFamInstDecl name -> SDoc -pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_group = False, tfid_eqns = [eqn] }) +pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) = ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> (ppr eqn) -pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqns = eqns }) - = hang (ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> ptext (sLit "where")) - 2 (vcat (map ppr eqns)) ppr_instance_keyword :: TopLevelFlag -> SDoc ppr_instance_keyword TopLevel = ptext (sLit "instance") diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 3a8e433596..181b765eba 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -232,7 +232,7 @@ pprPatBndr var -- Print with type info if -dppr-debug is on parens (pprBndr LambdaBind var) -- Could pass the site to pprPat -- but is it worth it? else - ppr var + pprPrefixOcc var pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc pprParendLPat (L _ p) = pprParendPat p @@ -246,14 +246,14 @@ pprPat (VarPat var) = pprPatBndr var pprPat (WildPat _) = char '_' pprPat (LazyPat pat) = char '~' <> pprParendLPat pat pprPat (BangPat pat) = char '!' <> pprParendLPat pat -pprPat (AsPat name pat) = hcat [ppr name, char '@', pprParendLPat pat] +pprPat (AsPat name pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat pat] pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat] pprPat (ParPat pat) = parens (ppr pat) pprPat (ListPat pats _ _) = brackets (interpp'SP pats) pprPat (PArrPat pats _) = paBrackets (interpp'SP pats) pprPat (TuplePat pats bx _) = tupleParens (boxityNormalTupleSort bx) (interpp'SP pats) -pprPat (ConPatIn con details) = pprUserCon con details +pprPat (ConPatIn con details) = pprUserCon (unLoc con) details pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, pat_binds = binds, pat_args = details }) = getPprStyle $ \ sty -> -- Tiresome; in TcBinds.tcRhs we print out a @@ -262,7 +262,7 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, ppr con <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts)) , ppr binds]) <+> pprConArgs details - else pprUserCon con details + else pprUserCon (unLoc con) details pprPat (LitPat s) = ppr s pprPat (NPat l Nothing _) = ppr l @@ -273,9 +273,9 @@ pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty -pprUserCon :: (Outputable con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc -pprUserCon c (InfixCon p1 p2) = ppr p1 <+> ppr c <+> ppr p2 -pprUserCon c details = ppr c <+> pprConArgs details +pprUserCon :: (OutputableBndr con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc +pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 +pprUserCon c details = pprPrefixOcc c <+> pprConArgs details pprConArgs :: OutputableBndr id => HsConPatDetails id -> SDoc pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats) diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index d0d9e1a0a9..485cfc14e3 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -32,7 +32,7 @@ module HsTypes ( splitLHsInstDeclTy_maybe, splitHsClassTy_maybe, splitLHsClassTy_maybe, splitHsFunType, - splitHsAppTys, mkHsAppTys, mkHsOpTy, + splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy, -- Printing pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, @@ -47,6 +47,7 @@ import Name( Name ) import RdrName( RdrName ) import DataCon( HsBang(..) ) import Type +import TyCon ( Role(..) ) import HsDoc import BasicTypes import SrcLoc @@ -152,8 +153,8 @@ hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name] hsQTvBndrs = hsq_tvs data HsWithBndrs thing - = HsWB { hswb_cts :: thing -- Main payload (type or list of types) - , hswb_kvs :: [Name] -- Kind vars + = HsWB { hswb_cts :: thing -- Main payload (type or list of types) + , hswb_kvs :: [Name] -- Kind vars , hswb_tvs :: [Name] -- Type vars } deriving (Data, Typeable) @@ -179,20 +180,15 @@ instance OutputableBndr HsIPName where pprInfixOcc n = ppr n pprPrefixOcc n = ppr n - data HsTyVarBndr name - = UserTyVar -- No explicit kinding - name -- See Note [Printing KindedTyVars] - - | KindedTyVar - name - (LHsKind name) -- The user-supplied kind signature + = HsTyVarBndr name + (Maybe (LHsKind name)) -- See Note [Printing KindedTyVars] + (Maybe Role) -- *** NOTA BENE *** A "monotype" in a pragma can have -- for-alls in it, (mostly to do with dictionaries). These -- must be explicitly Kinded. deriving (Data, Typeable) - data HsType name = HsForAllTy HsExplicitFlag -- Renamer leaves this flag unchanged, to record the way -- the user wrote it originally, so that the printer can @@ -232,6 +228,9 @@ data HsType name | HsKindSig (LHsType name) -- (ty :: kind) (LHsKind name) -- A type with a kind signature + | HsRoleAnnot (LHsType name) -- ty@role, seen only right after parsing + Role + | HsQuasiQuoteTy (HsQuasiQuote name) | HsSpliceTy (HsSplice name) @@ -280,7 +279,7 @@ Note [HsForAllTy tyvar binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ After parsing: * Implicit => empty - Explicit => the varibles the user wrote + Explicit => the variables the user wrote After renaming * Implicit => the *type* variables free in the type @@ -421,8 +420,7 @@ hsExplicitTvs _ = [] --------------------- hsTyVarName :: HsTyVarBndr name -> name -hsTyVarName (UserTyVar n) = n -hsTyVarName (KindedTyVar n _) = n +hsTyVarName (HsTyVarBndr n _ _) = n hsLTyVarName :: LHsTyVarBndr name -> name hsLTyVarName = hsTyVarName . unLoc @@ -447,8 +445,23 @@ hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs) \begin{code} splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n]) splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as) +splitHsAppTys (L _ (HsParTy f)) as = splitHsAppTys f as splitHsAppTys f as = (f,as) +-- retrieve the name of the "head" of a nested type application +-- somewhat like splitHsAppTys, but a little more thorough +-- used to examine the result of a GADT-like datacon, so it doesn't handle +-- *all* cases (like lists, tuples, (~), etc.) +hsTyGetAppHead_maybe :: LHsType n -> Maybe (n, [LHsType n]) +hsTyGetAppHead_maybe = go [] + where + go tys (L _ (HsTyVar n)) = Just (n, tys) + go tys (L _ (HsAppTy l r)) = go (r : tys) l + go tys (L _ (HsOpTy l (_, L _ n) r)) = Just (n, l : r : tys) + go tys (L _ (HsParTy t)) = go tys t + go tys (L _ (HsKindSig t _)) = go tys t + go _ _ = Nothing + mkHsAppTys :: OutputableBndr n => LHsType n -> [LHsType n] -> HsType n mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty) mkHsAppTys fun_ty (arg_ty:arg_tys) @@ -528,8 +541,10 @@ instance (OutputableBndr name) => Outputable (LHsTyVarBndrs name) where = sep [ ifPprDebug $ braces (interppSP kvs), interppSP tvs ] instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where - ppr (UserTyVar name) = ppr name - ppr (KindedTyVar name kind) = parens $ hsep [ppr name, dcolon, ppr kind] + ppr (HsTyVarBndr n Nothing Nothing) = ppr n + ppr (HsTyVarBndr n (Just k) Nothing) = parens $ hsep [ppr n, dcolon, ppr k] + ppr (HsTyVarBndr n Nothing (Just r)) = ppr n <> char '@' <> ppr r + ppr (HsTyVarBndr n (Just k) (Just r)) = parens $ hsep [ppr n, dcolon, ppr k] <> char '@' <> ppr r instance (Outputable thing) => Outputable (HsWithBndrs thing) where ppr (HsWB { hswb_cts = ty }) = ppr ty @@ -621,6 +636,7 @@ ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (interpp'SP tys) HsUnboxedTuple -> UnboxedTuple _ -> BoxedTuple ppr_mono_ty _ (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppr kind) +ppr_mono_ty _ (HsRoleAnnot ty r) = ppr ty <> char '@' <> ppr r ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty pREC_TOP ty) ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec pREC_FUN (ppr n <+> dcolon <+> ppr_mono_lty pREC_TOP ty) diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 1fa949653e..267b2cac0e 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -271,7 +271,7 @@ mkHsString s = HsString (mkFastString s) ------------- userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)] -- Caller sets location -userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ] +userHsTyVarBndrs loc bndrs = [ L loc (HsTyVarBndr v Nothing Nothing) | v <- bndrs ] \end{code} diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 69e702bb20..c4c1bcd69e 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -2,7 +2,6 @@ -- (c) The University of Glasgow 2002-2006 -- -{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -O #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -24,21 +23,15 @@ import TyCon import DataCon (dataConName, dataConWorkId, dataConTyCon) import PrelInfo (wiredInThings, basicKnownKeyNames) import Id (idName, isDataConWorkId_maybe) -import CoreSyn (DFunArg(..)) -import Coercion (LeftOrRight(..)) import TysWiredIn import IfaceEnv import HscTypes import BasicTypes -import Annotations -import IfaceSyn import Module import Name -import Avail import DynFlags import UniqFM import UniqSupply -import CostCentre import Panic import Binary import SrcLoc @@ -414,153 +407,6 @@ data BinDictionary = BinDictionary { -- indexed by FastString } --- ----------------------------------------------------------------------------- --- All the binary instances - --- BasicTypes -{-! for Fixity derive: Binary !-} -{-! for FixityDirection derive: Binary !-} -{-! for Boxity derive: Binary !-} -{-! for StrictnessMark derive: Binary !-} -{-! for Activation derive: Binary !-} - --- Class -{-! for DefMeth derive: Binary !-} - --- HsTypes -{-! for HsPred derive: Binary !-} -{-! for HsType derive: Binary !-} -{-! for TupCon derive: Binary !-} -{-! for HsTyVarBndr derive: Binary !-} - --- HsCore -{-! for UfExpr derive: Binary !-} -{-! for UfConAlt derive: Binary !-} -{-! for UfBinding derive: Binary !-} -{-! for UfBinder derive: Binary !-} -{-! for HsIdInfo derive: Binary !-} -{-! for UfNote derive: Binary !-} - --- HsDecls -{-! for ConDetails derive: Binary !-} -{-! for BangType derive: Binary !-} - --- CostCentre -{-! for IsCafCC derive: Binary !-} -{-! for CostCentre derive: Binary !-} - - - --- --------------------------------------------------------------------------- --- Reading a binary interface into ParsedIface - -instance Binary ModIface where - put_ bh (ModIface { - mi_module = mod, - mi_boot = is_boot, - mi_iface_hash= iface_hash, - mi_mod_hash = mod_hash, - mi_flag_hash = flag_hash, - mi_orphan = orphan, - mi_finsts = hasFamInsts, - mi_deps = deps, - mi_usages = usages, - mi_exports = exports, - mi_exp_hash = exp_hash, - mi_used_th = used_th, - mi_fixities = fixities, - mi_warns = warns, - mi_anns = anns, - mi_decls = decls, - mi_insts = insts, - mi_fam_insts = fam_insts, - mi_rules = rules, - mi_orphan_hash = orphan_hash, - mi_vect_info = vect_info, - mi_hpc = hpc_info, - mi_trust = trust, - mi_trust_pkg = trust_pkg }) = do - put_ bh mod - put_ bh is_boot - put_ bh iface_hash - put_ bh mod_hash - put_ bh flag_hash - put_ bh orphan - put_ bh hasFamInsts - lazyPut bh deps - lazyPut bh usages - put_ bh exports - put_ bh exp_hash - put_ bh used_th - put_ bh fixities - lazyPut bh warns - lazyPut bh anns - put_ bh decls - put_ bh insts - put_ bh fam_insts - lazyPut bh rules - put_ bh orphan_hash - put_ bh vect_info - put_ bh hpc_info - put_ bh trust - put_ bh trust_pkg - - get bh = do - mod_name <- get bh - is_boot <- get bh - iface_hash <- get bh - mod_hash <- get bh - flag_hash <- get bh - orphan <- get bh - hasFamInsts <- get bh - deps <- lazyGet bh - usages <- {-# SCC "bin_usages" #-} lazyGet bh - exports <- {-# SCC "bin_exports" #-} get bh - exp_hash <- get bh - used_th <- get bh - fixities <- {-# SCC "bin_fixities" #-} get bh - warns <- {-# SCC "bin_warns" #-} lazyGet bh - anns <- {-# SCC "bin_anns" #-} lazyGet bh - decls <- {-# SCC "bin_tycldecls" #-} get bh - insts <- {-# SCC "bin_insts" #-} get bh - fam_insts <- {-# SCC "bin_fam_insts" #-} get bh - rules <- {-# SCC "bin_rules" #-} lazyGet bh - orphan_hash <- get bh - vect_info <- get bh - hpc_info <- get bh - trust <- get bh - trust_pkg <- get bh - return (ModIface { - mi_module = mod_name, - mi_boot = is_boot, - mi_iface_hash = iface_hash, - mi_mod_hash = mod_hash, - mi_flag_hash = flag_hash, - mi_orphan = orphan, - mi_finsts = hasFamInsts, - mi_deps = deps, - mi_usages = usages, - mi_exports = exports, - mi_exp_hash = exp_hash, - mi_used_th = used_th, - mi_anns = anns, - mi_fixities = fixities, - mi_warns = warns, - mi_decls = decls, - mi_globals = Nothing, - mi_insts = insts, - mi_fam_insts = fam_insts, - mi_rules = rules, - mi_orphan_hash = orphan_hash, - mi_vect_info = vect_info, - mi_hpc = hpc_info, - mi_trust = trust, - mi_trust_pkg = trust_pkg, - -- And build the cached values - mi_warn_fn = mkIfaceWarnCache warns, - mi_fix_fn = mkIfaceFixCache fixities, - mi_hash_fn = mkIfaceHashCache decls }) - getWayDescr :: DynFlags -> String getWayDescr dflags | platformUnregisterised (targetPlatform dflags) = 'u':tag @@ -568,926 +414,3 @@ getWayDescr dflags where tag = buildTag dflags -- if this is an unregisterised build, make sure our interfaces -- can't be used by a registerised build. - -------------------------------------------------------------------------- --- Types from: HscTypes -------------------------------------------------------------------------- - -instance Binary Dependencies where - put_ bh deps = do put_ bh (dep_mods deps) - put_ bh (dep_pkgs deps) - put_ bh (dep_orphs deps) - put_ bh (dep_finsts deps) - - get bh = do ms <- get bh - ps <- get bh - os <- get bh - fis <- get bh - return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, - dep_finsts = fis }) - -instance Binary AvailInfo where - put_ bh (Avail aa) = do - putByte bh 0 - put_ bh aa - put_ bh (AvailTC ab ac) = do - putByte bh 1 - put_ bh ab - put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Avail aa) - _ -> do ab <- get bh - ac <- get bh - return (AvailTC ab ac) - -instance Binary Usage where - put_ bh usg@UsagePackageModule{} = do - putByte bh 0 - put_ bh (usg_mod usg) - put_ bh (usg_mod_hash usg) - put_ bh (usg_safe usg) - - put_ bh usg@UsageHomeModule{} = do - putByte bh 1 - put_ bh (usg_mod_name usg) - put_ bh (usg_mod_hash usg) - put_ bh (usg_exports usg) - put_ bh (usg_entities usg) - put_ bh (usg_safe usg) - - put_ bh usg@UsageFile{} = do - putByte bh 2 - put_ bh (usg_file_path usg) - put_ bh (usg_mtime usg) - - get bh = do - h <- getByte bh - case h of - 0 -> do - nm <- get bh - mod <- get bh - safe <- get bh - return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe } - 1 -> do - nm <- get bh - mod <- get bh - exps <- get bh - ents <- get bh - safe <- get bh - return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, - usg_exports = exps, usg_entities = ents, usg_safe = safe } - 2 -> do - fp <- get bh - mtime <- get bh - return UsageFile { usg_file_path = fp, usg_mtime = mtime } - i -> error ("Binary.get(Usage): " ++ show i) - -instance Binary Warnings where - put_ bh NoWarnings = putByte bh 0 - put_ bh (WarnAll t) = do - putByte bh 1 - put_ bh t - put_ bh (WarnSome ts) = do - putByte bh 2 - put_ bh ts - - get bh = do - h <- getByte bh - case h of - 0 -> return NoWarnings - 1 -> do aa <- get bh - return (WarnAll aa) - _ -> do aa <- get bh - return (WarnSome aa) - -instance Binary WarningTxt where - put_ bh (WarningTxt w) = do - putByte bh 0 - put_ bh w - put_ bh (DeprecatedTxt d) = do - putByte bh 1 - put_ bh d - - get bh = do - h <- getByte bh - case h of - 0 -> do w <- get bh - return (WarningTxt w) - _ -> do d <- get bh - return (DeprecatedTxt d) - -------------------------------------------------------------------------- --- Types from: BasicTypes -------------------------------------------------------------------------- - -instance Binary Activation where - put_ bh NeverActive = do - putByte bh 0 - put_ bh AlwaysActive = do - putByte bh 1 - put_ bh (ActiveBefore aa) = do - putByte bh 2 - put_ bh aa - put_ bh (ActiveAfter ab) = do - putByte bh 3 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do return NeverActive - 1 -> do return AlwaysActive - 2 -> do aa <- get bh - return (ActiveBefore aa) - _ -> do ab <- get bh - return (ActiveAfter ab) - -instance Binary RuleMatchInfo where - put_ bh FunLike = putByte bh 0 - put_ bh ConLike = putByte bh 1 - get bh = do - h <- getByte bh - if h == 1 then return ConLike - else return FunLike - -instance Binary InlinePragma where - put_ bh (InlinePragma a b c d) = do - put_ bh a - put_ bh b - put_ bh c - put_ bh d - - get bh = do - a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (InlinePragma a b c d) - -instance Binary InlineSpec where - put_ bh EmptyInlineSpec = putByte bh 0 - put_ bh Inline = putByte bh 1 - put_ bh Inlinable = putByte bh 2 - put_ bh NoInline = putByte bh 3 - - get bh = do h <- getByte bh - case h of - 0 -> return EmptyInlineSpec - 1 -> return Inline - 2 -> return Inlinable - _ -> return NoInline - -instance Binary IfaceBang where - put_ bh IfNoBang = putByte bh 0 - put_ bh IfStrict = putByte bh 1 - put_ bh IfUnpack = putByte bh 2 - put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co - - get bh = do - h <- getByte bh - case h of - 0 -> do return IfNoBang - 1 -> do return IfStrict - 2 -> do return IfUnpack - _ -> do { a <- get bh; return (IfUnpackCo a) } - -instance Binary TupleSort where - put_ bh BoxedTuple = putByte bh 0 - put_ bh UnboxedTuple = putByte bh 1 - put_ bh ConstraintTuple = putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return BoxedTuple - 1 -> do return UnboxedTuple - _ -> do return ConstraintTuple - -instance Binary RecFlag where - put_ bh Recursive = do - putByte bh 0 - put_ bh NonRecursive = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return Recursive - _ -> do return NonRecursive - -instance Binary DefMethSpec where - put_ bh NoDM = putByte bh 0 - put_ bh VanillaDM = putByte bh 1 - put_ bh GenericDM = putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> return NoDM - 1 -> return VanillaDM - _ -> return GenericDM - -instance Binary FixityDirection where - put_ bh InfixL = do - putByte bh 0 - put_ bh InfixR = do - putByte bh 1 - put_ bh InfixN = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return InfixL - 1 -> do return InfixR - _ -> do return InfixN - -instance Binary Fixity where - put_ bh (Fixity aa ab) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (Fixity aa ab) - - -------------------------------------------------------------------------- --- Types from: CostCentre -------------------------------------------------------------------------- - -instance Binary IsCafCC where - put_ bh CafCC = do - putByte bh 0 - put_ bh NotCafCC = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return CafCC - _ -> do return NotCafCC - -instance Binary CostCentre where - put_ bh (NormalCC aa ab ac _ad ae) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh ae - put_ bh (AllCafsCC ae _af) = do - putByte bh 1 - put_ bh ae - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - ac <- get bh - ae <- get bh - return (NormalCC aa ab ac noSrcSpan ae) - _ -> do ae <- get bh - return (AllCafsCC ae noSrcSpan) - - -- We ignore the SrcSpans in CostCentres when we serialise them, - -- and set the SrcSpans to noSrcSpan when deserialising. This is - -- ok, because we only need the SrcSpan when declaring the - -- CostCentre in the original module, it is not used by importing - -- modules. - -------------------------------------------------------------------------- --- IfaceTypes and friends -------------------------------------------------------------------------- - -instance Binary IfaceBndr where - put_ bh (IfaceIdBndr aa) = do - putByte bh 0 - put_ bh aa - put_ bh (IfaceTvBndr ab) = do - putByte bh 1 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (IfaceIdBndr aa) - _ -> do ab <- get bh - return (IfaceTvBndr ab) - -instance Binary IfaceLetBndr where - put_ bh (IfLetBndr a b c) = do - put_ bh a - put_ bh b - put_ bh c - get bh = do a <- get bh - b <- get bh - c <- get bh - return (IfLetBndr a b c) - -instance Binary IfaceType where - put_ bh (IfaceForAllTy aa ab) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh (IfaceTyVar ad) = do - putByte bh 1 - put_ bh ad - put_ bh (IfaceAppTy ae af) = do - putByte bh 2 - put_ bh ae - put_ bh af - put_ bh (IfaceFunTy ag ah) = do - putByte bh 3 - put_ bh ag - put_ bh ah - put_ bh (IfaceCoConApp cc tys) - = do { putByte bh 4; put_ bh cc; put_ bh tys } - put_ bh (IfaceTyConApp tc tys) - = do { putByte bh 5; put_ bh tc; put_ bh tys } - - put_ bh (IfaceLitTy n) - = do { putByte bh 30; put_ bh n } - - - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - ab <- get bh - return (IfaceForAllTy aa ab) - 1 -> do ad <- get bh - return (IfaceTyVar ad) - 2 -> do ae <- get bh - af <- get bh - return (IfaceAppTy ae af) - 3 -> do ag <- get bh - ah <- get bh - return (IfaceFunTy ag ah) - 4 -> do { cc <- get bh; tys <- get bh - ; return (IfaceCoConApp cc tys) } - 5 -> do { tc <- get bh; tys <- get bh - ; return (IfaceTyConApp tc tys) } - - 30 -> do n <- get bh - return (IfaceLitTy n) - - _ -> panic ("get IfaceType " ++ show h) - -instance Binary IfaceTyLit where - put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n - put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n - - get bh = - do tag <- getByte bh - case tag of - 1 -> do { n <- get bh - ; return (IfaceNumTyLit n) } - 2 -> do { n <- get bh - ; return (IfaceStrTyLit n) } - _ -> panic ("get IfaceTyLit " ++ show tag) - -instance Binary IfaceTyCon where - put_ bh (IfaceTc ext) = put_ bh ext - get bh = liftM IfaceTc (get bh) - -instance Binary LeftOrRight where - put_ bh CLeft = putByte bh 0 - put_ bh CRight = putByte bh 1 - - get bh = do { h <- getByte bh - ; case h of - 0 -> return CLeft - _ -> return CRight } - -instance Binary IfaceCoCon where - put_ bh (IfaceCoAx n ind) = do { putByte bh 0; put_ bh n; put_ bh ind } - put_ bh IfaceReflCo = putByte bh 1 - put_ bh IfaceUnsafeCo = putByte bh 2 - put_ bh IfaceSymCo = putByte bh 3 - put_ bh IfaceTransCo = putByte bh 4 - put_ bh IfaceInstCo = putByte bh 5 - put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d } - put_ bh (IfaceLRCo lr) = do { putByte bh 7; put_ bh lr } - - get bh = do - h <- getByte bh - case h of - 0 -> do { n <- get bh; ind <- get bh; return (IfaceCoAx n ind) } - 1 -> return IfaceReflCo - 2 -> return IfaceUnsafeCo - 3 -> return IfaceSymCo - 4 -> return IfaceTransCo - 5 -> return IfaceInstCo - 6 -> do { d <- get bh; return (IfaceNthCo d) } - 7 -> do { lr <- get bh; return (IfaceLRCo lr) } - _ -> panic ("get IfaceCoCon " ++ show h) - -------------------------------------------------------------------------- --- IfaceExpr and friends -------------------------------------------------------------------------- - -instance Binary IfaceExpr where - put_ bh (IfaceLcl aa) = do - putByte bh 0 - put_ bh aa - put_ bh (IfaceType ab) = do - putByte bh 1 - put_ bh ab - put_ bh (IfaceCo ab) = do - putByte bh 2 - put_ bh ab - put_ bh (IfaceTuple ac ad) = do - putByte bh 3 - put_ bh ac - put_ bh ad - put_ bh (IfaceLam ae af) = do - putByte bh 4 - put_ bh ae - put_ bh af - put_ bh (IfaceApp ag ah) = do - putByte bh 5 - put_ bh ag - put_ bh ah - put_ bh (IfaceCase ai aj ak) = do - putByte bh 6 - put_ bh ai - put_ bh aj - put_ bh ak - put_ bh (IfaceLet al am) = do - putByte bh 7 - put_ bh al - put_ bh am - put_ bh (IfaceTick an ao) = do - putByte bh 8 - put_ bh an - put_ bh ao - put_ bh (IfaceLit ap) = do - putByte bh 9 - put_ bh ap - put_ bh (IfaceFCall as at) = do - putByte bh 10 - put_ bh as - put_ bh at - put_ bh (IfaceExt aa) = do - putByte bh 11 - put_ bh aa - put_ bh (IfaceCast ie ico) = do - putByte bh 12 - put_ bh ie - put_ bh ico - put_ bh (IfaceECase a b) = do - putByte bh 13 - put_ bh a - put_ bh b - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (IfaceLcl aa) - 1 -> do ab <- get bh - return (IfaceType ab) - 2 -> do ab <- get bh - return (IfaceCo ab) - 3 -> do ac <- get bh - ad <- get bh - return (IfaceTuple ac ad) - 4 -> do ae <- get bh - af <- get bh - return (IfaceLam ae af) - 5 -> do ag <- get bh - ah <- get bh - return (IfaceApp ag ah) - 6 -> do ai <- get bh - aj <- get bh - ak <- get bh - return (IfaceCase ai aj ak) - 7 -> do al <- get bh - am <- get bh - return (IfaceLet al am) - 8 -> do an <- get bh - ao <- get bh - return (IfaceTick an ao) - 9 -> do ap <- get bh - return (IfaceLit ap) - 10 -> do as <- get bh - at <- get bh - return (IfaceFCall as at) - 11 -> do aa <- get bh - return (IfaceExt aa) - 12 -> do ie <- get bh - ico <- get bh - return (IfaceCast ie ico) - 13 -> do a <- get bh - b <- get bh - return (IfaceECase a b) - _ -> panic ("get IfaceExpr " ++ show h) - -instance Binary IfaceConAlt where - put_ bh IfaceDefault = putByte bh 0 - put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa - put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> return IfaceDefault - 1 -> get bh >>= (return . IfaceDataAlt) - _ -> get bh >>= (return . IfaceLitAlt) - -instance Binary IfaceBinding where - put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab - put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac - get bh = do - h <- getByte bh - case h of - 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) } - _ -> do { ac <- get bh; return (IfaceRec ac) } - -instance Binary IfaceIdDetails where - put_ bh IfVanillaId = putByte bh 0 - put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b - put_ bh (IfDFunId n) = do { putByte bh 2; put_ bh n } - get bh = do - h <- getByte bh - case h of - 0 -> return IfVanillaId - 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } - _ -> do { n <- get bh; return (IfDFunId n) } - -instance Binary (DFunArg IfaceExpr) where - put_ bh (DFunPolyArg e) = putByte bh 0 >> put_ bh e - put_ bh (DFunLamArg i) = putByte bh 1 >> put_ bh i - get bh = do { h <- getByte bh - ; case h of - 0 -> do { a <- get bh; return (DFunPolyArg a) } - _ -> do { a <- get bh; return (DFunLamArg a) } } - -instance Binary IfaceIdInfo where - put_ bh NoInfo = putByte bh 0 - put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut - - get bh = do - h <- getByte bh - case h of - 0 -> return NoInfo - _ -> lazyGet bh >>= (return . HasInfo) -- NB lazyGet - -instance Binary IfaceInfoItem where - put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa - put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab - put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad - put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad - put_ bh HsNoCafRefs = putByte bh 4 - get bh = do - h <- getByte bh - case h of - 0 -> get bh >>= (return . HsArity) - 1 -> get bh >>= (return . HsStrictness) - 2 -> do lb <- get bh - ad <- get bh - return (HsUnfold lb ad) - 3 -> get bh >>= (return . HsInline) - _ -> return HsNoCafRefs - -instance Binary IfaceUnfolding where - put_ bh (IfCoreUnfold s e) = do - putByte bh 0 - put_ bh s - put_ bh e - put_ bh (IfInlineRule a b c d) = do - putByte bh 1 - put_ bh a - put_ bh b - put_ bh c - put_ bh d - put_ bh (IfWrapper e) = do - putByte bh 2 - put_ bh e - put_ bh (IfDFunUnfold as) = do - putByte bh 3 - put_ bh as - put_ bh (IfCompulsory e) = do - putByte bh 4 - put_ bh e - get bh = do - h <- getByte bh - case h of - 0 -> do s <- get bh - e <- get bh - return (IfCoreUnfold s e) - 1 -> do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (IfInlineRule a b c d) - 2 -> do e <- get bh - return (IfWrapper e) - 3 -> do as <- get bh - return (IfDFunUnfold as) - _ -> do e <- get bh - return (IfCompulsory e) - -instance Binary IfaceTickish where - put_ bh (IfaceHpcTick m ix) = do - putByte bh 0 - put_ bh m - put_ bh ix - put_ bh (IfaceSCC cc tick push) = do - putByte bh 1 - put_ bh cc - put_ bh tick - put_ bh push - - get bh = do - h <- getByte bh - case h of - 0 -> do m <- get bh - ix <- get bh - return (IfaceHpcTick m ix) - 1 -> do cc <- get bh - tick <- get bh - push <- get bh - return (IfaceSCC cc tick push) - _ -> panic ("get IfaceTickish " ++ show h) - -------------------------------------------------------------------------- --- IfaceDecl and friends -------------------------------------------------------------------------- - --- A bit of magic going on here: there's no need to store the OccName --- for a decl on the disk, since we can infer the namespace from the --- context; however it is useful to have the OccName in the IfaceDecl --- to avoid re-building it in various places. So we build the OccName --- when de-serialising. - -instance Binary IfaceDecl where - put_ bh (IfaceId name ty details idinfo) = do - putByte bh 0 - put_ bh (occNameFS name) - put_ bh ty - put_ bh details - put_ bh idinfo - - put_ _ (IfaceForeign _ _) = - error "Binary.put_(IfaceDecl): IfaceForeign" - - put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do - putByte bh 2 - put_ bh (occNameFS a1) - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh a9 - - put_ bh (IfaceSyn a1 a2 a3 a4) = do - putByte bh 3 - put_ bh (occNameFS a1) - put_ bh a2 - put_ bh a3 - put_ bh a4 - - put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do - putByte bh 4 - put_ bh a1 - put_ bh (occNameFS a2) - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - - put_ bh (IfaceAxiom a1 a2 a3) = do - putByte bh 5 - put_ bh (occNameFS a1) - put_ bh a2 - put_ bh a3 - - get bh = do - h <- getByte bh - case h of - 0 -> do name <- get bh - ty <- get bh - details <- get bh - idinfo <- get bh - occ <- return $! mkOccNameFS varName name - return (IfaceId occ ty details idinfo) - 1 -> error "Binary.get(TyClDecl): ForeignType" - 2 -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - a9 <- get bh - occ <- return $! mkOccNameFS tcName a1 - return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9) - 3 -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - occ <- return $! mkOccNameFS tcName a1 - return (IfaceSyn occ a2 a3 a4) - 4 -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - occ <- return $! mkOccNameFS clsName a2 - return (IfaceClass a1 occ a3 a4 a5 a6 a7) - _ -> do a1 <- get bh - a2 <- get bh - a3 <- get bh - occ <- return $! mkOccNameFS tcName a1 - return (IfaceAxiom occ a2 a3) - -instance Binary IfaceAxBranch where - put_ bh (IfaceAxBranch a1 a2 a3) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - return (IfaceAxBranch a1 a2 a3) - -instance Binary ty => Binary (SynTyConRhs ty) where - put_ bh (SynFamilyTyCon a b) = putByte bh 0 >> put_ bh a >> put_ bh b - put_ bh (SynonymTyCon ty) = putByte bh 1 >> put_ bh ty - - get bh = do { h <- getByte bh - ; case h of - 0 -> do { a <- get bh - ; b <- get bh - ; return (SynFamilyTyCon a b) } - _ -> do { ty <- get bh - ; return (SynonymTyCon ty) } } - -instance Binary IfaceClsInst where - put_ bh (IfaceClsInst cls tys dfun flag orph) = do - put_ bh cls - put_ bh tys - put_ bh dfun - put_ bh flag - put_ bh orph - get bh = do - cls <- get bh - tys <- get bh - dfun <- get bh - flag <- get bh - orph <- get bh - return (IfaceClsInst cls tys dfun flag orph) - -instance Binary IfaceFamInst where - put_ bh (IfaceFamInst fam group tys name orph) = do - put_ bh fam - put_ bh group - put_ bh tys - put_ bh name - put_ bh orph - get bh = do - fam <- get bh - group <- get bh - tys <- get bh - name <- get bh - orph <- get bh - return (IfaceFamInst fam group tys name orph) - -instance Binary OverlapFlag where - put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b - put_ bh (OverlapOk b) = putByte bh 1 >> put_ bh b - put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b - get bh = do - h <- getByte bh - b <- get bh - case h of - 0 -> return $ NoOverlap b - 1 -> return $ OverlapOk b - 2 -> return $ Incoherent b - _ -> panic ("get OverlapFlag " ++ show h) - -instance Binary IfaceConDecls where - put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d - put_ bh IfDataFamTyCon = putByte bh 1 - put_ bh (IfDataTyCon cs) = putByte bh 2 >> put_ bh cs - put_ bh (IfNewTyCon c) = putByte bh 3 >> put_ bh c - get bh = do - h <- getByte bh - case h of - 0 -> get bh >>= (return . IfAbstractTyCon) - 1 -> return IfDataFamTyCon - 2 -> get bh >>= (return . IfDataTyCon) - _ -> get bh >>= (return . IfNewTyCon) - -instance Binary IfaceConDecl where - put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh a9 - put_ bh a10 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - a9 <- get bh - a10 <- get bh - return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) - -instance Binary IfaceAT where - put_ bh (IfaceAT dec defs) = do - put_ bh dec - put_ bh defs - get bh = do - dec <- get bh - defs <- get bh - return (IfaceAT dec defs) - -instance Binary IfaceClassOp where - put_ bh (IfaceClassOp n def ty) = do - put_ bh (occNameFS n) - put_ bh def - put_ bh ty - get bh = do - n <- get bh - def <- get bh - ty <- get bh - occ <- return $! mkOccNameFS varName n - return (IfaceClassOp occ def ty) - -instance Binary IfaceRule where - put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) - -instance Binary IfaceAnnotation where - put_ bh (IfaceAnnotation a1 a2) = do - put_ bh a1 - put_ bh a2 - get bh = do - a1 <- get bh - a2 <- get bh - return (IfaceAnnotation a1 a2) - -instance Binary name => Binary (AnnTarget name) where - put_ bh (NamedTarget a) = do - putByte bh 0 - put_ bh a - put_ bh (ModuleTarget a) = do - putByte bh 1 - put_ bh a - get bh = do - h <- getByte bh - case h of - 0 -> get bh >>= (return . NamedTarget) - _ -> get bh >>= (return . ModuleTarget) - -instance Binary IfaceVectInfo where - put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - return (IfaceVectInfo a1 a2 a3 a4 a5) - -instance Binary IfaceTrustInfo where - put_ bh iftrust = putByte bh $ trustInfoToNum iftrust - get bh = getByte bh >>= (return . numToTrustInfo) - diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index d5e4a4a62e..20aea22e47 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -46,13 +46,13 @@ import Outputable \begin{code} ------------------------------------------------------ -buildSynTyCon :: Name -> [TyVar] - -> SynTyConRhs Type +buildSynTyCon :: Name -> [TyVar] -> [Role] + -> SynTyConRhs -> Kind -- ^ Kind of the RHS -> TyConParent -> TcRnIf m n TyCon -buildSynTyCon tc_name tvs rhs rhs_kind parent - = return (mkSynTyCon tc_name kind tvs rhs parent) +buildSynTyCon tc_name tvs roles rhs rhs_kind parent + = return (mkSynTyCon tc_name kind tvs roles rhs parent) where kind = mkPiKinds tvs rhs_kind @@ -80,7 +80,7 @@ mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs -- because the latter is part of a knot, whereas the former is not. mkNewTyConRhs tycon_name tycon con = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc - ; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_rhs + ; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_roles etad_rhs ; traceIf (text "mkNewTyConRhs" <+> ppr co_tycon) ; return (NewTyCon { data_con = con, nt_rhs = rhs_ty, @@ -90,6 +90,7 @@ mkNewTyConRhs tycon_name tycon con -- for nt_co, or uses explicit coercions otherwise where tvs = tyConTyVars tycon + roles = tyConRoles tycon inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs) rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty -- Instantiate the data con with the @@ -101,20 +102,22 @@ mkNewTyConRhs tycon_name tycon con -- has a single argument (Foo a) that is a *type class*, so -- dataConInstOrigArgTys returns []. - etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can - etad_rhs :: Type -- return a TyCon without pulling on rhs_ty - -- See Note [Tricky iface loop] in LoadIface - (etad_tvs, etad_rhs) = eta_reduce (reverse tvs) rhs_ty + etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can + etad_roles :: [Role] -- return a TyCon without pulling on rhs_ty + etad_rhs :: Type -- See Note [Tricky iface loop] in LoadIface + (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty - eta_reduce :: [TyVar] -- Reversed - -> Type -- Rhs type - -> ([TyVar], Type) -- Eta-reduced version (tyvars in normal order) - eta_reduce (a:as) ty | Just (fun, arg) <- splitAppTy_maybe ty, - Just tv <- getTyVar_maybe arg, - tv == a, - not (a `elemVarSet` tyVarsOfType fun) - = eta_reduce as fun - eta_reduce tvs ty = (reverse tvs, ty) + eta_reduce :: [TyVar] -- Reversed + -> [Role] -- also reversed + -> Type -- Rhs type + -> ([TyVar], [Role], Type) -- Eta-reduced version + -- (tyvars in normal order) + eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty, + Just tv <- getTyVar_maybe arg, + tv == a, + not (a `elemVarSet` tyVarsOfType fun) + = eta_reduce as rs fun + eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty) ------------------------------------------------------ @@ -185,14 +188,14 @@ type TcMethInfo = (Name, DefMethSpec, Type) buildClass :: Bool -- True <=> do not include unfoldings -- on dict selectors -- Used when importing a class without -O - -> Name -> [TyVar] -> ThetaType + -> Name -> [TyVar] -> [Role] -> ThetaType -> [FunDep TyVar] -- Functional dependencies -> [ClassATItem] -- Associated types -> [TcMethInfo] -- Method info -> RecFlag -- Info for type constructor -> TcRnIf m n Class -buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec +buildClass no_unf tycon_name tvs roles sc_theta fds at_items sig_stuff tc_isrec = fixM $ \ rec_clas -> -- Only name generation inside loop do { traceIf (text "buildClass") ; dflags <- getDynFlags @@ -255,7 +258,7 @@ buildClass no_unf tycon_name tvs sc_theta fds at_items sig_stuff tc_isrec ; let { clas_kind = mkPiKinds tvs constraintKind - ; tycon = mkClassTyCon tycon_name clas_kind tvs + ; tycon = mkClassTyCon tycon_name clas_kind tvs roles rhs rec_clas tc_isrec -- A class can be recursive, and in the case of newtypes -- this matters. For example diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index 20a21c3733..0441fdbf41 100644 --- a/compiler/iface/IfaceEnv.lhs +++ b/compiler/iface/IfaceEnv.lhs @@ -55,10 +55,27 @@ import Data.IORef ( atomicModifyIORef, readIORef ) %* * %********************************************************* +Note [The Name Cache] +~~~~~~~~~~~~~~~~~~~~~ +The Name Cache makes sure that, during any invovcation of GHC, each +External Name "M.x" has one, and only one globally-agreed Unique. + +* The first time we come across M.x we make up a Unique and record that + association in the Name Cache. + +* When we come across "M.x" again, we look it up in the Name Cache, + and get a hit. + +The functions newGlobalBinder, allocateGlobalBinder do the main work. +When you make an External name, you should probably be calling one +of them. + + \begin{code} newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name -- Used for source code and interface files, to make the -- Name for a thing, given its Module and OccName +-- See Note [The Name Cache] -- -- The cache may already already have a binding for this thing, -- because we may have seen an occurrence before, but now is the @@ -74,6 +91,7 @@ allocateGlobalBinder :: NameCache -> Module -> OccName -> SrcSpan -> (NameCache, Name) +-- See Note [The Name Cache] allocateGlobalBinder name_supply mod occ loc = case lookupOrigNameCache (nsNames name_supply) mod occ of -- A hit in the cache! We are at the binding site of the name. @@ -171,6 +189,8 @@ lookupOrig mod occ %* * %************************************************************************ +See Note [The Name Cache] above. + \begin{code} lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name lookupOrigNameCache _ mod occ diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index dbe1dca191..8dc4188bb9 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -14,7 +14,7 @@ module IfaceSyn ( module IfaceType, - IfaceDecl(..), IfaceClassOp(..), IfaceAT(..), + IfaceDecl(..), IfaceSynTyConRhs(..), IfaceClassOp(..), IfaceAT(..), IfaceConDecl(..), IfaceConDecls(..), IfaceExpr(..), IfaceAlt, IfaceLetBndr(..), IfaceBinding(..), IfaceConAlt(..), @@ -36,14 +36,13 @@ module IfaceSyn ( #include "HsVersions.h" -import TyCon( SynTyConRhs(..) ) import IfaceType -import CoreSyn( DFunArg, dfunArgExprs ) import PprCore() -- Printing DFunArgs import Demand import Annotations import Class import NameSet +import CoAxiom ( BranchIndex, Role ) import Name import CostCentre import Literal @@ -57,6 +56,7 @@ import TysWiredIn ( eqTyConName ) import Fingerprint import Binary +import Control.Monad import System.IO.Unsafe infixl 3 &&& @@ -79,6 +79,7 @@ data IfaceDecl | IfaceData { ifName :: OccName, -- Type constructor ifCType :: Maybe CType, -- C type for CAPI FFI ifTyVars :: [IfaceTvBndr], -- Type variables + ifRoles :: [Role], -- Roles ifCtxt :: IfaceContext, -- The "stupid theta" ifCons :: IfaceConDecls, -- Includes new/data/data family info ifRec :: RecFlag, -- Recursive or not? @@ -91,12 +92,14 @@ data IfaceDecl | IfaceSyn { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables + ifRoles :: [Role], -- Roles ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon) - ifSynRhs :: SynTyConRhs IfaceType } + ifSynRhs :: IfaceSynTyConRhs } | IfaceClass { ifCtxt :: IfaceContext, -- Context... ifName :: OccName, -- Name of the class TyCon ifTyVars :: [IfaceTvBndr], -- Type variables + ifRoles :: [Role], -- Roles ifFDs :: [FunDep FastString], -- Functional dependencies ifATs :: [IfaceAT], -- Associated type families ifSigs :: [IfaceClassOp], -- Method signatures @@ -106,6 +109,7 @@ data IfaceDecl | IfaceAxiom { ifName :: OccName, -- Axiom name ifTyCon :: IfaceTyCon, -- LHS TyCon + ifRole :: Role, -- Role of axiom ifAxBranches :: [IfaceAxBranch] -- Branches } @@ -113,23 +117,205 @@ data IfaceDecl -- beyond .NET ifExtName :: Maybe FastString } +-- A bit of magic going on here: there's no need to store the OccName +-- for a decl on the disk, since we can infer the namespace from the +-- context; however it is useful to have the OccName in the IfaceDecl +-- to avoid re-building it in various places. So we build the OccName +-- when de-serialising. + +instance Binary IfaceDecl where + put_ bh (IfaceId name ty details idinfo) = do + putByte bh 0 + put_ bh (occNameFS name) + put_ bh ty + put_ bh details + put_ bh idinfo + + put_ _ (IfaceForeign _ _) = + error "Binary.put_(IfaceDecl): IfaceForeign" + + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do + putByte bh 2 + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + put_ bh a10 + + put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do + putByte bh 3 + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + + put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8) = do + putByte bh 4 + put_ bh a1 + put_ bh (occNameFS a2) + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + + put_ bh (IfaceAxiom a1 a2 a3 a4) = do + putByte bh 5 + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + put_ bh a4 + + get bh = do + h <- getByte bh + case h of + 0 -> do name <- get bh + ty <- get bh + details <- get bh + idinfo <- get bh + occ <- return $! mkOccNameFS varName name + return (IfaceId occ ty details idinfo) + 1 -> error "Binary.get(TyClDecl): ForeignType" + 2 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + a10 <- get bh + occ <- return $! mkOccNameFS tcName a1 + return (IfaceData occ a2 a3 a4 a5 a6 a7 a8 a9 a10) + 3 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + occ <- return $! mkOccNameFS tcName a1 + return (IfaceSyn occ a2 a3 a4 a5) + 4 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + occ <- return $! mkOccNameFS clsName a2 + return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8) + _ -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + occ <- return $! mkOccNameFS tcName a1 + return (IfaceAxiom occ a2 a3 a4) + +data IfaceSynTyConRhs + = IfaceOpenSynFamilyTyCon + | IfaceClosedSynFamilyTyCon IfExtName -- name of associated axiom + | IfaceAbstractClosedSynFamilyTyCon + | IfaceSynonymTyCon IfaceType + +instance Binary IfaceSynTyConRhs where + put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0 + put_ bh (IfaceClosedSynFamilyTyCon ax) = putByte bh 1 >> put_ bh ax + put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2 + put_ bh (IfaceSynonymTyCon ty) = putByte bh 3 >> put_ bh ty + + get bh = do { h <- getByte bh + ; case h of + 0 -> return IfaceOpenSynFamilyTyCon + 1 -> do { ax <- get bh + ; return (IfaceClosedSynFamilyTyCon ax) } + 2 -> return IfaceAbstractClosedSynFamilyTyCon + _ -> do { ty <- get bh + ; return (IfaceSynonymTyCon ty) } } + data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType -- Nothing => no default method -- Just False => ordinary polymorphic default method -- Just True => generic default method +instance Binary IfaceClassOp where + put_ bh (IfaceClassOp n def ty) = do + put_ bh (occNameFS n) + put_ bh def + put_ bh ty + get bh = do + n <- get bh + def <- get bh + ty <- get bh + occ <- return $! mkOccNameFS varName n + return (IfaceClassOp occ def ty) + data IfaceAT = IfaceAT IfaceDecl [IfaceAxBranch] -- Nothing => no default associated type instance -- Just ds => default associated type instance from these templates +instance Binary IfaceAT where + put_ bh (IfaceAT dec defs) = do + put_ bh dec + put_ bh defs + get bh = do + dec <- get bh + defs <- get bh + return (IfaceAT dec defs) + instance Outputable IfaceAxBranch where - ppr (IfaceAxBranch { ifaxbTyVars = tvs, ifaxbLHS = pat_tys, ifaxbRHS = ty }) - = ppr tvs <+> hsep (map ppr pat_tys) <+> char '=' <+> ppr ty + ppr = pprAxBranch Nothing + +pprAxBranch :: Maybe IfaceTyCon -> IfaceAxBranch -> SDoc +pprAxBranch mtycon (IfaceAxBranch { ifaxbTyVars = tvs + , ifaxbLHS = pat_tys + , ifaxbRHS = ty + , ifaxbIncomps = incomps }) + = ppr tvs <+> ppr_lhs <+> char '=' <+> ppr ty $+$ + nest 4 maybe_incomps + where + ppr_lhs + | Just tycon <- mtycon + = ppr (IfaceTyConApp tycon pat_tys) + | otherwise + = hsep (map ppr pat_tys) + + maybe_incomps + | [] <- incomps + = empty + + | otherwise + = parens (ptext (sLit "incompatible indices:") <+> ppr incomps) -- this is just like CoAxBranch -data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] - , ifaxbLHS :: [IfaceType] - , ifaxbRHS :: IfaceType } +data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] + , ifaxbLHS :: [IfaceType] + , ifaxbRoles :: [Role] + , ifaxbRHS :: IfaceType + , ifaxbIncomps :: [BranchIndex] } + -- See Note [Storing compatibility] in CoAxiom + +instance Binary IfaceAxBranch where + put_ bh (IfaceAxBranch a1 a2 a3 a4 a5) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + return (IfaceAxBranch a1 a2 a3 a4 a5) data IfaceConDecls = IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon @@ -137,6 +323,19 @@ data IfaceConDecls | IfDataTyCon [IfaceConDecl] -- Data type decls | IfNewTyCon IfaceConDecl -- Newtype decls +instance Binary IfaceConDecls where + put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d + put_ bh IfDataFamTyCon = putByte bh 1 + put_ bh (IfDataTyCon cs) = putByte bh 2 >> put_ bh cs + put_ bh (IfNewTyCon c) = putByte bh 3 >> put_ bh c + get bh = do + h <- getByte bh + case h of + 0 -> liftM IfAbstractTyCon $ get bh + 1 -> return IfDataFamTyCon + 2 -> liftM IfDataTyCon $ get bh + _ -> liftM IfNewTyCon $ get bh + visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] visibleIfConDecls (IfAbstractTyCon {}) = [] visibleIfConDecls IfDataFamTyCon = [] @@ -150,16 +349,55 @@ data IfaceConDecl ifConInfix :: Bool, -- True <=> declared infix ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars ifConExTvs :: [IfaceTvBndr], -- Existential tyvars - ifConEqSpec :: [(OccName,IfaceType)], -- Equality contraints + ifConEqSpec :: [(OccName,IfaceType)], -- Equality constraints ifConCtxt :: IfaceContext, -- Non-stupid context ifConArgTys :: [IfaceType], -- Arg types ifConFields :: [OccName], -- ...ditto... (field labels) ifConStricts :: [IfaceBang]} -- Empty (meaning all lazy), -- or 1-1 corresp with arg tys +instance Binary IfaceConDecl where + put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + put_ bh a10 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + a10 <- get bh + return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) + data IfaceBang = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion +instance Binary IfaceBang where + put_ bh IfNoBang = putByte bh 0 + put_ bh IfStrict = putByte bh 1 + put_ bh IfUnpack = putByte bh 2 + put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co + + get bh = do + h <- getByte bh + case h of + 0 -> do return IfNoBang + 1 -> do return IfStrict + 2 -> do return IfUnpack + _ -> do { a <- get bh; return (IfUnpackCo a) } + data IfaceClsInst = IfaceClsInst { ifInstCls :: IfExtName, -- See comments with ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst @@ -173,17 +411,43 @@ data IfaceClsInst -- If this instance decl is *used*, we'll record a usage on the dfun; -- and if the head does not change it won't be used if it wasn't before +instance Binary IfaceClsInst where + put_ bh (IfaceClsInst cls tys dfun flag orph) = do + put_ bh cls + put_ bh tys + put_ bh dfun + put_ bh flag + put_ bh orph + get bh = do + cls <- get bh + tys <- get bh + dfun <- get bh + flag <- get bh + orph <- get bh + return (IfaceClsInst cls tys dfun flag orph) + -- The ifFamInstTys field of IfaceFamInst contains a list of the rough --- match types, one per branch... but each "rough match types" is itself --- a list of Maybe IfaceTyCon. So, we get [[Maybe IfaceTyCon]]. +-- match types data IfaceFamInst - = IfaceFamInst { ifFamInstFam :: IfExtName -- Family name - , ifFamInstGroup :: Bool -- Is this a group? - , ifFamInstTys :: [[Maybe IfaceTyCon]] -- See above - , ifFamInstAxiom :: IfExtName -- The axiom - , ifFamInstOrph :: Maybe OccName -- Just like IfaceClsInst + = IfaceFamInst { ifFamInstFam :: IfExtName -- Family name + , ifFamInstTys :: [Maybe IfaceTyCon] -- See above + , ifFamInstAxiom :: IfExtName -- The axiom + , ifFamInstOrph :: Maybe OccName -- Just like IfaceClsInst } +instance Binary IfaceFamInst where + put_ bh (IfaceFamInst fam tys name orph) = do + put_ bh fam + put_ bh tys + put_ bh name + put_ bh orph + get bh = do + fam <- get bh + tys <- get bh + name <- get bh + orph <- get bh + return (IfaceFamInst fam tys name orph) + data IfaceRule = IfaceRule { ifRuleName :: RuleName, @@ -196,12 +460,42 @@ data IfaceRule ifRuleOrph :: Maybe OccName -- Just like IfaceClsInst } +instance Binary IfaceRule where + put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) + data IfaceAnnotation = IfaceAnnotation { ifAnnotatedTarget :: IfaceAnnTarget, ifAnnotatedValue :: Serialized } +instance Binary IfaceAnnotation where + put_ bh (IfaceAnnotation a1 a2) = do + put_ bh a1 + put_ bh a2 + get bh = do + a1 <- get bh + a2 <- get bh + return (IfaceAnnotation a1 a2) + type IfaceAnnTarget = AnnTarget OccName -- We only serialise the IdDetails of top-level Ids, and even then @@ -214,10 +508,31 @@ data IfaceIdDetails | IfRecSelId IfaceTyCon Bool | IfDFunId Int -- Number of silent args +instance Binary IfaceIdDetails where + put_ bh IfVanillaId = putByte bh 0 + put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b + put_ bh (IfDFunId n) = do { putByte bh 2; put_ bh n } + get bh = do + h <- getByte bh + case h of + 0 -> return IfVanillaId + 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } + _ -> do { n <- get bh; return (IfDFunId n) } + data IfaceIdInfo = NoInfo -- When writing interface file without -O | HasInfo [IfaceInfoItem] -- Has info, and here it is +instance Binary IfaceIdInfo where + put_ bh NoInfo = putByte bh 0 + put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut + + get bh = do + h <- getByte bh + case h of + 0 -> return NoInfo + _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet + -- Here's a tricky case: -- * Compile with -O module A, and B which imports A.f -- * Change function f in A, and recompile without -O @@ -236,6 +551,23 @@ data IfaceInfoItem IfaceUnfolding -- See Note [Expose recursive functions] | HsNoCafRefs +instance Binary IfaceInfoItem where + put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa + put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab + put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad + put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad + put_ bh HsNoCafRefs = putByte bh 4 + get bh = do + h <- getByte bh + case h of + 0 -> liftM HsArity $ get bh + 1 -> liftM HsStrictness $ get bh + 2 -> do lb <- get bh + ad <- get bh + return (HsUnfold lb ad) + 3 -> liftM HsInline $ get bh + _ -> return HsNoCafRefs + -- NB: Specialisations and rules come in separately and are -- only later attached to the Id. Partial reason: some are orphans. @@ -253,14 +585,54 @@ data IfaceUnfolding | IfWrapper IfaceExpr -- cf TcIface's Note [wrappers in interface files] - | IfDFunUnfold [DFunArg IfaceExpr] + | IfDFunUnfold [IfaceBndr] [IfaceExpr] + +instance Binary IfaceUnfolding where + put_ bh (IfCoreUnfold s e) = do + putByte bh 0 + put_ bh s + put_ bh e + put_ bh (IfInlineRule a b c d) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh c + put_ bh d + put_ bh (IfWrapper e) = do + putByte bh 2 + put_ bh e + put_ bh (IfDFunUnfold as bs) = do + putByte bh 3 + put_ bh as + put_ bh bs + put_ bh (IfCompulsory e) = do + putByte bh 4 + put_ bh e + get bh = do + h <- getByte bh + case h of + 0 -> do s <- get bh + e <- get bh + return (IfCoreUnfold s e) + 1 -> do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (IfInlineRule a b c d) + 2 -> do e <- get bh + return (IfWrapper e) + 3 -> do as <- get bh + bs <- get bh + return (IfDFunUnfold as bs) + _ -> do e <- get bh + return (IfCompulsory e) -------------------------------- data IfaceExpr = IfaceLcl IfLclName | IfaceExt IfExtName | IfaceType IfaceType - | IfaceCo IfaceType -- We re-use IfaceType for coercions + | IfaceCo IfaceCoercion | IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted | IfaceLam IfaceBndr IfaceExpr | IfaceApp IfaceExpr IfaceExpr @@ -272,11 +644,130 @@ data IfaceExpr | IfaceFCall ForeignCall IfaceType | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E +instance Binary IfaceExpr where + put_ bh (IfaceLcl aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceType ab) = do + putByte bh 1 + put_ bh ab + put_ bh (IfaceCo ab) = do + putByte bh 2 + put_ bh ab + put_ bh (IfaceTuple ac ad) = do + putByte bh 3 + put_ bh ac + put_ bh ad + put_ bh (IfaceLam ae af) = do + putByte bh 4 + put_ bh ae + put_ bh af + put_ bh (IfaceApp ag ah) = do + putByte bh 5 + put_ bh ag + put_ bh ah + put_ bh (IfaceCase ai aj ak) = do + putByte bh 6 + put_ bh ai + put_ bh aj + put_ bh ak + put_ bh (IfaceLet al am) = do + putByte bh 7 + put_ bh al + put_ bh am + put_ bh (IfaceTick an ao) = do + putByte bh 8 + put_ bh an + put_ bh ao + put_ bh (IfaceLit ap) = do + putByte bh 9 + put_ bh ap + put_ bh (IfaceFCall as at) = do + putByte bh 10 + put_ bh as + put_ bh at + put_ bh (IfaceExt aa) = do + putByte bh 11 + put_ bh aa + put_ bh (IfaceCast ie ico) = do + putByte bh 12 + put_ bh ie + put_ bh ico + put_ bh (IfaceECase a b) = do + putByte bh 13 + put_ bh a + put_ bh b + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceLcl aa) + 1 -> do ab <- get bh + return (IfaceType ab) + 2 -> do ab <- get bh + return (IfaceCo ab) + 3 -> do ac <- get bh + ad <- get bh + return (IfaceTuple ac ad) + 4 -> do ae <- get bh + af <- get bh + return (IfaceLam ae af) + 5 -> do ag <- get bh + ah <- get bh + return (IfaceApp ag ah) + 6 -> do ai <- get bh + aj <- get bh + ak <- get bh + return (IfaceCase ai aj ak) + 7 -> do al <- get bh + am <- get bh + return (IfaceLet al am) + 8 -> do an <- get bh + ao <- get bh + return (IfaceTick an ao) + 9 -> do ap <- get bh + return (IfaceLit ap) + 10 -> do as <- get bh + at <- get bh + return (IfaceFCall as at) + 11 -> do aa <- get bh + return (IfaceExt aa) + 12 -> do ie <- get bh + ico <- get bh + return (IfaceCast ie ico) + 13 -> do a <- get bh + b <- get bh + return (IfaceECase a b) + _ -> panic ("get IfaceExpr " ++ show h) + data IfaceTickish = IfaceHpcTick Module Int -- from HpcTick x | IfaceSCC CostCentre Bool Bool -- from ProfNote -- no breakpoints: we never export these into interface files +instance Binary IfaceTickish where + put_ bh (IfaceHpcTick m ix) = do + putByte bh 0 + put_ bh m + put_ bh ix + put_ bh (IfaceSCC cc tick push) = do + putByte bh 1 + put_ bh cc + put_ bh tick + put_ bh push + + get bh = do + h <- getByte bh + case h of + 0 -> do m <- get bh + ix <- get bh + return (IfaceHpcTick m ix) + 1 -> do cc <- get bh + tick <- get bh + push <- get bh + return (IfaceSCC cc tick push) + _ -> panic ("get IfaceTickish " ++ show h) + type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) -- Note: IfLclName, not IfaceBndr (and same with the case binder) -- We reconstruct the kind/type of the thing from the context @@ -286,14 +777,44 @@ data IfaceConAlt = IfaceDefault | IfaceDataAlt IfExtName | IfaceLitAlt Literal +instance Binary IfaceConAlt where + put_ bh IfaceDefault = putByte bh 0 + put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa + put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceDefault + 1 -> liftM IfaceDataAlt $ get bh + _ -> liftM IfaceLitAlt $ get bh + data IfaceBinding = IfaceNonRec IfaceLetBndr IfaceExpr | IfaceRec [(IfaceLetBndr, IfaceExpr)] +instance Binary IfaceBinding where + put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab + put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) } + _ -> do { ac <- get bh; return (IfaceRec ac) } + -- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too -- It's used for *non-top-level* let/rec binders -- See Note [IdInfo on nested let-bindings] data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo + +instance Binary IfaceLetBndr where + put_ bh (IfLetBndr a b c) = do + put_ bh a + put_ bh b + put_ bh c + get bh = do a <- get bh + b <- get bh + c <- get bh + return (IfLetBndr a b c) \end{code} Note [Empty case alternatives] @@ -496,21 +1017,28 @@ pprIfaceDecl (IfaceForeign {ifName = tycon}) pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = SynonymTyCon mono_ty}) - = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars) + ifRoles = roles, + ifSynRhs = IfaceSynonymTyCon mono_ty}) + = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars roles) 4 (vcat [equals <+> ppr mono_ty]) -pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = SynFamilyTyCon {}, ifSynKind = kind }) - = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars) +pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifRoles = roles, + ifSynRhs = IfaceOpenSynFamilyTyCon, ifSynKind = kind }) + = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars roles) + 4 (dcolon <+> ppr kind) + +-- this case handles both abstract and instantiated closed family tycons +pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifRoles = roles, + ifSynRhs = _closedSynFamilyTyCon, ifSynKind = kind }) + = hang (ptext (sLit "closed type family") <+> pprIfaceDeclHead [] tycon tyvars roles) 4 (dcolon <+> ppr kind) pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType, ifCtxt = context, - ifTyVars = tyvars, ifCons = condecls, + ifTyVars = tyvars, ifRoles = roles, ifCons = condecls, ifRec = isrec, ifPromotable = is_prom, ifAxiom = mbAxiom}) - = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) + = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars roles) 4 (vcat [ pprCType cType , pprRec isrec <> comma <+> pp_prom , pp_condecls tycon condecls @@ -525,19 +1053,16 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType, IfNewTyCon _ -> ptext (sLit "newtype") pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, - ifFDs = fds, ifATs = ats, ifSigs = sigs, + ifRoles = roles, ifFDs = fds, ifATs = ats, ifSigs = sigs, ifRec = isrec}) - = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds) + = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars roles <+> pprFundeps fds) 4 (vcat [pprRec isrec, sep (map ppr ats), sep (map ppr sigs)]) pprIfaceDecl (IfaceAxiom {ifName = name, ifTyCon = tycon, ifAxBranches = branches }) = hang (ptext (sLit "axiom") <+> ppr name <> colon) - 2 (vcat $ map ppr_branch branches) - where - ppr_branch (IfaceAxBranch { ifaxbTyVars = tyvars, ifaxbLHS = lhs, ifaxbRHS = rhs }) - = pprIfaceTvBndrs tyvars <> dot <+> ppr (IfaceTyConApp tycon lhs) <+> text "~#" <+> ppr rhs + 2 (vcat $ map (pprAxBranch $ Just tycon) branches) pprCType :: Maybe CType -> SDoc pprCType Nothing = ptext (sLit "No C type associated") @@ -556,10 +1081,10 @@ instance Outputable IfaceClassOp where instance Outputable IfaceAT where ppr (IfaceAT d defs) = hang (ppr d) 2 (vcat (map ppr defs)) -pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc -pprIfaceDeclHead context thing tyvars +pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> [Role] -> SDoc +pprIfaceDeclHead context thing tyvars roles = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), - pprIfaceTvBndrs tyvars] + pprIfaceTvBndrsRoles tyvars roles] pp_condecls :: OccName -> IfaceConDecls -> SDoc pp_condecls _ (IfAbstractTyCon {}) = empty @@ -589,7 +1114,7 @@ pprIfaceConDecl tc ppr_bang IfNoBang = char '_' -- Want to see these ppr_bang IfStrict = char '!' ppr_bang IfUnpack = ptext (sLit "!!") - ppr_bang (IfUnpackCo co) = ptext (sLit "!!") <> pprParendIfaceType co + ppr_bang (IfUnpackCo co) = ptext (sLit "!!") <> pprParendIfaceCoercion co main_payload = ppr name <+> dcolon <+> pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau @@ -622,10 +1147,10 @@ instance Outputable IfaceClsInst where 2 (equals <+> ppr dfun_id) instance Outputable IfaceFamInst where - ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcss, + ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs, ifFamInstAxiom = tycon_ax}) = hang (ptext (sLit "family instance") <+> - ppr fam <+> pprWithCommas (brackets . pprWithCommas ppr_rough) mb_tcss) + ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs) 2 (equals <+> ppr tycon_ax) ppr_rough :: Maybe IfaceTyCon -> SDoc @@ -654,7 +1179,7 @@ pprIfaceExpr _ (IfaceExt v) = ppr v pprIfaceExpr _ (IfaceLit l) = ppr l pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty -pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceType co +pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceCoercion co pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (interpp'SP as) @@ -687,7 +1212,7 @@ pprIfaceExpr add_par (IfaceCase scrut bndr alts) pprIfaceExpr _ (IfaceCast expr co) = sep [pprParendIfaceExpr expr, nest 2 (ptext (sLit "`cast`")), - pprParendIfaceType co] + pprParendIfaceCoercion co] pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body) = add_par (sep [ptext (sLit "let {"), @@ -763,9 +1288,9 @@ instance Outputable IfaceUnfolding where ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok), pprParendIfaceExpr e] - ppr (IfWrapper e) = ptext (sLit "Wrapper") <+> parens (ppr e) - ppr (IfDFunUnfold ns) = ptext (sLit "DFun:") - <+> brackets (pprWithCommas ppr ns) + ppr (IfWrapper e) = ptext (sLit "Wrapper:") <+> parens (ppr e) + ppr (IfDFunUnfold bs es) = hang (ptext (sLit "DFun:") <+> sep (map ppr bs) <> dot) + 2 (sep (map pprParendIfaceExpr es)) -- ----------------------------------------------------------------------------- -- | Finding the Names in IfaceSyn @@ -816,9 +1341,11 @@ freeNamesIfIdDetails (IfRecSelId tc _) = freeNamesIfTc tc freeNamesIfIdDetails _ = emptyNameSet -- All other changes are handled via the version info on the tycon -freeNamesIfSynRhs :: SynTyConRhs IfaceType -> NameSet -freeNamesIfSynRhs (SynonymTyCon ty) = freeNamesIfType ty -freeNamesIfSynRhs _ = emptyNameSet +freeNamesIfSynRhs :: IfaceSynTyConRhs -> NameSet +freeNamesIfSynRhs (IfaceSynonymTyCon ty) = freeNamesIfType ty +freeNamesIfSynRhs IfaceOpenSynFamilyTyCon = emptyNameSet +freeNamesIfSynRhs (IfaceClosedSynFamilyTyCon ax) = unitNameSet ax +freeNamesIfSynRhs IfaceAbstractClosedSynFamilyTyCon = emptyNameSet freeNamesIfContext :: IfaceContext -> NameSet freeNamesIfContext = fnList freeNamesIfType @@ -856,8 +1383,35 @@ freeNamesIfType (IfaceLitTy _) = emptyNameSet freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTvBndr tv &&& freeNamesIfType t freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t -freeNamesIfType (IfaceCoConApp tc ts) = - freeNamesIfCo tc &&& fnList freeNamesIfType ts + +freeNamesIfCoercion :: IfaceCoercion -> NameSet +freeNamesIfCoercion (IfaceReflCo _ t) = freeNamesIfType t +freeNamesIfCoercion (IfaceFunCo _ c1 c2) + = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceTyConAppCo _ tc cos) + = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos +freeNamesIfCoercion (IfaceAppCo c1 c2) + = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceForAllCo tv co) + = freeNamesIfTvBndr tv &&& freeNamesIfCoercion co +freeNamesIfCoercion (IfaceCoVarCo _) + = emptyNameSet +freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos) + = unitNameSet ax &&& fnList freeNamesIfCoercion cos +freeNamesIfCoercion (IfaceUnivCo _ t1 t2) + = freeNamesIfType t1 &&& freeNamesIfType t2 +freeNamesIfCoercion (IfaceSymCo c) + = freeNamesIfCoercion c +freeNamesIfCoercion (IfaceTransCo c1 c2) + = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceNthCo _ co) + = freeNamesIfCoercion co +freeNamesIfCoercion (IfaceLRCo _ co) + = freeNamesIfCoercion co +freeNamesIfCoercion (IfaceInstCo co ty) + = freeNamesIfCoercion co &&& freeNamesIfType ty +freeNamesIfCoercion (IfaceSubCo co) + = freeNamesIfCoercion co freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet freeNamesIfTvBndrs = fnList freeNamesIfTvBndr @@ -893,17 +1447,17 @@ freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e freeNamesIfUnfold (IfWrapper e) = freeNamesIfExpr e -freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr (dfunArgExprs vs) +freeNamesIfUnfold (IfDFunUnfold bs es) = fnList freeNamesIfBndr bs &&& fnList freeNamesIfExpr es freeNamesIfExpr :: IfaceExpr -> NameSet freeNamesIfExpr (IfaceExt v) = unitNameSet v freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty -freeNamesIfExpr (IfaceCo co) = freeNamesIfType co +freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a -freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfType co +freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty freeNamesIfExpr (IfaceCase s _ alts) @@ -933,11 +1487,6 @@ freeNamesIfTc :: IfaceTyCon -> NameSet freeNamesIfTc (IfaceTc tc) = unitNameSet tc -- ToDo: shouldn't we include IfaceIntTc & co.? -freeNamesIfCo :: IfaceCoCon -> NameSet -freeNamesIfCo (IfaceCoAx tc _) = unitNameSet tc --- ToDo: include IfaceIPCoAx? Probably not necessary. -freeNamesIfCo _ = emptyNameSet - freeNamesIfRule :: IfaceRule -> NameSet freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f , ifRuleArgs = es, ifRuleRhs = rhs }) diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index 103d336dbb..b9d6a445cf 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -9,22 +9,24 @@ This module defines interface types and binders module IfaceType ( IfExtName, IfLclName, - IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoCon(..), + IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoercion(..), IfaceTyLit(..), - IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion, + IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, -- Conversion from Type -> IfaceType toIfaceType, toIfaceKind, toIfaceContext, toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, toIfaceTyCon, toIfaceTyCon_name, - -- Conversion from Coercion -> IfaceType - coToIfaceType, + -- Conversion from Coercion -> IfaceCoercion + toIfaceCoercion, -- Printing pprIfaceType, pprParendIfaceType, pprIfaceContext, - pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceBndrs, - tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart + pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceTvBndrsRoles, + pprIfaceBndrs, + tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart, + pprIfaceCoercion, pprParendIfaceCoercion ) where @@ -40,8 +42,11 @@ import TysPrim import PrelNames( funTyConKey ) import Name import BasicTypes +import Binary import Outputable import FastString + +import Control.Monad \end{code} %************************************************************************ @@ -65,16 +70,14 @@ type IfaceTvBndr = (IfLclName, IfaceKind) ------------------------------- type IfaceKind = IfaceType -type IfaceCoercion = IfaceType -data IfaceType -- A kind of universal type, used for types, kinds, and coercions +data IfaceType -- A kind of universal type, used for types and kinds = IfaceTyVar IfLclName -- Type/coercion variable only, not tycon | IfaceAppTy IfaceType IfaceType | IfaceFunTy IfaceType IfaceType | IfaceForAllTy IfaceTvBndr IfaceType | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated -- Includes newtypes, synonyms, tuples - | IfaceCoConApp IfaceCoCon [IfaceType] -- Always saturated | IfaceLitTy IfaceTyLit type IfacePredType = IfaceType @@ -88,12 +91,21 @@ data IfaceTyLit -- coercion constructors, the lot newtype IfaceTyCon = IfaceTc { ifaceTyConName :: IfExtName } - -- Coercion constructors -data IfaceCoCon - = IfaceCoAx IfExtName Int -- Int is 0-indexed branch number - | IfaceReflCo | IfaceUnsafeCo | IfaceSymCo - | IfaceTransCo | IfaceInstCo - | IfaceNthCo Int | IfaceLRCo LeftOrRight +data IfaceCoercion + = IfaceReflCo Role IfaceType + | IfaceFunCo Role IfaceCoercion IfaceCoercion + | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion] + | IfaceAppCo IfaceCoercion IfaceCoercion + | IfaceForAllCo IfaceTvBndr IfaceCoercion + | IfaceCoVarCo IfLclName + | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion] + | IfaceUnivCo Role IfaceType IfaceType + | IfaceSymCo IfaceCoercion + | IfaceTransCo IfaceCoercion IfaceCoercion + | IfaceNthCo Int IfaceCoercion + | IfaceLRCo LeftOrRight IfaceCoercion + | IfaceInstCo IfaceCoercion IfaceType + | IfaceSubCo IfaceCoercion \end{code} %************************************************************************ @@ -173,6 +185,26 @@ pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind) pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc pprIfaceTvBndrs tyvars = sep (map pprIfaceTvBndr tyvars) + +pprIfaceTvBndrsRoles :: [IfaceTvBndr] -> [Role] -> SDoc +pprIfaceTvBndrsRoles tyvars roles = sep (zipWith ppr_bndr_role tyvars roles) + where + ppr_bndr_role bndr role = pprIfaceTvBndr bndr <> char '@' <> ppr role + +instance Binary IfaceBndr where + put_ bh (IfaceIdBndr aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceTvBndr ab) = do + putByte bh 1 + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceIdBndr aa) + _ -> do ab <- get bh + return (IfaceTvBndr ab) \end{code} ----------------------------- Printing IfaceType ------------------------------------ @@ -193,14 +225,10 @@ isIfacePredTy _ = False ppr_ty :: Int -> IfaceType -> SDoc ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys +ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ppr_ty ctxt_prec tc tys ppr_ty _ (IfaceLitTy n) = ppr_tylit n -ppr_ty ctxt_prec (IfaceCoConApp tc tys) - = maybeParen ctxt_prec tYCON_PREC - (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))]) - -- Function types ppr_ty ctxt_prec (IfaceFunTy ty1 ty2) = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. @@ -225,7 +253,9 @@ ppr_ty ctxt_prec ty@(IfaceForAllTy _ _) (tvs, theta, tau) = splitIfaceSigmaTy ty ------------------- -pprIfaceForAllPart :: [IfaceTvBndr] -> IfaceContext -> SDoc -> SDoc +-- needs to handle type contexts and coercion contexts, hence the +-- generality +pprIfaceForAllPart :: Outputable a => [IfaceTvBndr] -> [a] -> SDoc -> SDoc pprIfaceForAllPart tvs ctxt doc = sep [ppr_tvs, pprIfaceContext ctxt, doc] where @@ -233,20 +263,23 @@ pprIfaceForAllPart tvs ctxt doc | otherwise = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot ------------------- -ppr_tc_app :: Int -> IfaceTyCon -> [IfaceType] -> SDoc -ppr_tc_app _ tc [] = ppr_tc tc +ppr_tc_app :: (Int -> a -> SDoc) -> Int -> IfaceTyCon -> [a] -> SDoc +ppr_tc_app _ _ tc [] = ppr_tc tc -ppr_tc_app _ (IfaceTc n) [ty] | n == listTyConName = brackets (pprIfaceType ty) -ppr_tc_app _ (IfaceTc n) [ty] | n == parrTyConName = paBrackets (pprIfaceType ty) -ppr_tc_app _ (IfaceTc n) tys +ppr_tc_app pp _ (IfaceTc n) [ty] + | n == listTyConName + = brackets (pp tOP_PREC ty) + | n == parrTyConName + = paBrackets (pp tOP_PREC ty) +ppr_tc_app pp _ (IfaceTc n) tys | Just (ATyCon tc) <- wiredInNameTyThing_maybe n , Just sort <- tyConTuple_maybe tc , tyConArity tc == length tys - = tupleParens sort (sep (punctuate comma (map pprIfaceType tys))) -ppr_tc_app ctxt_prec tc tys + = tupleParens sort (sep (punctuate comma (map (pp tOP_PREC) tys))) +ppr_tc_app pp ctxt_prec tc tys = maybeParen ctxt_prec tYCON_PREC - (sep [ppr_tc tc, nest 4 (sep (map pprParendIfaceType tys))]) + (sep [ppr_tc tc, nest 4 (sep (map (pp tYCON_PREC) tys))]) ppr_tc :: IfaceTyCon -> SDoc -- Wrap infix type constructors in parens @@ -260,32 +293,255 @@ ppr_tylit :: IfaceTyLit -> SDoc ppr_tylit (IfaceNumTyLit n) = integer n ppr_tylit (IfaceStrTyLit n) = text (show n) +pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc +pprIfaceCoercion = ppr_co tOP_PREC +pprParendIfaceCoercion = ppr_co tYCON_PREC + +ppr_co :: Int -> IfaceCoercion -> SDoc +ppr_co _ (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r +ppr_co ctxt_prec (IfaceFunCo r co1 co2) + = maybeParen ctxt_prec fUN_PREC $ + sep (ppr_co fUN_PREC co1 : ppr_fun_tail co2) + where + ppr_fun_tail (IfaceFunCo r co1 co2) + = (arrow <> ppr_role r <+> ppr_co fUN_PREC co1) : ppr_fun_tail co2 + ppr_fun_tail other_co + = [arrow <> ppr_role r <+> pprIfaceCoercion other_co] + +ppr_co _ (IfaceTyConAppCo r tc cos) + = parens (ppr_tc_app ppr_co tOP_PREC tc cos) <> ppr_role r +ppr_co ctxt_prec (IfaceAppCo co1 co2) + = maybeParen ctxt_prec tYCON_PREC $ + ppr_co fUN_PREC co1 <+> pprParendIfaceCoercion co2 +ppr_co ctxt_prec co@(IfaceForAllCo _ _) + = maybeParen ctxt_prec fUN_PREC (sep [ppr_tvs, pprIfaceCoercion inner_co]) + where + (tvs, inner_co) = split_co co + ppr_tvs = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot + + split_co (IfaceForAllCo tv co') + = let (tvs, co'') = split_co co' in (tv:tvs,co'') + split_co co' = ([], co') + +ppr_co _ (IfaceCoVarCo covar) = ppr covar + +ppr_co ctxt_prec (IfaceUnivCo r ty1 ty2) + = maybeParen ctxt_prec tYCON_PREC $ + ptext (sLit "UnivCo") <+> ppr r <+> + pprParendIfaceType ty1 <+> pprParendIfaceType ty2 + +ppr_co ctxt_prec (IfaceInstCo co ty) + = maybeParen ctxt_prec tYCON_PREC $ + ptext (sLit "Inst") <+> pprParendIfaceCoercion co <+> pprParendIfaceType ty + +ppr_co ctxt_prec co + = ppr_special_co ctxt_prec doc cos + where (doc, cos) = case co of + { IfaceAxiomInstCo n i cos -> (ppr n <> brackets (ppr i), cos) + ; IfaceSymCo co -> (ptext (sLit "Sym"), [co]) + ; IfaceTransCo co1 co2 -> (ptext (sLit "Trans"), [co1,co2]) + ; IfaceNthCo d co -> (ptext (sLit "Nth:") <> int d, + [co]) + ; IfaceLRCo lr co -> (ppr lr, [co]) + ; IfaceSubCo co -> (ptext (sLit "Sub"), [co]) + ; _ -> panic "pprIfaceCo" } + +ppr_special_co :: Int -> SDoc -> [IfaceCoercion] -> SDoc +ppr_special_co ctxt_prec doc cos + = maybeParen ctxt_prec tYCON_PREC + (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))]) + +ppr_role :: Role -> SDoc +ppr_role r = underscore <> ppr r + ------------------- instance Outputable IfaceTyCon where ppr = ppr . ifaceTyConName -instance Outputable IfaceCoCon where - ppr (IfaceCoAx n i) = ppr n <> brackets (ppr i) - ppr IfaceReflCo = ptext (sLit "Refl") - ppr IfaceUnsafeCo = ptext (sLit "Unsafe") - ppr IfaceSymCo = ptext (sLit "Sym") - ppr IfaceTransCo = ptext (sLit "Trans") - ppr IfaceInstCo = ptext (sLit "Inst") - ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d - ppr (IfaceLRCo lr) = ppr lr +instance Outputable IfaceCoercion where + ppr = pprIfaceCoercion + +instance Binary IfaceTyCon where + put_ bh (IfaceTc ext) = put_ bh ext + get bh = liftM IfaceTc (get bh) instance Outputable IfaceTyLit where ppr = ppr_tylit +instance Binary IfaceTyLit where + put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n + put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n + + get bh = + do tag <- getByte bh + case tag of + 1 -> do { n <- get bh + ; return (IfaceNumTyLit n) } + 2 -> do { n <- get bh + ; return (IfaceStrTyLit n) } + _ -> panic ("get IfaceTyLit " ++ show tag) + ------------------- -pprIfaceContext :: IfaceContext -> SDoc +pprIfaceContext :: Outputable a => [a] -> SDoc -- Prints "(C a, D b) =>", including the arrow pprIfaceContext [] = empty pprIfaceContext theta = ppr_preds theta <+> darrow -ppr_preds :: [IfacePredType] -> SDoc +ppr_preds :: Outputable a => [a] -> SDoc ppr_preds [pred] = ppr pred -- No parens ppr_preds preds = parens (sep (punctuate comma (map ppr preds))) + +instance Binary IfaceType where + put_ bh (IfaceForAllTy aa ab) = do + putByte bh 0 + put_ bh aa + put_ bh ab + put_ bh (IfaceTyVar ad) = do + putByte bh 1 + put_ bh ad + put_ bh (IfaceAppTy ae af) = do + putByte bh 2 + put_ bh ae + put_ bh af + put_ bh (IfaceFunTy ag ah) = do + putByte bh 3 + put_ bh ag + put_ bh ah + put_ bh (IfaceTyConApp tc tys) + = do { putByte bh 5; put_ bh tc; put_ bh tys } + + put_ bh (IfaceLitTy n) + = do { putByte bh 30; put_ bh n } + + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + ab <- get bh + return (IfaceForAllTy aa ab) + 1 -> do ad <- get bh + return (IfaceTyVar ad) + 2 -> do ae <- get bh + af <- get bh + return (IfaceAppTy ae af) + 3 -> do ag <- get bh + ah <- get bh + return (IfaceFunTy ag ah) + 5 -> do { tc <- get bh; tys <- get bh + ; return (IfaceTyConApp tc tys) } + + 30 -> do n <- get bh + return (IfaceLitTy n) + + _ -> panic ("get IfaceType " ++ show h) + +instance Binary IfaceCoercion where + put_ bh (IfaceReflCo a b) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh (IfaceFunCo a b c) = do + putByte bh 2 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceTyConAppCo a b c) = do + putByte bh 3 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceAppCo a b) = do + putByte bh 4 + put_ bh a + put_ bh b + put_ bh (IfaceForAllCo a b) = do + putByte bh 5 + put_ bh a + put_ bh b + put_ bh (IfaceCoVarCo a) = do + putByte bh 6 + put_ bh a + put_ bh (IfaceAxiomInstCo a b c) = do + putByte bh 7 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceUnivCo a b c) = do + putByte bh 8 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceSymCo a) = do + putByte bh 9 + put_ bh a + put_ bh (IfaceTransCo a b) = do + putByte bh 10 + put_ bh a + put_ bh b + put_ bh (IfaceNthCo a b) = do + putByte bh 11 + put_ bh a + put_ bh b + put_ bh (IfaceLRCo a b) = do + putByte bh 12 + put_ bh a + put_ bh b + put_ bh (IfaceInstCo a b) = do + putByte bh 13 + put_ bh a + put_ bh b + put_ bh (IfaceSubCo a) = do + putByte bh 14 + put_ bh a + + get bh = do + tag <- getByte bh + case tag of + 1 -> do a <- get bh + b <- get bh + return $ IfaceReflCo a b + 2 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceFunCo a b c + 3 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceTyConAppCo a b c + 4 -> do a <- get bh + b <- get bh + return $ IfaceAppCo a b + 5 -> do a <- get bh + b <- get bh + return $ IfaceForAllCo a b + 6 -> do a <- get bh + return $ IfaceCoVarCo a + 7 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceAxiomInstCo a b c + 8 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceUnivCo a b c + 9 -> do a <- get bh + return $ IfaceSymCo a + 10-> do a <- get bh + b <- get bh + return $ IfaceTransCo a b + 11-> do a <- get bh + b <- get bh + return $ IfaceNthCo a b + 12-> do a <- get bh + b <- get bh + return $ IfaceLRCo a b + 13-> do a <- get bh + b <- get bh + return $ IfaceInstCo a b + 14-> do a <- get bh + return $ IfaceSubCo a + _ -> panic ("get IfaceCoercion " ++ show tag) + \end{code} %************************************************************************ @@ -347,38 +603,31 @@ toIfaceContext :: ThetaType -> IfaceContext toIfaceContext = toIfaceTypes ---------------- -coToIfaceType :: Coercion -> IfaceType -coToIfaceType (Refl ty) = IfaceCoConApp IfaceReflCo [toIfaceType ty] -coToIfaceType (TyConAppCo tc cos) +toIfaceCoercion :: Coercion -> IfaceCoercion +toIfaceCoercion (Refl r ty) = IfaceReflCo r (toIfaceType ty) +toIfaceCoercion (TyConAppCo r tc cos) | tc `hasKey` funTyConKey - , [arg,res] <- cos = IfaceFunTy (coToIfaceType arg) (coToIfaceType res) - | otherwise = IfaceTyConApp (toIfaceTyCon tc) - (map coToIfaceType cos) -coToIfaceType (AppCo co1 co2) = IfaceAppTy (coToIfaceType co1) - (coToIfaceType co2) -coToIfaceType (ForAllCo v co) = IfaceForAllTy (toIfaceTvBndr v) - (coToIfaceType co) -coToIfaceType (CoVarCo cv) = IfaceTyVar (toIfaceCoVar cv) -coToIfaceType (AxiomInstCo con ind cos) - = IfaceCoConApp (coAxiomToIfaceType con ind) - (map coToIfaceType cos) -coToIfaceType (UnsafeCo ty1 ty2) = IfaceCoConApp IfaceUnsafeCo - [ toIfaceType ty1 - , toIfaceType ty2 ] -coToIfaceType (SymCo co) = IfaceCoConApp IfaceSymCo - [ coToIfaceType co ] -coToIfaceType (TransCo co1 co2) = IfaceCoConApp IfaceTransCo - [ coToIfaceType co1 - , coToIfaceType co2 ] -coToIfaceType (NthCo d co) = IfaceCoConApp (IfaceNthCo d) - [ coToIfaceType co ] -coToIfaceType (LRCo lr co) = IfaceCoConApp (IfaceLRCo lr) - [ coToIfaceType co ] -coToIfaceType (InstCo co ty) = IfaceCoConApp IfaceInstCo - [ coToIfaceType co - , toIfaceType ty ] - -coAxiomToIfaceType :: CoAxiom br -> Int -> IfaceCoCon -coAxiomToIfaceType con ind = IfaceCoAx (coAxiomName con) ind + , [arg,res] <- cos = IfaceFunCo r (toIfaceCoercion arg) (toIfaceCoercion res) + | otherwise = IfaceTyConAppCo r (toIfaceTyCon tc) + (map toIfaceCoercion cos) +toIfaceCoercion (AppCo co1 co2) = IfaceAppCo (toIfaceCoercion co1) + (toIfaceCoercion co2) +toIfaceCoercion (ForAllCo v co) = IfaceForAllCo (toIfaceTvBndr v) + (toIfaceCoercion co) +toIfaceCoercion (CoVarCo cv) = IfaceCoVarCo (toIfaceCoVar cv) +toIfaceCoercion (AxiomInstCo con ind cos) + = IfaceAxiomInstCo (coAxiomName con) ind + (map toIfaceCoercion cos) +toIfaceCoercion (UnivCo r ty1 ty2) = IfaceUnivCo r (toIfaceType ty1) + (toIfaceType ty2) +toIfaceCoercion (SymCo co) = IfaceSymCo (toIfaceCoercion co) +toIfaceCoercion (TransCo co1 co2) = IfaceTransCo (toIfaceCoercion co1) + (toIfaceCoercion co2) +toIfaceCoercion (NthCo d co) = IfaceNthCo d (toIfaceCoercion co) +toIfaceCoercion (LRCo lr co) = IfaceLRCo lr (toIfaceCoercion co) +toIfaceCoercion (InstCo co ty) = IfaceInstCo (toIfaceCoercion co) + (toIfaceType ty) +toIfaceCoercion (SubCo co) = IfaceSubCo (toIfaceCoercion co) + \end{code} diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 5f3b7a5aae..25044224e7 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -311,7 +311,6 @@ mkIface_ hsc_env maybe_old_fingerprint mi_warn_fn = mkIfaceWarnCache warns, mi_fix_fn = mkIfaceFixCache fixities } } - ; (new_iface, no_change_at_all) <- {-# SCC "versioninfo" #-} addFingerprints hsc_env maybe_old_fingerprint @@ -1442,19 +1441,40 @@ idToIfaceDecl id coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl -- We *do* tidy Axioms, because they are not (and cannot -- conveniently be) built in tidy form -coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches }) +coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches + , co_ax_role = role }) = IfaceAxiom { ifName = name , ifTyCon = toIfaceTyCon tycon - , ifAxBranches = brListMap (coAxBranchToIfaceBranch emptyTidyEnv) branches } + , ifRole = role + , ifAxBranches = brListMap (coAxBranchToIfaceBranch + emptyTidyEnv + (brListMap coAxBranchLHS branches)) branches } where name = getOccName ax - -coAxBranchToIfaceBranch :: TidyEnv -> CoAxBranch -> IfaceAxBranch -coAxBranchToIfaceBranch env0 (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs }) +-- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches +-- to incompatible indices +-- See [Storing compatibility] in CoAxiom +coAxBranchToIfaceBranch :: TidyEnv -> [[Type]] -> CoAxBranch -> IfaceAxBranch +coAxBranchToIfaceBranch env0 lhs_s + branch@(CoAxBranch { cab_incomps = incomps }) + = (coAxBranchToIfaceBranch' env0 branch) { ifaxbIncomps = iface_incomps } + where + iface_incomps = map (expectJust "iface_incomps" + . (flip findIndex lhs_s + . eqTypes) + . coAxBranchLHS) incomps + +-- use this one for standalone branches without incompatibles +coAxBranchToIfaceBranch' :: TidyEnv -> CoAxBranch -> IfaceAxBranch +coAxBranchToIfaceBranch' env0 + (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs + , cab_roles = roles, cab_rhs = rhs }) = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs , ifaxbLHS = map (tidyToIfaceType env1) lhs - , ifaxbRHS = tidyToIfaceType env1 rhs } + , ifaxbRoles = roles + , ifaxbRHS = tidyToIfaceType env1 rhs + , ifaxbIncomps = [] } where (env1, tv_bndrs) = tidyTyVarBndrs env0 tvs @@ -1469,6 +1489,7 @@ tyConToIfaceDecl env tycon | Just syn_rhs <- synTyConRhs_maybe tycon = IfaceSyn { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, + ifRoles = tyConRoles tycon, ifSynRhs = to_ifsyn_rhs syn_rhs, ifSynKind = tidyToIfaceType env1 (synTyConResKind tycon) } @@ -1476,6 +1497,7 @@ tyConToIfaceDecl env tycon = IfaceData { ifName = getOccName tycon, ifCType = tyConCType tycon, ifTyVars = toIfaceTvBndrs tyvars, + ifRoles = tyConRoles tycon, ifCtxt = tidyToIfaceContext env1 (tyConStupidTheta tycon), ifCons = ifaceConDecls (algTyConRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), @@ -1491,8 +1513,12 @@ tyConToIfaceDecl env tycon where (env1, tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon) - to_ifsyn_rhs (SynFamilyTyCon a b) = SynFamilyTyCon a b - to_ifsyn_rhs (SynonymTyCon ty) = SynonymTyCon (tidyToIfaceType env1 ty) + to_ifsyn_rhs OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon + to_ifsyn_rhs (ClosedSynFamilyTyCon ax) + = IfaceClosedSynFamilyTyCon (coAxiomName ax) + to_ifsyn_rhs AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon + to_ifsyn_rhs (SynonymTyCon ty) + = IfaceSynonymTyCon (tidyToIfaceType env1 ty) ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) @@ -1528,7 +1554,7 @@ tyConToIfaceDecl env tycon toIfaceBang :: TidyEnv -> HsBang -> IfaceBang toIfaceBang _ HsNoBang = IfNoBang toIfaceBang _ (HsUnpack Nothing) = IfUnpack -toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (coToIfaceType (tidyCo env co)) +toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co)) toIfaceBang _ HsStrict = IfStrict toIfaceBang _ (HsUserBang {}) = panic "toIfaceBang" @@ -1537,6 +1563,7 @@ classToIfaceDecl env clas = IfaceClass { ifCtxt = tidyToIfaceContext env1 sc_theta, ifName = getOccName (classTyCon clas), ifTyVars = toIfaceTvBndrs clas_tyvars', + ifRoles = tyConRoles (classTyCon clas), ifFDs = map toIfaceFD clas_fds, ifATs = map toIfaceAT clas_ats, ifSigs = map toIfaceClassOp op_stuff, @@ -1550,7 +1577,7 @@ classToIfaceDecl env clas toIfaceAT :: ClassATItem -> IfaceAT toIfaceAT (tc, defs) - = IfaceAT (tyConToIfaceDecl env1 tc) (map (coAxBranchToIfaceBranch env1) defs) + = IfaceAT (tyConToIfaceDecl env1 tc) (map (coAxBranchToIfaceBranch' env1) defs) toIfaceClassOp (sel_id, def_meth) = ASSERT(sel_tyvars == clas_tyvars) @@ -1638,19 +1665,15 @@ instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag (n : _) -> Just (nameOccName n) -------------------------- -famInstToIfaceFamInst :: FamInst br -> IfaceFamInst +famInstToIfaceFamInst :: FamInst -> IfaceFamInst famInstToIfaceFamInst (FamInst { fi_axiom = axiom, - fi_group = group, fi_fam = fam, - fi_branches = branches }) - = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom - , ifFamInstFam = fam - , ifFamInstGroup = group - , ifFamInstTys = map (map do_rough) roughs - , ifFamInstOrph = orph } + fi_tcs = roughs }) + = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom + , ifFamInstFam = fam + , ifFamInstTys = map do_rough roughs + , ifFamInstOrph = orph } where - roughs = brListMap famInstBranchRoughMatch branches - do_rough Nothing = Nothing do_rough (Just n) = Just (toIfaceTyCon_name n) @@ -1743,8 +1766,8 @@ toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity where if_rhs = toIfaceExpr rhs -toIfUnfolding lb (DFunUnfolding _ar _con ops) - = Just (HsUnfold lb (IfDFunUnfold (map (fmap toIfaceExpr) ops))) +toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args))) -- No need to serialise the data constructor; -- we can recover it from the type of the dfun @@ -1774,7 +1797,7 @@ coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn, -- construct the same ru_rough field as we have right now; -- see tcIfaceRule do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty)) - do_arg (Coercion co) = IfaceCo (coToIfaceType co) + do_arg (Coercion co) = IfaceCo (toIfaceCoercion co) do_arg arg = toIfaceExpr arg -- Compute orphanhood. See Note [Orphans] in IfaceSyn @@ -1797,14 +1820,14 @@ toIfaceExpr :: CoreExpr -> IfaceExpr toIfaceExpr (Var v) = toIfaceVar v toIfaceExpr (Lit l) = IfaceLit l toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) -toIfaceExpr (Coercion co) = IfaceCo (coToIfaceType co) +toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co) toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x) (toIfaceExpr b) toIfaceExpr (App f a) = toIfaceApp f [a] toIfaceExpr (Case s x ty as) | null as = IfaceECase (toIfaceExpr s) (toIfaceType ty) | otherwise = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as) toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) -toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (coToIfaceType co) +toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co) toIfaceExpr (Tick t e) = IfaceTick (toIfaceTickish t) (toIfaceExpr e) --------------------- diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 2047b849ed..dffd69b9ed 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -436,7 +436,8 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, tc_iface_decl parent _ (IfaceData {ifName = occ_name, ifCType = cType, - ifTyVars = tv_bndrs, + ifTyVars = tv_bndrs, + ifRoles = roles, ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, ifRec = is_rec, ifPromotable = is_prom, @@ -447,7 +448,7 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name, { stupid_theta <- tcIfaceCtxt ctxt ; parent' <- tc_parent tyvars mb_axiom_name ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons - ; return (buildAlgTyCon tc_name tyvars cType stupid_theta + ; return (buildAlgTyCon tc_name tyvars roles cType stupid_theta cons is_rec is_prom gadt_syn parent') } ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) } @@ -460,17 +461,25 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name, ; let fam_tc = coAxiomTyCon ax ax_unbr = toUnbranchedAxiom ax -- data families don't have branches: - branch = coAxiomSingleBranch ax_unbr - ax_tvs = coAxBranchTyVars branch - ax_lhs = coAxBranchLHS branch - subst = zipTopTvSubst ax_tvs (mkTyVarTys tyvars) + branch = coAxiomSingleBranch ax_unbr + ax_tvs = coAxBranchTyVars branch + ax_lhs = coAxBranchLHS branch + tycon_tys = mkTyVarTys tyvars + subst = mkTopTvSubst (ax_tvs `zip` tycon_tys) -- The subst matches the tyvar of the TyCon -- with those from the CoAxiom. They aren't -- necessarily the same, since the two may be -- gotten from separate interface-file declarations - ; return (FamInstTyCon ax_unbr fam_tc (substTys subst ax_lhs)) } + -- NB: ax_tvs may be shorter because of eta-reduction + -- See Note [Eta reduction for data family axioms] in TcInstDcls + lhs_tys = substTys subst ax_lhs `chkAppend` + dropList ax_tvs tycon_tys + -- The 'lhs_tys' should be 1-1 with the 'tyvars' + -- but ax_tvs maybe shorter because of eta-reduction + ; return (FamInstTyCon ax_unbr fam_tc lhs_tys) } tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, + ifRoles = roles, ifSynRhs = mb_rhs_ty, ifSynKind = kind }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do @@ -478,17 +487,21 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, ; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop] ; rhs <- forkM (mk_doc tc_name) $ tc_syn_rhs mb_rhs_ty - ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind parent + ; tycon <- buildSynTyCon tc_name tyvars roles rhs rhs_kind parent ; return (ATyCon tycon) } where mk_doc n = ptext (sLit "Type syonym") <+> ppr n - tc_syn_rhs (SynFamilyTyCon a b) = return (SynFamilyTyCon a b) - tc_syn_rhs (SynonymTyCon ty) = do { rhs_ty <- tcIfaceType ty - ; return (SynonymTyCon rhs_ty) } + tc_syn_rhs IfaceOpenSynFamilyTyCon = return OpenSynFamilyTyCon + tc_syn_rhs (IfaceClosedSynFamilyTyCon ax_name) + = do { ax <- tcIfaceCoAxiom ax_name + ; return (ClosedSynFamilyTyCon ax) } + tc_syn_rhs IfaceAbstractClosedSynFamilyTyCon = return AbstractClosedSynFamilyTyCon + tc_syn_rhs (IfaceSynonymTyCon ty) = do { rhs_ty <- tcIfaceType ty + ; return (SynonymTyCon rhs_ty) } tc_iface_decl _parent ignore_prags (IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ, - ifTyVars = tv_bndrs, ifFDs = rdr_fds, + ifTyVars = tv_bndrs, ifRoles = roles, ifFDs = rdr_fds, ifATs = rdr_ats, ifSigs = rdr_sigs, ifRec = tc_isrec }) -- ToDo: in hs-boot files we should really treat abstract classes specially, @@ -504,7 +517,7 @@ tc_iface_decl _parent ignore_prags ; cls <- fixM $ \ cls -> do { ats <- mapM (tc_at cls) rdr_ats ; traceIf (text "tc-iface-class4" <+> ppr tc_occ) - ; buildClass ignore_prags tc_name tyvars ctxt fds ats sigs tc_isrec } + ; buildClass ignore_prags tc_name tyvars roles ctxt fds ats sigs tc_isrec } ; return (ATyCon (classTyCon cls)) } where tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred) @@ -515,7 +528,6 @@ tc_iface_decl _parent ignore_prags -- data T a -- Here the associated type T is knot-tied with the class, and -- so we must not pull on T too eagerly. See Trac #5970 - mk_sc_doc pred = ptext (sLit "Superclass") <+> ppr pred tc_sig (IfaceClassOp occ dm rdr_ty) = do { op_name <- lookupIfaceTop occ @@ -527,9 +539,15 @@ tc_iface_decl _parent ignore_prags tc_at cls (IfaceAT tc_decl defs_decls) = do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl - defs <- mapM tc_ax_branch defs_decls + defs <- forkM (mk_at_doc tc) $ + foldlM tc_ax_branches [] defs_decls + -- Must be done lazily in case the RHS of the defaults mention + -- the type constructor being defined here + -- e.g. type AT a; type AT b = AT [b] Trac #8002 return (tc, defs) + mk_sc_doc pred = ptext (sLit "Superclass") <+> ppr pred + mk_at_doc tc = ptext (sLit "Associated type") <+> ppr tc mk_op_doc op_name op_ty = ptext (sLit "Class op") <+> sep [ppr op_name, ppr op_ty] tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1 @@ -539,28 +557,36 @@ tc_iface_decl _parent ignore_prags tc_iface_decl _ _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) = do { name <- lookupIfaceTop rdr_name ; return (ATyCon (mkForeignTyCon name ext_name - liftedTypeKind 0)) } + liftedTypeKind)) } -tc_iface_decl _ _ (IfaceAxiom {ifName = ax_occ, ifTyCon = tc, ifAxBranches = branches}) +tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc + , ifAxBranches = branches, ifRole = role }) = do { tc_name <- lookupIfaceTop ax_occ ; tc_tycon <- tcIfaceTyCon tc - ; tc_branches <- mapM tc_ax_branch branches - ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name + ; tc_branches <- foldlM tc_ax_branches [] branches + ; let axiom = computeAxiomIncomps $ + CoAxiom { co_ax_unique = nameUnique tc_name , co_ax_name = tc_name , co_ax_tc = tc_tycon + , co_ax_role = role , co_ax_branches = toBranchList tc_branches , co_ax_implicit = False } ; return (ACoAxiom axiom) } -tc_ax_branch :: IfaceAxBranch -> IfL CoAxBranch -tc_ax_branch (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs }) +tc_ax_branches :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch] +tc_ax_branches prev_branches + (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs + , ifaxbRoles = roles, ifaxbIncomps = incomps }) = bindIfaceTyVars tv_bndrs $ \ tvs -> do -- Variables will all be fresh { tc_lhs <- mapM tcIfaceType lhs ; tc_rhs <- tcIfaceType rhs - ; return (CoAxBranch { cab_loc = noSrcSpan - , cab_tvs = tvs - , cab_lhs = tc_lhs - , cab_rhs = tc_rhs } ) } + ; let br = CoAxBranch { cab_loc = noSrcSpan + , cab_tvs = tvs + , cab_lhs = tc_lhs + , cab_roles = roles + , cab_rhs = tc_rhs + , cab_incomps = map (prev_branches !!) incomps } + ; return (prev_branches ++ [br]) } tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs tcIfaceDataCons tycon_name tycon _ if_cons @@ -656,13 +682,15 @@ tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs ; return (mkImportedInstance cls mb_tcs' dfun oflag) } -tcIfaceFamInst :: IfaceFamInst -> IfL (FamInst Branched) -tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcss - , ifFamInstGroup = group, ifFamInstAxiom = axiom_name } ) +tcIfaceFamInst :: IfaceFamInst -> IfL FamInst +tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs + , ifFamInstAxiom = axiom_name } ) = do { axiom' <- forkM (ptext (sLit "Axiom") <+> ppr axiom_name) $ tcIfaceCoAxiom axiom_name - ; let mb_tcss' = map (map (fmap ifaceTyConName)) mb_tcss - ; return (mkImportedFamInst fam group mb_tcss' axiom') } + -- will panic if branched, but that's OK + ; let axiom'' = toUnbranchedAxiom axiom' + mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedFamInst fam mb_tcs' axiom'') } \end{code} @@ -892,7 +920,6 @@ tcIfaceType (IfaceTyConApp tc tks) = do { tc' <- tcIfaceTyCon tc ; tks' <- tcIfaceTcArgs (tyConKind tc') tks ; return (mkTyConApp tc' tks') } tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') } -tcIfaceType t@(IfaceCoConApp {}) = pprPanic "tcIfaceType" (ppr t) tcIfaceTypes :: [IfaceType] -> IfL [Type] tcIfaceTypes tys = mapM tcIfaceType tys @@ -960,28 +987,29 @@ This context business is why we need tcIfaceTcArgs. %************************************************************************ \begin{code} -tcIfaceCo :: IfaceType -> IfL Coercion -tcIfaceCo (IfaceTyVar n) = mkCoVarCo <$> tcIfaceCoVar n -tcIfaceCo (IfaceAppTy t1 t2) = mkAppCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 -tcIfaceCo (IfaceFunTy t1 t2) = mkFunCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 -tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIfaceCo ts -tcIfaceCo t@(IfaceLitTy _) = mkReflCo <$> tcIfaceType t -tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts -tcIfaceCo (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> - mkForAllCo tv' <$> tcIfaceCo t - -tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion -tcIfaceCoApp IfaceReflCo [t] = Refl <$> tcIfaceType t -tcIfaceCoApp (IfaceCoAx n i) ts = AxiomInstCo <$> tcIfaceCoAxiom n - <*> pure i - <*> mapM tcIfaceCo ts -tcIfaceCoApp IfaceUnsafeCo [t1,t2] = UnsafeCo <$> tcIfaceType t1 <*> tcIfaceType t2 -tcIfaceCoApp IfaceSymCo [t] = SymCo <$> tcIfaceCo t -tcIfaceCoApp IfaceTransCo [t1,t2] = TransCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 -tcIfaceCoApp IfaceInstCo [t1,t2] = InstCo <$> tcIfaceCo t1 <*> tcIfaceType t2 -tcIfaceCoApp (IfaceNthCo d) [t] = NthCo d <$> tcIfaceCo t -tcIfaceCoApp (IfaceLRCo lr) [t] = LRCo lr <$> tcIfaceCo t -tcIfaceCoApp cc ts = pprPanic "toIfaceCoApp" (ppr cc <+> ppr ts) +tcIfaceCo :: IfaceCoercion -> IfL Coercion +tcIfaceCo (IfaceReflCo r t) = mkReflCo r <$> tcIfaceType t +tcIfaceCo (IfaceFunCo r c1 c2) = mkFunCo r <$> tcIfaceCo c1 <*> tcIfaceCo c2 +tcIfaceCo (IfaceTyConAppCo r tc cs) = mkTyConAppCo r <$> tcIfaceTyCon tc + <*> mapM tcIfaceCo cs +tcIfaceCo (IfaceAppCo c1 c2) = mkAppCo <$> tcIfaceCo c1 + <*> tcIfaceCo c2 +tcIfaceCo (IfaceForAllCo tv c) = bindIfaceTyVar tv $ \ tv' -> + mkForAllCo tv' <$> tcIfaceCo c +tcIfaceCo (IfaceCoVarCo n) = mkCoVarCo <$> tcIfaceCoVar n +tcIfaceCo (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n + <*> pure i + <*> mapM tcIfaceCo cs +tcIfaceCo (IfaceUnivCo r t1 t2) = UnivCo r <$> tcIfaceType t1 + <*> tcIfaceType t2 +tcIfaceCo (IfaceSymCo c) = SymCo <$> tcIfaceCo c +tcIfaceCo (IfaceTransCo c1 c2) = TransCo <$> tcIfaceCo c1 + <*> tcIfaceCo c2 +tcIfaceCo (IfaceInstCo c1 t2) = InstCo <$> tcIfaceCo c1 + <*> tcIfaceType t2 +tcIfaceCo (IfaceNthCo d c) = NthCo d <$> tcIfaceCo c +tcIfaceCo (IfaceLRCo lr c) = LRCo lr <$> tcIfaceCo c +tcIfaceCo (IfaceSubCo c) = SubCo <$> tcIfaceCo c tcIfaceCoVar :: FastString -> IfL CoVar tcIfaceCoVar = tcIfaceLclId @@ -1263,15 +1291,15 @@ tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr) (UnfWhen unsat_ok boring_ok)) } -tcUnfolding name dfun_ty _ (IfDFunUnfold ops) - = do { mb_ops1 <- forkM_maybe doc $ mapM tc_arg ops +tcUnfolding name dfun_ty _ (IfDFunUnfold bs ops) + = bindIfaceBndrs bs $ \ bs' -> + do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops ; return (case mb_ops1 of Nothing -> noUnfolding - Just ops1 -> mkDFunUnfolding dfun_ty ops1) } + Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) } where doc = text "Class ops for dfun" <+> ppr name - tc_arg (DFunPolyArg e) = do { e' <- tcIfaceExpr e; return (DFunPolyArg e') } - tc_arg (DFunLamArg i) = return (DFunLamArg i) + (_, _, cls, _) = tcSplitDFunTy dfun_ty tcUnfolding name _ info (IfWrapper if_expr) = do { mb_expr <- tcPragExpr name if_expr diff --git a/compiler/iface/TcIface.lhs-boot b/compiler/iface/TcIface.lhs-boot index 58df07cdc4..591419a251 100644 --- a/compiler/iface/TcIface.lhs-boot +++ b/compiler/iface/TcIface.lhs-boot @@ -5,7 +5,7 @@ import IfaceSyn ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule, IfaceAnno import TypeRep ( TyThing ) import TcRnTypes ( IfL ) import InstEnv ( ClsInst ) -import FamInstEnv ( FamInst, Branched ) +import FamInstEnv ( FamInst ) import CoreSyn ( CoreRule ) import HscTypes ( TypeEnv, VectInfo, IfaceVectInfo ) import Module ( Module ) @@ -15,7 +15,7 @@ tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo tcIfaceInst :: IfaceClsInst -> IfL ClsInst -tcIfaceFamInst :: IfaceFamInst -> IfL (FamInst Branched) +tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] \end{code} diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs index d69b88ce23..85095997ae 100644 --- a/compiler/llvmGen/Llvm.hs +++ b/compiler/llvmGen/Llvm.hs @@ -32,20 +32,22 @@ module Llvm ( -- * Variables and Type System LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..), - LlvmAlias, LMGlobal, LMString, LMSection, LMAlign, + LlvmAlias, LMGlobal(..), LMString, LMSection, LMAlign, + LMConst(..), -- ** Some basic types i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr, -- ** Metadata types - LlvmMetaVal(..), LlvmMetaUnamed(..), LlvmMeta(..), MetaData, + MetaExpr(..), MetaAnnot(..), MetaDecl(..), -- ** Operations on the type system. - isGlobal, getLitType, getLit, getName, getPlainName, getVarType, - getLink, getStatType, getGlobalVar, getGlobalType, pVarLift, pVarLower, + isGlobal, getLitType, getVarType, + getLink, getStatType, pVarLift, pVarLower, pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits, -- * Pretty Printing + ppLit, ppName, ppPlainName, ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals, ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta, @@ -53,6 +55,7 @@ module Llvm ( ) where import Llvm.AbsSyn +import Llvm.MetaData import Llvm.PpLlvm import Llvm.Types diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs index f5f5eacdee..f92bd89c5c 100644 --- a/compiler/llvmGen/Llvm/AbsSyn.hs +++ b/compiler/llvmGen/Llvm/AbsSyn.hs @@ -4,6 +4,7 @@ module Llvm.AbsSyn where +import Llvm.MetaData import Llvm.Types import Unique @@ -32,7 +33,7 @@ data LlvmModule = LlvmModule { modAliases :: [LlvmAlias], -- | LLVM meta data. - modMeta :: [LlvmMeta], + modMeta :: [MetaDecl], -- | Global variables to include in the module. modGlobals :: [LMGlobal], @@ -165,11 +166,9 @@ data LlvmStatement {- | A LLVM statement with metadata attached to it. -} - | MetaStmt [MetaData] LlvmStatement + | MetaStmt [MetaAnnot] LlvmStatement - deriving (Show, Eq) - -type MetaData = (LMString, LlvmMetaUnamed) + deriving (Eq) -- | Llvm Expressions @@ -253,6 +252,17 @@ data LlvmExpression | Call LlvmCallType LlvmVar [LlvmVar] [LlvmFuncAttr] {- | + Call a function as above but potentially taking metadata as arguments. + * tailJumps: CallType to signal if the function should be tail called + * fnptrval: An LLVM value containing a pointer to a function to be + invoked. Can be indirect. Should be LMFunction type. + * args: Arguments that may include metadata. + * attrs: A list of function attributes for the call. Only NoReturn, + NoUnwind, ReadOnly and ReadNone are valid here. + -} + | CallM LlvmCallType LlvmVar [MetaExpr] [LlvmFuncAttr] + + {- | Merge variables from different basic blocks which are predecessors of this basic block in a new variable of type tp. * tp: type of the merged variable, must match the types of the @@ -264,21 +274,21 @@ data LlvmExpression {- | Inline assembly expression. Syntax is very similar to the style used by GCC. - * assembly: Actual inline assembly code. - * contraints: Operand constraints. - * return ty: Return type of function. - * vars: Any variables involved in the assembly code. - * sideeffect: Does the expression have side effects not visible from the - constraints list. - * alignstack: Should the stack be conservatively aligned before this - expression is executed. + * assembly: Actual inline assembly code. + * constraints: Operand constraints. + * return ty: Return type of function. + * vars: Any variables involved in the assembly code. + * sideeffect: Does the expression have side effects not visible from the + constraints list. + * alignstack: Should the stack be conservatively aligned before this + expression is executed. -} | Asm LMString LMString LlvmType [LlvmVar] Bool Bool {- | A LLVM expression with metadata attached to it. -} - | MetaExpr [MetaData] LlvmExpression + | MExpr [MetaAnnot] LlvmExpression - deriving (Show, Eq) + deriving (Eq) diff --git a/compiler/llvmGen/Llvm/MetaData.hs b/compiler/llvmGen/Llvm/MetaData.hs new file mode 100644 index 0000000000..dda3ca0c4c --- /dev/null +++ b/compiler/llvmGen/Llvm/MetaData.hs @@ -0,0 +1,84 @@ +-------------------------------------------------------------------------------- +-- | The LLVM Metadata System. +-- +-- The LLVM metadata feature is poorly documented but roughly follows the +-- following design: +-- * Metadata can be constructed in a few different ways (See below). +-- * After which it can either be attached to LLVM statements to pass along +-- extra information to the optimizer and code generator OR specificially named +-- metadata has an affect on the whole module (i.e., linking behaviour). +-- +-- +-- # Constructing metadata +-- Metadata comes largely in three forms: +-- +-- * Metadata expressions -- these are the raw metadata values that encode +-- information. They consist of metadata strings, metadata nodes, regular +-- LLVM values (both literals and references to global variables) and +-- metadata expressions (i.e., recursive data type). Some examples: +-- !{ metadata !"hello", metadata !0, i32 0 } +-- !{ metadata !1, metadata !{ i32 0 } } +-- +-- * Metadata nodes -- global metadata variables that attach a metadata +-- expression to a number. For example: +-- !0 = metadata !{ [<metadata expressions>] !} +-- +-- * Named metadata -- global metadata variables that attach a metadata nodes +-- to a name. Used ONLY to communicated module level information to LLVM +-- through a meaningful name. For example: +-- !llvm.module.linkage = !{ !0, !1 } +-- +-- +-- # Using Metadata +-- Using metadata depends on the form it is in: +-- +-- * Attach to instructions -- metadata can be attached to LLVM instructions +-- using a specific reference as follows: +-- %l = load i32* @glob, !nontemporal !10 +-- %m = load i32* @glob, !nontemporal !{ i32 0, metadata !{ i32 0 } } +-- Only metadata nodes or expressions can be attached, named metadata cannot. +-- Refer to LLVM documentation for which instructions take metadata and its +-- meaning. +-- +-- * As arguments -- llvm functions can take metadata as arguments, for +-- example: +-- call void @llvm.dbg.value(metadata !{ i32 0 }, i64 0, metadata !1) +-- As with instructions, only metadata nodes or expressions can be attached. +-- +-- * As a named metadata -- Here the metadata is simply declared in global +-- scope using a specific name to communicate module level information to LLVM. +-- For example: +-- !llvm.module.linkage = !{ !0, !1 } +-- +module Llvm.MetaData where + +import Llvm.Types + +import Outputable + +-- | LLVM metadata expressions +data MetaExpr = MetaStr LMString + | MetaNode Int + | MetaVar LlvmVar + | MetaStruct [MetaExpr] + deriving (Eq) + +instance Outputable MetaExpr where + ppr (MetaStr s ) = text "metadata !\"" <> ftext s <> char '"' + ppr (MetaNode n ) = text "metadata !" <> int n + ppr (MetaVar v ) = ppr v + ppr (MetaStruct es) = text "metadata !{ " <> ppCommaJoin es <> char '}' + +-- | Associates some metadata with a specific label for attaching to an +-- instruction. +data MetaAnnot = MetaAnnot LMString MetaExpr + deriving (Eq) + +-- | Metadata declarations. Metadata can only be declared in global scope. +data MetaDecl + -- | Named metadata. Only used for communicating module information to + -- LLVM. ('!name = !{ [!<n>] }' form). + = MetaNamed LMString [Int] + -- | Metadata node declaration. + -- ('!0 = metadata !{ <metadata expression> }' form). + | MetaUnamed Int MetaExpr diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index a709a05b7d..fca1a7cd4d 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -24,11 +24,13 @@ module Llvm.PpLlvm ( #include "HsVersions.h" import Llvm.AbsSyn +import Llvm.MetaData import Llvm.Types import Data.List ( intersperse ) import Outputable import Unique +import FastString ( sLit ) -------------------------------------------------------------------------------- -- * Top Level Print functions @@ -59,7 +61,7 @@ ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls -- | Print out a global mutable variable definition ppLlvmGlobal :: LMGlobal -> SDoc -ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) = +ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) = let sect = case x of Just x' -> text ", section" <+> doubleQuotes (ftext x') Nothing -> empty @@ -69,15 +71,21 @@ ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) = Nothing -> empty rhs = case dat of - Just stat -> texts stat - Nothing -> texts (pLower $ getVarType var) + Just stat -> ppr stat + Nothing -> ppr (pLower $ getVarType var) - const' = if c then text "constant" else text "global" + -- Position of linkage is different for aliases. + const_link = case c of + Global -> ppr link <+> text "global" + Constant -> ppr link <+> text "constant" + Alias -> text "alias" <+> ppr link - in ppAssignment var $ texts link <+> const' <+> rhs <> sect <> align + in ppAssignment var $ const_link <+> rhs <> sect <> align $+$ newLine -ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth +ppLlvmGlobal (LMGlobal var val) = sdocWithDynFlags $ \dflags -> + error $ "Non Global var ppr as global! " + ++ showSDoc dflags (ppr var) ++ " " ++ showSDoc dflags (ppr val) -- | Print out a list of LLVM type aliases. @@ -87,32 +95,31 @@ ppLlvmAliases tys = vcat $ map ppLlvmAlias tys -- | Print out an LLVM type alias. ppLlvmAlias :: LlvmAlias -> SDoc ppLlvmAlias (name, ty) - = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty + = char '%' <> ftext name <+> equals <+> text "type" <+> ppr ty -- | Print out a list of LLVM metadata. -ppLlvmMetas :: [LlvmMeta] -> SDoc +ppLlvmMetas :: [MetaDecl] -> SDoc ppLlvmMetas metas = vcat $ map ppLlvmMeta metas -- | Print out an LLVM metadata definition. -ppLlvmMeta :: LlvmMeta -> SDoc -ppLlvmMeta (MetaUnamed (LMMetaUnamed u) metas) - = exclamation <> int u <> text " = metadata !{" <> - hcat (intersperse comma $ map ppLlvmMetaVal metas) <> text "}" - -ppLlvmMeta (MetaNamed n metas) - = exclamation <> ftext n <> text " = !{" <> - hcat (intersperse comma $ map pprNode munq) <> text "}" +ppLlvmMeta :: MetaDecl -> SDoc +ppLlvmMeta (MetaUnamed n m) + = exclamation <> int n <> text " = " <> ppLlvmMetaExpr m + +ppLlvmMeta (MetaNamed n m) + = exclamation <> ftext n <> text " = !" <> braces nodes where - munq = map (\(LMMetaUnamed u) -> u) metas + nodes = hcat $ intersperse comma $ map pprNode m pprNode n = exclamation <> int n -- | Print out an LLVM metadata value. -ppLlvmMetaVal :: LlvmMetaVal -> SDoc -ppLlvmMetaVal (MetaStr s) = text "metadata !" <> doubleQuotes (ftext s) -ppLlvmMetaVal (MetaVar v) = texts v -ppLlvmMetaVal (MetaNode (LMMetaUnamed u)) - = text "metadata !" <> int u +ppLlvmMetaExpr :: MetaExpr -> SDoc +ppLlvmMetaExpr (MetaStr s ) = text "metadata !" <> doubleQuotes (ftext s) +ppLlvmMetaExpr (MetaNode n ) = text "metadata !" <> int n +ppLlvmMetaExpr (MetaVar v ) = ppr v +ppLlvmMetaExpr (MetaStruct es) = + text "metadata !{" <> hsep (punctuate comma (map ppLlvmMetaExpr es)) <> char '}' -- | Print out a list of function definitions. @@ -138,17 +145,17 @@ ppLlvmFunction (LlvmFunction dec args attrs sec body) = ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args = let varg' = case varg of - VarArgs | null p -> text "..." - | otherwise -> text ", ..." - _otherwise -> empty + VarArgs | null p -> sLit "..." + | otherwise -> sLit ", ..." + _otherwise -> sLit "" align = case a of - Just a' -> text " align" <+> texts a' + Just a' -> text " align " <> ppr a' Nothing -> empty - args' = map (\((ty,p),n) -> texts ty <+> ppSpaceJoin p <+> text "%" + args' = map (\((ty,p),n) -> ppr ty <+> ppSpaceJoin p <+> char '%' <> ftext n) (zip p args) - in texts l <+> texts c <+> texts r <+> text "@" <> ftext n <> lparen <> - (hcat $ intersperse (comma <> space) args') <> varg' <> rparen <> align + in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <> + (hsep $ punctuate comma args') <> ptext varg' <> rparen <> align -- | Print out a list of function declaration. ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc @@ -160,16 +167,16 @@ ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) = let varg' = case varg of - VarArgs | null p -> text "..." - | otherwise -> text ", ..." - _otherwise -> empty + VarArgs | null p -> sLit "..." + | otherwise -> sLit ", ..." + _otherwise -> sLit "" align = case a of - Just a' -> text " align" <+> texts a' + Just a' -> text " align" <+> ppr a' Nothing -> empty args = hcat $ intersperse (comma <> space) $ - map (\(t,a) -> texts t <+> ppSpaceJoin a) p - in text "declare" <+> texts l <+> texts c <+> texts r <+> text "@" <> - ftext n <> lparen <> args <> varg' <> rparen <> align $+$ newLine + map (\(t,a) -> ppr t <+> ppSpaceJoin a) p + in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <> + ftext n <> lparen <> args <> ptext varg' <> rparen <> align $+$ newLine -- | Print out a list of LLVM blocks. @@ -179,19 +186,14 @@ ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks -- | Print out an LLVM block. -- It must be part of a function definition. ppLlvmBlock :: LlvmBlock -> SDoc -ppLlvmBlock (LlvmBlock blockId stmts) - = go blockId stmts - where - lbreak acc [] = (Nothing, reverse acc, []) - lbreak acc (MkLabel id:xs) = (Just id, reverse acc, xs) - lbreak acc (x:xs) = lbreak (x:acc) xs - - go id code = - let (id2, block, rest) = lbreak [] code - ppRest = case id2 of - Just id2' -> go id2' rest - Nothing -> empty - in ppLlvmBlockLabel id +ppLlvmBlock (LlvmBlock blockId stmts) = + let isLabel (MkLabel _) = True + isLabel _ = False + (block, rest) = break isLabel stmts + ppRest = case rest of + MkLabel id:xs -> ppLlvmBlock (LlvmBlock id xs) + _ -> empty + in ppLlvmBlockLabel blockId $+$ (vcat $ map ppLlvmStatement block) $+$ newLine $+$ ppRest @@ -227,7 +229,8 @@ ppLlvmExpression expr = case expr of Alloca tp amount -> ppAlloca tp amount LlvmOp op left right -> ppMachOp op left right - Call tp fp args attrs -> ppCall tp fp args attrs + Call tp fp args attrs -> ppCall tp fp (map MetaVar args) attrs + CallM tp fp args attrs -> ppCall tp fp args attrs Cast op from to -> ppCast op from to Compare op left right -> ppCmpOp op left right Extract vec idx -> ppExtract vec idx @@ -237,7 +240,7 @@ ppLlvmExpression expr Malloc tp amount -> ppMalloc tp amount Phi tp precessors -> ppPhi tp precessors Asm asm c ty v se sk -> ppAsm asm c ty v se sk - MetaExpr meta expr -> ppMetaExpr meta expr + MExpr meta expr -> ppMetaExpr meta expr -------------------------------------------------------------------------------- @@ -246,8 +249,8 @@ ppLlvmExpression expr -- | Should always be a function pointer. So a global var of function type -- (since globals are always pointers) or a local var of pointer function type. -ppCall :: LlvmCallType -> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> SDoc -ppCall ct fptr vals attrs = case fptr of +ppCall :: LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc +ppCall ct fptr args attrs = case fptr of -- -- if local var function pointer, unwrap LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d @@ -263,23 +266,22 @@ ppCall ct fptr vals attrs = case fptr of where ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) = let tc = if ct == TailCall then text "tail " else empty - ppValues = ppCommaJoin vals - ppParams = map (texts . fst) params - ppArgTy = (hcat $ intersperse comma ppParams) <> + ppValues = ppCommaJoin args + ppArgTy = (ppCommaJoin $ map fst params) <> (case argTy of VarArgs -> text ", ..." FixedArgs -> empty) - fnty = space <> lparen <> ppArgTy <> rparen <> text "*" + fnty = space <> lparen <> ppArgTy <> rparen <> char '*' attrDoc = ppSpaceJoin attrs - in tc <> text "call" <+> texts cc <+> texts ret - <> fnty <+> (text $ getName fptr) <> lparen <+> ppValues + in tc <> text "call" <+> ppr cc <+> ppr ret + <> fnty <+> ppName fptr <> lparen <+> ppValues <+> rparen <+> attrDoc ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc ppMachOp op left right = - (texts op) <+> (texts (getVarType left)) <+> (text $ getName left) - <> comma <+> (text $ getName right) + (ppr op) <+> (ppr (getVarType left)) <+> ppName left + <> comma <+> ppName right ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc @@ -293,12 +295,12 @@ ppCmpOp op left right = ++ (show $ getVarType left) ++ ", right = " ++ (show $ getVarType right)) -} - in cmpOp <+> texts op <+> texts (getVarType left) - <+> (text $ getName left) <> comma <+> (text $ getName right) + in cmpOp <+> ppr op <+> ppr (getVarType left) + <+> ppName left <> comma <+> ppName right ppAssignment :: LlvmVar -> SDoc -> SDoc -ppAssignment var expr = (text $ getName var) <+> equals <+> expr +ppAssignment var expr = ppName var <+> equals <+> expr ppFence :: Bool -> LlvmSyncOrdering -> SDoc ppFence st ord = @@ -324,72 +326,71 @@ ppSyncOrdering SyncSeqCst = text "seq_cst" ppLoad :: LlvmVar -> SDoc ppLoad var - | isVecPtrVar var = text "load" <+> texts var <> + | isVecPtrVar var = text "load" <+> ppr var <> comma <+> text "align 1" - | otherwise = text "load" <+> texts var + | otherwise = text "load" <+> ppr var where isVecPtrVar :: LlvmVar -> Bool isVecPtrVar = isVector . pLower . getVarType ppStore :: LlvmVar -> LlvmVar -> SDoc ppStore val dst - | isVecPtrVar dst = text "store" <+> texts val <> comma <+> texts dst <> + | isVecPtrVar dst = text "store" <+> ppr val <> comma <+> ppr dst <> comma <+> text "align 1" - | otherwise = text "store" <+> texts val <> comma <+> texts dst + | otherwise = text "store" <+> ppr val <> comma <+> ppr dst where isVecPtrVar :: LlvmVar -> Bool isVecPtrVar = isVector . pLower . getVarType ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc -ppCast op from to = texts op <+> texts from <+> text "to" <+> texts to +ppCast op from to = ppr op <+> ppr from <+> text "to" <+> ppr to ppMalloc :: LlvmType -> Int -> SDoc ppMalloc tp amount = let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 - in text "malloc" <+> texts tp <> comma <+> texts amount' + in text "malloc" <+> ppr tp <> comma <+> ppr amount' ppAlloca :: LlvmType -> Int -> SDoc ppAlloca tp amount = let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 - in text "alloca" <+> texts tp <> comma <+> texts amount' + in text "alloca" <+> ppr tp <> comma <+> ppr amount' ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc ppGetElementPtr inb ptr idx = let indexes = comma <+> ppCommaJoin idx inbound = if inb then text "inbounds" else empty - in text "getelementptr" <+> inbound <+> texts ptr <> indexes + in text "getelementptr" <+> inbound <+> ppr ptr <> indexes ppReturn :: Maybe LlvmVar -> SDoc -ppReturn (Just var) = text "ret" <+> texts var -ppReturn Nothing = text "ret" <+> texts LMVoid +ppReturn (Just var) = text "ret" <+> ppr var +ppReturn Nothing = text "ret" <+> ppr LMVoid ppBranch :: LlvmVar -> SDoc -ppBranch var = text "br" <+> texts var +ppBranch var = text "br" <+> ppr var ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc ppBranchIf cond trueT falseT - = text "br" <+> texts cond <> comma <+> texts trueT <> comma <+> texts falseT + = text "br" <+> ppr cond <> comma <+> ppr trueT <> comma <+> ppr falseT ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc ppPhi tp preds = - let ppPreds (val, label) = brackets $ (text $ getName val) <> comma - <+> (text $ getName label) - in text "phi" <+> texts tp <+> hcat (intersperse comma $ map ppPreds preds) + let ppPreds (val, label) = brackets $ ppName val <> comma <+> ppName label + in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds) ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc ppSwitch scrut dflt targets = - let ppTarget (val, lab) = texts val <> comma <+> texts lab + let ppTarget (val, lab) = ppr val <> comma <+> ppr lab ppTargets xs = brackets $ vcat (map ppTarget xs) - in text "switch" <+> texts scrut <> comma <+> texts dflt + in text "switch" <+> ppr scrut <> comma <+> ppr dflt <+> ppTargets targets @@ -397,7 +398,7 @@ ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc ppAsm asm constraints rty vars sideeffect alignstack = let asm' = doubleQuotes $ ftext asm cons = doubleQuotes $ ftext constraints - rty' = texts rty + rty' = ppr rty vars' = lparen <+> ppCommaJoin vars <+> rparen side = if sideeffect then text "sideeffect" else empty align = if alignstack then text "alignstack" else empty @@ -407,49 +408,42 @@ ppAsm asm constraints rty vars sideeffect alignstack = ppExtract :: LlvmVar -> LlvmVar -> SDoc ppExtract vec idx = text "extractelement" - <+> texts (getVarType vec) <+> text (getName vec) <> comma - <+> texts idx + <+> ppr (getVarType vec) <+> ppName vec <> comma + <+> ppr idx ppInsert :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc ppInsert vec elt idx = text "insertelement" - <+> texts (getVarType vec) <+> text (getName vec) <> comma - <+> texts (getVarType elt) <+> text (getName elt) <> comma - <+> texts idx - -ppMetaStatement :: [MetaData] -> LlvmStatement -> SDoc -ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetas meta + <+> ppr (getVarType vec) <+> ppName vec <> comma + <+> ppr (getVarType elt) <+> ppName elt <> comma + <+> ppr idx -ppMetaExpr :: [MetaData] -> LlvmExpression -> SDoc -ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetas meta +ppMetaStatement :: [MetaAnnot] -> LlvmStatement -> SDoc +ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetaAnnots meta +ppMetaExpr :: [MetaAnnot] -> LlvmExpression -> SDoc +ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetaAnnots meta -ppMetas :: [MetaData] -> SDoc -ppMetas meta = hcat $ map ppMeta meta +ppMetaAnnots :: [MetaAnnot] -> SDoc +ppMetaAnnots meta = hcat $ map ppMeta meta where - ppMeta (name, (LMMetaUnamed n)) - = comma <+> exclamation <> ftext name <+> exclamation <> int n + ppMeta (MetaAnnot name e) + = comma <+> exclamation <> ftext name <+> + case e of + MetaNode n -> exclamation <> int n + MetaStruct ms -> exclamation <> braces (ppCommaJoin ms) + other -> exclamation <> braces (ppr other) -- possible? -------------------------------------------------------------------------------- -- * Misc functions -------------------------------------------------------------------------------- -ppCommaJoin :: (Show a) => [a] -> SDoc -ppCommaJoin strs = hcat $ intersperse (comma <> space) (map texts strs) - -ppSpaceJoin :: (Show a) => [a] -> SDoc -ppSpaceJoin strs = hcat $ intersperse space (map texts strs) - --- | Showable to SDoc -texts :: (Show a) => a -> SDoc -texts = (text . show) -- | Blank line. newLine :: SDoc -newLine = text "" +newLine = empty -- | Exclamation point. exclamation :: SDoc -exclamation = text "!" - +exclamation = char '!' diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index 8b33c0b9dd..6b9c8c181a 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + -------------------------------------------------------------------------------- -- | The LLVM Type System. -- @@ -8,12 +10,11 @@ module Llvm.Types where import Data.Char import Data.Int -import Data.List (intercalate) import Numeric import DynFlags import FastString -import Outputable (panic) +import Outputable import Unique -- from NCG @@ -26,7 +27,11 @@ import GHC.Float -- -- | A global mutable variable. Maybe defined or external -type LMGlobal = (LlvmVar, Maybe LlvmStatic) +data LMGlobal = LMGlobal { + getGlobalVar :: LlvmVar, -- ^ Returns the variable of the 'LMGlobal' + getGlobalValue :: Maybe LlvmStatic -- ^ Return the value of the 'LMGlobal' + } + -- | A String in LLVM type LMString = FastString @@ -47,76 +52,49 @@ data LlvmType | LMVoid -- ^ Void type | LMStruct [LlvmType] -- ^ Structure type | LMAlias LlvmAlias -- ^ A type alias + | LMMetadata -- ^ LLVM Metadata -- | Function type, used to create pointers to functions | LMFunction LlvmFunctionDecl deriving (Eq) -instance Show LlvmType where - show (LMInt size ) = "i" ++ show size - show (LMFloat ) = "float" - show (LMDouble ) = "double" - show (LMFloat80 ) = "x86_fp80" - show (LMFloat128 ) = "fp128" - show (LMPointer x ) = show x ++ "*" - show (LMArray nr tp ) = "[" ++ show nr ++ " x " ++ show tp ++ "]" - show (LMVector nr tp ) = "<" ++ show nr ++ " x " ++ show tp ++ ">" - show (LMLabel ) = "label" - show (LMVoid ) = "void" - show (LMStruct tys ) = "<{" ++ (commaCat tys) ++ "}>" - - show (LMFunction (LlvmFunctionDecl _ _ _ r varg p _)) - = let varg' = case varg of - VarArgs | null args -> "..." - | otherwise -> ", ..." - _otherwise -> "" - -- by default we don't print param attributes - args = intercalate ", " $ map (show . fst) p - in show r ++ " (" ++ args ++ varg' ++ ")" - - show (LMAlias (s,_)) = "%" ++ unpackFS s - --- | LLVM metadata values. Used for representing debug and optimization --- information. -data LlvmMetaVal - -- | Metadata string - = MetaStr LMString - -- | Metadata node - | MetaNode LlvmMetaUnamed - -- | Normal value type as metadata - | MetaVar LlvmVar - deriving (Eq) - --- | LLVM metadata nodes. -data LlvmMeta - -- | Unamed metadata - = MetaUnamed LlvmMetaUnamed [LlvmMetaVal] - -- | Named metadata - | MetaNamed LMString [LlvmMetaUnamed] - deriving (Eq) - --- | Unamed metadata variable. -newtype LlvmMetaUnamed = LMMetaUnamed Int - -instance Eq LlvmMetaUnamed where - (==) (LMMetaUnamed n) (LMMetaUnamed m) = n == m - -instance Show LlvmMetaVal where - show (MetaStr s) = "metadata !\"" ++ unpackFS s ++ "\"" - show (MetaNode n) = "metadata " ++ show n - show (MetaVar v) = show v - -instance Show LlvmMetaUnamed where - show (LMMetaUnamed u) = "!" ++ show u - -instance Show LlvmMeta where - show (MetaUnamed m _) = show m - show (MetaNamed m _) = "!" ++ unpackFS m +instance Outputable LlvmType where + ppr (LMInt size ) = char 'i' <> ppr size + ppr (LMFloat ) = text "float" + ppr (LMDouble ) = text "double" + ppr (LMFloat80 ) = text "x86_fp80" + ppr (LMFloat128 ) = text "fp128" + ppr (LMPointer x ) = ppr x <> char '*' + ppr (LMArray nr tp ) = char '[' <> ppr nr <> text " x " <> ppr tp <> char ']' + ppr (LMVector nr tp ) = char '<' <> ppr nr <> text " x " <> ppr tp <> char '>' + ppr (LMLabel ) = text "label" + ppr (LMVoid ) = text "void" + ppr (LMStruct tys ) = text "<{" <> ppCommaJoin tys <> text "}>" + ppr (LMMetadata ) = text "metadata" + + ppr (LMFunction (LlvmFunctionDecl _ _ _ r varg p _)) + = ppr r <+> lparen <> ppParams varg p <> rparen + + ppr (LMAlias (s,_)) = char '%' <> ftext s + +ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc +ppParams varg p + = let varg' = case varg of + VarArgs | null args -> sLit "..." + | otherwise -> sLit ", ..." + _otherwise -> sLit "" + -- by default we don't print param attributes + args = map fst p + in ppCommaJoin args <> ptext varg' -- | An LLVM section definition. If Nothing then let LLVM decide the section type LMSection = Maybe LMString type LMAlign = Maybe Int -type LMConst = Bool -- ^ is a variable constant or not + +data LMConst = Global -- ^ Mutable global variable + | Constant -- ^ Constant global variable + | Alias -- ^ Alias of another variable + deriving (Eq) -- | LLVM Variables data LlvmVar @@ -131,9 +109,9 @@ data LlvmVar | LMLitVar LlvmLit deriving (Eq) -instance Show LlvmVar where - show (LMLitVar x) = show x - show (x ) = show (getVarType x) ++ " " ++ getName x +instance Outputable LlvmVar where + ppr (LMLitVar x) = ppr x + ppr (x ) = ppr (getVarType x) <+> ppName x -- | Llvm Literal Data. @@ -152,9 +130,9 @@ data LlvmLit | LMUndefLit LlvmType deriving (Eq) -instance Show LlvmLit where - show l@(LMVectorLit {}) = getLit l - show l = show (getLitType l) ++ " " ++ getLit l +instance Outputable LlvmLit where + ppr l@(LMVectorLit {}) = ppLit l + ppr l = ppr (getLitType l) <+> ppLit l -- | Llvm Static Data. @@ -177,37 +155,33 @@ data LlvmStatic | LMAdd LlvmStatic LlvmStatic -- ^ Constant addition operation | LMSub LlvmStatic LlvmStatic -- ^ Constant subtraction operation -instance Show LlvmStatic where - show (LMComment s) = "; " ++ unpackFS s - show (LMStaticLit l ) = show l - show (LMUninitType t) = show t ++ " undef" - show (LMStaticStr s t) = show t ++ " c\"" ++ unpackFS s ++ "\\00\"" - show (LMStaticArray d t) = show t ++ " [" ++ commaCat d ++ "]" - show (LMStaticStruc d t) = show t ++ "<{" ++ commaCat d ++ "}>" - show (LMStaticPointer v) = show v - show (LMBitc v t) - = show t ++ " bitcast (" ++ show v ++ " to " ++ show t ++ ")" - show (LMPtoI v t) - = show t ++ " ptrtoint (" ++ show v ++ " to " ++ show t ++ ")" - show (LMAdd s1 s2) - = let ty1 = getStatType s1 - op = if isFloat ty1 then " fadd (" else " add (" - in if ty1 == getStatType s2 - then show ty1 ++ op ++ show s1 ++ "," ++ show s2 ++ ")" - else error $ "LMAdd with different types! s1: " - ++ show s1 ++ ", s2: " ++ show s2 - show (LMSub s1 s2) - = let ty1 = getStatType s1 - op = if isFloat ty1 then " fsub (" else " sub (" - in if ty1 == getStatType s2 - then show ty1 ++ op ++ show s1 ++ "," ++ show s2 ++ ")" - else error $ "LMSub with different types! s1: " - ++ show s1 ++ ", s2: " ++ show s2 - - --- | Concatenate an array together, separated by commas -commaCat :: Show a => [a] -> String -commaCat xs = intercalate ", " $ map show xs +instance Outputable LlvmStatic where + ppr (LMComment s) = text "; " <> ftext s + ppr (LMStaticLit l ) = ppr l + ppr (LMUninitType t) = ppr t <> text " undef" + ppr (LMStaticStr s t) = ppr t <> text " c\"" <> ftext s <> text "\\00\"" + ppr (LMStaticArray d t) = ppr t <> text " [" <> ppCommaJoin d <> char ']' + ppr (LMStaticStruc d t) = ppr t <> text "<{" <> ppCommaJoin d <> text "}>" + ppr (LMStaticPointer v) = ppr v + ppr (LMBitc v t) + = ppr t <> text " bitcast (" <> ppr v <> text " to " <> ppr t <> char ')' + ppr (LMPtoI v t) + = ppr t <> text " ptrtoint (" <> ppr v <> text " to " <> ppr t <> char ')' + + ppr (LMAdd s1 s2) + = pprStaticArith s1 s2 (sLit "add") (sLit "fadd") "LMAdd" + ppr (LMSub s1 s2) + = pprStaticArith s1 s2 (sLit "sub") (sLit "fsub") "LMSub" + +pprStaticArith :: LlvmStatic -> LlvmStatic -> LitString -> LitString -> String -> SDoc +pprStaticArith s1 s2 int_op float_op op_name = + let ty1 = getStatType s1 + op = if isFloat ty1 then float_op else int_op + in if ty1 == getStatType s2 + then ppr ty1 <+> ptext op <+> lparen <> ppr s1 <> comma <> ppr s2 <> rparen + else sdocWithDynFlags $ \dflags -> + error $ op_name ++ " with different types! s1: " + ++ showSDoc dflags (ppr s1) ++ ", s2: " ++ showSDoc dflags (ppr s2) -- ----------------------------------------------------------------------------- -- ** Operations on LLVM Basic Types and Variables @@ -215,33 +189,33 @@ commaCat xs = intercalate ", " $ map show xs -- | Return the variable name or value of the 'LlvmVar' -- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@). -getName :: LlvmVar -> String -getName v@(LMGlobalVar _ _ _ _ _ _) = "@" ++ getPlainName v -getName v@(LMLocalVar _ _ ) = "%" ++ getPlainName v -getName v@(LMNLocalVar _ _ ) = "%" ++ getPlainName v -getName v@(LMLitVar _ ) = getPlainName v +ppName :: LlvmVar -> SDoc +ppName v@(LMGlobalVar {}) = char '@' <> ppPlainName v +ppName v@(LMLocalVar {}) = char '%' <> ppPlainName v +ppName v@(LMNLocalVar {}) = char '%' <> ppPlainName v +ppName v@(LMLitVar {}) = ppPlainName v -- | Return the variable name or value of the 'LlvmVar' -- in a plain textual representation (e.g. @x@, @y@ or @42@). -getPlainName :: LlvmVar -> String -getPlainName (LMGlobalVar x _ _ _ _ _) = unpackFS x -getPlainName (LMLocalVar x LMLabel ) = show x -getPlainName (LMLocalVar x _ ) = "l" ++ show x -getPlainName (LMNLocalVar x _ ) = unpackFS x -getPlainName (LMLitVar x ) = getLit x +ppPlainName :: LlvmVar -> SDoc +ppPlainName (LMGlobalVar x _ _ _ _ _) = ftext x +ppPlainName (LMLocalVar x LMLabel ) = text (show x) +ppPlainName (LMLocalVar x _ ) = text ('l' : show x) +ppPlainName (LMNLocalVar x _ ) = ftext x +ppPlainName (LMLitVar x ) = ppLit x -- | Print a literal value. No type. -getLit :: LlvmLit -> String -getLit (LMIntLit i (LMInt 32)) = show (fromInteger i :: Int32) -getLit (LMIntLit i (LMInt 64)) = show (fromInteger i :: Int64) -getLit (LMIntLit i _ ) = show (fromInteger i :: Int) --- See Note [LLVM Float Types]. -getLit (LMFloatLit r LMFloat ) = (dToStr . widenFp . narrowFp) r -getLit (LMFloatLit r LMDouble) = dToStr r -getLit f@(LMFloatLit _ _) = error $ "Can't print this float literal!" ++ show f -getLit (LMVectorLit ls ) = "< " ++ commaCat ls ++ " >" -getLit (LMNullLit _ ) = "null" -getLit (LMUndefLit _ ) = "undef" +ppLit :: LlvmLit -> SDoc +ppLit (LMIntLit i (LMInt 32)) = ppr (fromInteger i :: Int32) +ppLit (LMIntLit i (LMInt 64)) = ppr (fromInteger i :: Int64) +ppLit (LMIntLit i _ ) = ppr ((fromInteger i)::Int) +ppLit (LMFloatLit r LMFloat ) = ppFloat $ narrowFp r +ppLit (LMFloatLit r LMDouble) = ppDouble r +ppLit f@(LMFloatLit _ _) = sdocWithDynFlags (\dflags -> + error $ "Can't print this float literal!" ++ showSDoc dflags (ppr f)) +ppLit (LMVectorLit ls ) = char '<' <+> ppCommaJoin ls <+> char '>' +ppLit (LMNullLit _ ) = text "null" +ppLit (LMUndefLit _ ) = text "undef" -- | Return the 'LlvmType' of the 'LlvmVar' getVarType :: LlvmVar -> LlvmType @@ -252,12 +226,12 @@ getVarType (LMLitVar l ) = getLitType l -- | Return the 'LlvmType' of a 'LlvmLit' getLitType :: LlvmLit -> LlvmType -getLitType (LMIntLit _ t) = t -getLitType (LMFloatLit _ t) = t +getLitType (LMIntLit _ t) = t +getLitType (LMFloatLit _ t) = t getLitType (LMVectorLit []) = panic "getLitType" getLitType (LMVectorLit ls) = LMVector (length ls) (getLitType (head ls)) -getLitType (LMNullLit t) = t -getLitType (LMUndefLit t) = t +getLitType (LMNullLit t) = t +getLitType (LMUndefLit t) = t -- | Return the 'LlvmType' of the 'LlvmStatic' getStatType :: LlvmStatic -> LlvmType @@ -273,14 +247,6 @@ getStatType (LMAdd t _) = getStatType t getStatType (LMSub t _) = getStatType t getStatType (LMComment _) = error "Can't call getStatType on LMComment!" --- | Return the 'LlvmType' of the 'LMGlobal' -getGlobalType :: LMGlobal -> LlvmType -getGlobalType (v, _) = getVarType v - --- | Return the 'LlvmVar' part of a 'LMGlobal' -getGlobalVar :: LMGlobal -> LlvmVar -getGlobalVar (v, _) = v - -- | Return the 'LlvmLinkageType' for a 'LlvmVar' getLink :: LlvmVar -> LlvmLinkageType getLink (LMGlobalVar _ _ l _ _ _) = l @@ -289,9 +255,10 @@ getLink _ = Internal -- | Add a pointer indirection to the supplied type. 'LMLabel' and 'LMVoid' -- cannot be lifted. pLift :: LlvmType -> LlvmType -pLift (LMLabel) = error "Labels are unliftable" -pLift (LMVoid) = error "Voids are unliftable" -pLift x = LMPointer x +pLift LMLabel = error "Labels are unliftable" +pLift LMVoid = error "Voids are unliftable" +pLift LMMetadata = error "Metadatas are unliftable" +pLift x = LMPointer x -- | Lower a variable of 'LMPointer' type. pVarLift :: LlvmVar -> LlvmVar @@ -304,7 +271,7 @@ pVarLift (LMLitVar _ ) = error $ "Can't lower a literal type!" -- constructors can be lowered. pLower :: LlvmType -> LlvmType pLower (LMPointer x) = x -pLower x = error $ show x ++ " is a unlowerable type, need a pointer" +pLower x = error $ showSDoc undefined (ppr x) ++ " is a unlowerable type, need a pointer" -- | Lower a variable of 'LMPointer' type. pVarLower :: LlvmVar -> LlvmVar @@ -350,14 +317,17 @@ llvmWidthInBits _ (LMFloat80) = 80 llvmWidthInBits _ (LMFloat128) = 128 -- Could return either a pointer width here or the width of what -- it points to. We will go with the former for now. +-- PMW: At least judging by the way LLVM outputs constants, pointers +-- should use the former, but arrays the latter. llvmWidthInBits dflags (LMPointer _) = llvmWidthInBits dflags (llvmWord dflags) -llvmWidthInBits dflags (LMArray _ _) = llvmWidthInBits dflags (llvmWord dflags) +llvmWidthInBits dflags (LMArray n t) = n * llvmWidthInBits dflags t llvmWidthInBits dflags (LMVector n ty) = n * llvmWidthInBits dflags ty llvmWidthInBits _ LMLabel = 0 llvmWidthInBits _ LMVoid = 0 llvmWidthInBits dflags (LMStruct tys) = sum $ map (llvmWidthInBits dflags) tys llvmWidthInBits _ (LMFunction _) = 0 llvmWidthInBits dflags (LMAlias (_,t)) = llvmWidthInBits dflags t +llvmWidthInBits _ LMMetadata = panic "llvmWidthInBits: Meta-data has no runtime representation!" -- ----------------------------------------------------------------------------- @@ -401,19 +371,13 @@ data LlvmFunctionDecl = LlvmFunctionDecl { } deriving (Eq) -instance Show LlvmFunctionDecl where - show (LlvmFunctionDecl n l c r varg p a) - = let varg' = case varg of - VarArgs | null args -> "..." - | otherwise -> ", ..." - _otherwise -> "" - align = case a of - Just a' -> " align " ++ show a' - Nothing -> "" - -- by default we don't print param attributes - args = intercalate ", " $ map (show . fst) p - in show l ++ " " ++ show c ++ " " ++ show r ++ " @" ++ unpackFS n ++ - "(" ++ args ++ varg' ++ ")" ++ align +instance Outputable LlvmFunctionDecl where + ppr (LlvmFunctionDecl n l c r varg p a) + = let align = case a of + Just a' -> text " align " <> ppr a' + Nothing -> empty + in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> + lparen <> ppParams varg p <> rparen <> align type LlvmFunctionDecls = [LlvmFunctionDecl] @@ -454,15 +418,15 @@ data LlvmParamAttr | Nest deriving (Eq) -instance Show LlvmParamAttr where - show ZeroExt = "zeroext" - show SignExt = "signext" - show InReg = "inreg" - show ByVal = "byval" - show SRet = "sret" - show NoAlias = "noalias" - show NoCapture = "nocapture" - show Nest = "nest" +instance Outputable LlvmParamAttr where + ppr ZeroExt = text "zeroext" + ppr SignExt = text "signext" + ppr InReg = text "inreg" + ppr ByVal = text "byval" + ppr SRet = text "sret" + ppr NoAlias = text "noalias" + ppr NoCapture = text "nocapture" + ppr Nest = text "nest" -- | Llvm Function Attributes. -- @@ -542,20 +506,20 @@ data LlvmFuncAttr | Naked deriving (Eq) -instance Show LlvmFuncAttr where - show AlwaysInline = "alwaysinline" - show InlineHint = "inlinehint" - show NoInline = "noinline" - show OptSize = "optsize" - show NoReturn = "noreturn" - show NoUnwind = "nounwind" - show ReadNone = "readnon" - show ReadOnly = "readonly" - show Ssp = "ssp" - show SspReq = "ssqreq" - show NoRedZone = "noredzone" - show NoImplicitFloat = "noimplicitfloat" - show Naked = "naked" +instance Outputable LlvmFuncAttr where + ppr AlwaysInline = text "alwaysinline" + ppr InlineHint = text "inlinehint" + ppr NoInline = text "noinline" + ppr OptSize = text "optsize" + ppr NoReturn = text "noreturn" + ppr NoUnwind = text "nounwind" + ppr ReadNone = text "readnon" + ppr ReadOnly = text "readonly" + ppr Ssp = text "ssp" + ppr SspReq = text "ssqreq" + ppr NoRedZone = text "noredzone" + ppr NoImplicitFloat = text "noimplicitfloat" + ppr Naked = text "naked" -- | Different types to call a function. @@ -600,12 +564,12 @@ data LlvmCallConvention | CC_X86_Stdcc deriving (Eq) -instance Show LlvmCallConvention where - show CC_Ccc = "ccc" - show CC_Fastcc = "fastcc" - show CC_Coldcc = "coldcc" - show (CC_Ncc i) = "cc " ++ show i - show CC_X86_Stdcc = "x86_stdcallcc" +instance Outputable LlvmCallConvention where + ppr CC_Ccc = text "ccc" + ppr CC_Fastcc = text "fastcc" + ppr CC_Coldcc = text "coldcc" + ppr (CC_Ncc i) = text "cc " <> ppr i + ppr CC_X86_Stdcc = text "x86_stdcallcc" -- | Functions can have a fixed amount of parameters, or a variable amount. @@ -659,20 +623,22 @@ data LlvmLinkageType -- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM -- assembly. | External + -- | Symbol is private to the module and should not appear in the symbol table + | Private deriving (Eq) -instance Show LlvmLinkageType where - show Internal = "internal" - show LinkOnce = "linkonce" - show Weak = "weak" - show Appending = "appending" - show ExternWeak = "extern_weak" +instance Outputable LlvmLinkageType where + ppr Internal = text "internal" + ppr LinkOnce = text "linkonce" + ppr Weak = text "weak" + ppr Appending = text "appending" + ppr ExternWeak = text "extern_weak" -- ExternallyVisible does not have a textual representation, it is -- the linkage type a function resolves to if no other is specified -- in Llvm. - show ExternallyVisible = "" - show External = "external" - + ppr ExternallyVisible = empty + ppr External = text "external" + ppr Private = text "private" -- ----------------------------------------------------------------------------- -- * LLVM Operations @@ -709,25 +675,25 @@ data LlvmMachOp | LM_MO_Xor -- ^ XOR bitwise logical operation. deriving (Eq) -instance Show LlvmMachOp where - show LM_MO_Add = "add" - show LM_MO_Sub = "sub" - show LM_MO_Mul = "mul" - show LM_MO_UDiv = "udiv" - show LM_MO_SDiv = "sdiv" - show LM_MO_URem = "urem" - show LM_MO_SRem = "srem" - show LM_MO_FAdd = "fadd" - show LM_MO_FSub = "fsub" - show LM_MO_FMul = "fmul" - show LM_MO_FDiv = "fdiv" - show LM_MO_FRem = "frem" - show LM_MO_Shl = "shl" - show LM_MO_LShr = "lshr" - show LM_MO_AShr = "ashr" - show LM_MO_And = "and" - show LM_MO_Or = "or" - show LM_MO_Xor = "xor" +instance Outputable LlvmMachOp where + ppr LM_MO_Add = text "add" + ppr LM_MO_Sub = text "sub" + ppr LM_MO_Mul = text "mul" + ppr LM_MO_UDiv = text "udiv" + ppr LM_MO_SDiv = text "sdiv" + ppr LM_MO_URem = text "urem" + ppr LM_MO_SRem = text "srem" + ppr LM_MO_FAdd = text "fadd" + ppr LM_MO_FSub = text "fsub" + ppr LM_MO_FMul = text "fmul" + ppr LM_MO_FDiv = text "fdiv" + ppr LM_MO_FRem = text "frem" + ppr LM_MO_Shl = text "shl" + ppr LM_MO_LShr = text "lshr" + ppr LM_MO_AShr = text "ashr" + ppr LM_MO_And = text "and" + ppr LM_MO_Or = text "or" + ppr LM_MO_Xor = text "xor" -- | Llvm compare operations. @@ -753,23 +719,23 @@ data LlvmCmpOp | LM_CMP_Fle -- ^ Float less than or equal deriving (Eq) -instance Show LlvmCmpOp where - show LM_CMP_Eq = "eq" - show LM_CMP_Ne = "ne" - show LM_CMP_Ugt = "ugt" - show LM_CMP_Uge = "uge" - show LM_CMP_Ult = "ult" - show LM_CMP_Ule = "ule" - show LM_CMP_Sgt = "sgt" - show LM_CMP_Sge = "sge" - show LM_CMP_Slt = "slt" - show LM_CMP_Sle = "sle" - show LM_CMP_Feq = "oeq" - show LM_CMP_Fne = "une" - show LM_CMP_Fgt = "ogt" - show LM_CMP_Fge = "oge" - show LM_CMP_Flt = "olt" - show LM_CMP_Fle = "ole" +instance Outputable LlvmCmpOp where + ppr LM_CMP_Eq = text "eq" + ppr LM_CMP_Ne = text "ne" + ppr LM_CMP_Ugt = text "ugt" + ppr LM_CMP_Uge = text "uge" + ppr LM_CMP_Ult = text "ult" + ppr LM_CMP_Ule = text "ule" + ppr LM_CMP_Sgt = text "sgt" + ppr LM_CMP_Sge = text "sge" + ppr LM_CMP_Slt = text "slt" + ppr LM_CMP_Sle = text "sle" + ppr LM_CMP_Feq = text "oeq" + ppr LM_CMP_Fne = text "une" + ppr LM_CMP_Fgt = text "ogt" + ppr LM_CMP_Fge = text "oge" + ppr LM_CMP_Flt = text "olt" + ppr LM_CMP_Fle = text "ole" -- | Llvm cast operations. @@ -788,19 +754,19 @@ data LlvmCastOp | LM_Bitcast -- ^ Cast between types where no bit manipulation is needed deriving (Eq) -instance Show LlvmCastOp where - show LM_Trunc = "trunc" - show LM_Zext = "zext" - show LM_Sext = "sext" - show LM_Fptrunc = "fptrunc" - show LM_Fpext = "fpext" - show LM_Fptoui = "fptoui" - show LM_Fptosi = "fptosi" - show LM_Uitofp = "uitofp" - show LM_Sitofp = "sitofp" - show LM_Ptrtoint = "ptrtoint" - show LM_Inttoptr = "inttoptr" - show LM_Bitcast = "bitcast" +instance Outputable LlvmCastOp where + ppr LM_Trunc = text "trunc" + ppr LM_Zext = text "zext" + ppr LM_Sext = text "sext" + ppr LM_Fptrunc = text "fptrunc" + ppr LM_Fpext = text "fpext" + ppr LM_Fptoui = text "fptoui" + ppr LM_Fptosi = text "fptosi" + ppr LM_Uitofp = text "uitofp" + ppr LM_Sitofp = text "sitofp" + ppr LM_Ptrtoint = text "ptrtoint" + ppr LM_Inttoptr = text "inttoptr" + ppr LM_Bitcast = text "bitcast" -- ----------------------------------------------------------------------------- @@ -812,8 +778,8 @@ instance Show LlvmCastOp where -- regardless of underlying architecture. -- -- See Note [LLVM Float Types]. -dToStr :: Double -> String -dToStr d +ppDouble :: Double -> SDoc +ppDouble d = let bs = doubleToBytes d hex d' = case showHex d' "" of [] -> error "dToStr: too few hex digits for float" @@ -821,12 +787,12 @@ dToStr d [x,y] -> [x,y] _ -> error "dToStr: too many hex digits for float" - str = map toUpper $ concat . fixEndian . (map hex) $ bs - in "0x" ++ str + str = map toUpper $ concat $ fixEndian $ map hex bs + in text "0x" <> text str -- Note [LLVM Float Types] -- ~~~~~~~~~~~~~~~~~~~~~~~ --- We use 'dToStr' for both printing Float and Double floating point types. This is +-- We use 'ppDouble' for both printing Float and Double floating point types. This is -- as LLVM expects all floating point constants (single & double) to be in IEEE -- 754 Double precision format. However, for single precision numbers (Float) -- they should be *representable* in IEEE 754 Single precision format. So the @@ -849,6 +815,9 @@ widenFp :: Float -> Double {-# NOINLINE widenFp #-} widenFp = float2Double +ppFloat :: Float -> SDoc +ppFloat = ppDouble . widenFp + -- | Reverse or leave byte data alone to fix endianness on this target. fixEndian :: [a] -> [a] #ifdef WORDS_BIGENDIAN @@ -857,3 +826,13 @@ fixEndian = id fixEndian = reverse #endif + +-------------------------------------------------------------------------------- +-- * Misc functions +-------------------------------------------------------------------------------- + +ppCommaJoin :: (Outputable a) => [a] -> SDoc +ppCommaJoin strs = hsep $ punctuate comma (map ppr strs) + +ppSpaceJoin :: (Outputable a) => [a] -> SDoc +ppSpaceJoin strs = hsep (map ppr strs) diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index a157a258fe..d0f343fa92 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -11,6 +11,7 @@ import LlvmCodeGen.Base import LlvmCodeGen.CodeGen import LlvmCodeGen.Data import LlvmCodeGen.Ppr +import LlvmCodeGen.Regs import LlvmMangler import CgUtils ( fixStgRegisters ) @@ -23,142 +24,173 @@ import DynFlags import ErrUtils import FastString import Outputable -import qualified Pretty as Prt import UniqSupply -import Util import SysTools ( figureLlvmVersion ) +import qualified Stream import Control.Monad ( when ) import Data.IORef ( writeIORef ) -import Data.Maybe ( fromMaybe ) +import Data.Maybe ( fromMaybe, catMaybes ) import System.IO -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM Code generator -- -llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO () -llvmCodeGen dflags h us cmms - = let cmm = concat cmms - (cdata,env) = {-# SCC "llvm_split" #-} - foldr split ([], initLlvmEnv dflags) cmm - split (CmmData s d' ) (d,e) = ((s,d'):d,e) - split (CmmProc h l live g) (d,e) = - let lbl = strCLabel_llvm env $ - case mapLookup (g_entry g) h of - Nothing -> l - Just (Statics info_lbl _) -> info_lbl - env' = funInsert lbl (llvmFunTy dflags live) e - in (d,env') - in do - showPass dflags "LlVM CodeGen" - dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" pprLlvmHeader - bufh <- newBufHandle h - Prt.bufLeftRender bufh $ withPprStyleDoc dflags (mkCodeStyle CStyle) pprLlvmHeader - ver <- getLlvmVersion - env' <- {-# SCC "llvm_datas_gen" #-} - cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata [] - {-# SCC "llvm_procs_gen" #-} - cmmProcLlvmGens dflags bufh us env' cmm 1 [] - bFlush bufh - return () - - where - -- | Handle setting up the LLVM version. - getLlvmVersion = do - ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags - -- cache llvm version for later use - writeIORef (llvmVersion dflags) ver - debugTraceMsg dflags 2 - (text "Using LLVM version:" <+> text (show ver)) - let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags - when (ver < minSupportLlvmVersion && doWarn) $ - errorMsg dflags (text "You are using an old version of LLVM that" - <> text " isn't supported anymore!" - $+$ text "We will try though...") - when (ver > maxSupportLlvmVersion && doWarn) $ - putMsg dflags (text "You are using a new version of LLVM that" - <> text " hasn't been tested yet!" - $+$ text "We will try though...") - return ver +llvmCodeGen :: DynFlags -> Handle -> UniqSupply + -> Stream.Stream IO RawCmmGroup () + -> IO () +llvmCodeGen dflags h us cmm_stream + = do bufh <- newBufHandle h + + -- Pass header + showPass dflags "LLVM CodeGen" + -- get llvm version, cache for later use + ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags + writeIORef (llvmVersion dflags) ver + + -- warn if unsupported + debugTraceMsg dflags 2 + (text "Using LLVM version:" <+> text (show ver)) + let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags + when (ver < minSupportLlvmVersion && doWarn) $ + errorMsg dflags (text "You are using an old version of LLVM that" + <> text " isn't supported anymore!" + $+$ text "We will try though...") + when (ver > maxSupportLlvmVersion && doWarn) $ + putMsg dflags (text "You are using a new version of LLVM that" + <> text " hasn't been tested yet!" + $+$ text "We will try though...") + + -- run code generation + runLlvm dflags ver bufh us $ + llvmCodeGen' (liftStream cmm_stream) + + bFlush bufh + +llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM () +llvmCodeGen' cmm_stream + = do -- Preamble + renderLlvm pprLlvmHeader + ghcInternalFunctions + cmmMetaLlvmPrelude + + -- Procedures + let llvmStream = Stream.mapM llvmGroupLlvmGens cmm_stream + _ <- Stream.collect llvmStream + + -- Declare aliases for forward references + renderLlvm . pprLlvmData =<< generateAliases + + -- Postamble + cmmUsedLlvmGens + +llvmGroupLlvmGens :: RawCmmGroup -> LlvmM () +llvmGroupLlvmGens cmm = do + + -- Insert functions into map, collect data + let split (CmmData s d' ) = return $ Just (s, d') + split (CmmProc h l live g) = do + -- Set function type + let l' = case mapLookup (g_entry g) h of + Nothing -> l + Just (Statics info_lbl _) -> info_lbl + lml <- strCLabel_llvm l' + funInsert lml =<< llvmFunTy live + return Nothing + cdata <- fmap catMaybes $ mapM split cmm + + {-# SCC "llvm_datas_gen" #-} + cmmDataLlvmGens cdata + {-# SCC "llvm_procs_gen" #-} + mapM_ cmmLlvmGen cmm -- ----------------------------------------------------------------------------- -- | Do LLVM code generation on all these Cmms data sections. -- -cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)] - -> [LlvmUnresData] -> IO ( LlvmEnv ) - -cmmDataLlvmGens dflags h env [] lmdata - = let (env', lmdata') = {-# SCC "llvm_resolve" #-} - resolveLlvmDatas env lmdata - lmdoc = {-# SCC "llvm_data_ppr" #-} - vcat $ map pprLlvmData lmdata' - in do - dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" lmdoc - {-# SCC "llvm_data_out" #-} - Prt.bufLeftRender h $ withPprStyleDoc dflags (mkCodeStyle CStyle) lmdoc - return env' - -cmmDataLlvmGens dflags h env (cmm:cmms) lmdata - = let lm@(l, _, ty, _) = {-# SCC "llvm_data_gen" #-} - genLlvmData env cmm - env' = {-# SCC "llvm_data_insert" #-} - funInsert (strCLabel_llvm env l) ty env - lmdata' = {-# SCC "llvm_data_append" #-} - lm:lmdata - in cmmDataLlvmGens dflags h env' cmms lmdata' +cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM () +cmmDataLlvmGens statics + = do lmdatas <- mapM genLlvmData statics --- ----------------------------------------------------------------------------- --- | Do LLVM code generation on all these Cmms procs. --- -cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmDecl] - -> Int -- ^ count, used for generating unique subsections - -> [[LlvmVar]] -- ^ info tables that need to be marked as 'used' - -> IO () - -cmmProcLlvmGens _ _ _ _ [] _ [] - = return () - -cmmProcLlvmGens dflags h _ _ [] _ ivars - = let ivars' = concat ivars - cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr - ty = (LMArray (length ivars') i8Ptr) - usedArray = LMStaticArray (map cast ivars') ty - lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending - (Just $ fsLit "llvm.metadata") Nothing False, Just usedArray) - in Prt.bufLeftRender h $ {-# SCC "llvm_used_ppr" #-} - withPprStyleDoc dflags (mkCodeStyle CStyle) $ - pprLlvmData ([lmUsed], []) - -cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars - = cmmProcLlvmGens dflags h us env cmms count ivars - -cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do - (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm - let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm - Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-} - withPprStyleDoc dflags (mkCodeStyle CStyle) $ vcat docs - cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars) + let (gss, tss) = unzip lmdatas + let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _) + = funInsert l ty + regGlobal _ = return () + mapM_ regGlobal (concat gss) + + renderLlvm $ pprLlvmData (concat gss, concat tss) -- | Complete LLVM code generation phase for a single top-level chunk of Cmm. -cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmDecl - -> IO ( UniqSupply, LlvmEnv, [LlvmCmmDecl] ) -cmmLlvmGen dflags us env cmm = do +cmmLlvmGen ::RawCmmDecl -> LlvmM () +cmmLlvmGen cmm@CmmProc{} = do + -- rewrite assignments to global regs + dflags <- getDynFlag id let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters dflags cmm - dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" - (pprCmmGroup [fixed_cmm]) + dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm]) -- generate llvm code from cmm - let ((env', llvmBC), usGen) = {-# SCC "llvm_proc_gen" #-} - initUs us $ genLlvmProc env fixed_cmm + llvmBC <- withClearVars $ genLlvmProc fixed_cmm - dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" - (vcat $ map (fst . pprLlvmCmmDecl env' 0) llvmBC) + -- allocate IDs for info table and code, so the mangler can later + -- make sure they end up next to each other. + itableSection <- freshSectionId + _codeSection <- freshSectionId - return (usGen, env', llvmBC) + -- pretty print + (docs, ivars) <- fmap unzip $ mapM (pprLlvmCmmDecl itableSection) llvmBC + + -- Output, note down used variables + renderLlvm (vcat docs) + mapM_ markUsedVar $ concat ivars + +cmmLlvmGen _ = return () + +-- ----------------------------------------------------------------------------- +-- | Generate meta data nodes +-- + +cmmMetaLlvmPrelude :: LlvmM () +cmmMetaLlvmPrelude = do + metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do + -- Generate / lookup meta data IDs + tbaaId <- getMetaUniqueId + setUniqMeta uniq tbaaId + parentId <- maybe (return Nothing) getUniqMeta parent + -- Build definition + return $ MetaUnamed tbaaId $ MetaStruct + [ MetaStr name + , case parentId of + Just p -> MetaNode p + Nothing -> MetaVar $ LMLitVar $ LMNullLit i8Ptr + ] + renderLlvm $ ppLlvmMetas metas + +-- ----------------------------------------------------------------------------- +-- | Marks variables as used where necessary +-- +cmmUsedLlvmGens :: LlvmM () +cmmUsedLlvmGens = do + + -- LLVM would discard variables that are internal and not obviously + -- used if we didn't provide these hints. This will generate a + -- definition of the form + -- + -- @llvm.used = appending global [42 x i8*] [i8* bitcast <var> to i8*, ...] + -- + -- Which is the LLVM way of protecting them against getting removed. + ivars <- getUsedVars + let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr + ty = (LMArray (length ivars) i8Ptr) + usedArray = LMStaticArray (map cast ivars) ty + sectName = Just $ fsLit "llvm.metadata" + lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant + lmUsed = LMGlobal lmUsedVar (Just usedArray) + if null ivars + then return () + else renderLlvm $ pprLlvmData ([lmUsed], []) diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index bcfce3401e..dda2c9e05b 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -13,15 +13,23 @@ module LlvmCodeGen.Base ( LlvmVersion, defaultLlvmVersion, minSupportLlvmVersion, maxSupportLlvmVersion, - LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert, - funLookup, funInsert, getLlvmVer, setLlvmVer, getLlvmPlatform, - getDflags, ghcInternalFunctions, + LlvmM, + runLlvm, liftStream, withClearVars, varLookup, varInsert, + markStackReg, checkStackReg, + funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform, + dumpIfSetLlvm, renderLlvm, runUs, markUsedVar, getUsedVars, + ghcInternalFunctions, + + getMetaUniqueId, + setUniqMeta, getUniqMeta, + freshSectionId, cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, llvmPtrBits, mkLlvmFunc, tysToParams, - strCLabel_llvm, genCmmLabelRef, genStringLabelRef + strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm, + getGlobalPtr, generateAliases, ) where @@ -36,9 +44,15 @@ import DynFlags import FastString import Cmm import qualified Outputable as Outp +import qualified Pretty as Prt import Platform import UniqFM import Unique +import BufWrite ( BufHandle ) +import UniqSet +import UniqSupply +import ErrUtils +import qualified Stream -- ---------------------------------------------------------------------------- -- * Some Data Types @@ -93,30 +107,32 @@ llvmGhcCC dflags | otherwise = CC_Ncc 10 -- | Llvm Function type for Cmm function -llvmFunTy :: DynFlags -> LiveGlobalRegs -> LlvmType -llvmFunTy dflags live = LMFunction $ llvmFunSig' dflags live (fsLit "a") ExternallyVisible +llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType +llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible -- | Llvm Function signature -llvmFunSig :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmFunctionDecl -llvmFunSig env live lbl link - = llvmFunSig' (getDflags env) live (strCLabel_llvm env lbl) link - -llvmFunSig' :: DynFlags -> LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmFunctionDecl -llvmFunSig' dflags live lbl link - = let toParams x | isPointer x = (x, [NoAlias, NoCapture]) - | otherwise = (x, []) - in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs - (map (toParams . getVarType) (llvmFunArgs dflags live)) - (llvmFunAlign dflags) +llvmFunSig :: LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl +llvmFunSig live lbl link = do + lbl' <- strCLabel_llvm lbl + llvmFunSig' live lbl' link + +llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl +llvmFunSig' live lbl link + = do let toParams x | isPointer x = (x, [NoAlias, NoCapture]) + | otherwise = (x, []) + dflags <- getDynFlags + return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs + (map (toParams . getVarType) (llvmFunArgs dflags live)) + (llvmFunAlign dflags) -- | Create a Haskell function in LLVM. -mkLlvmFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks - -> LlvmFunction -mkLlvmFunc env live lbl link sec blks - = let dflags = getDflags env - funDec = llvmFunSig env live lbl link - funArgs = map (fsLit . getPlainName) (llvmFunArgs dflags live) - in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks +mkLlvmFunc :: LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks + -> LlvmM LlvmFunction +mkLlvmFunc live lbl link sec blks + = do funDec <- llvmFunSig live lbl link + dflags <- getDynFlags + let funArgs = map (fsLit . Outp.showSDoc dflags . ppPlainName) (llvmFunArgs dflags live) + return $ LlvmFunction funDec funArgs llvmStdFunAttrs sec blks -- | Alignment to use for functions llvmFunAlign :: DynFlags -> LMAlign @@ -166,102 +182,292 @@ minSupportLlvmVersion :: LlvmVersion minSupportLlvmVersion = 28 maxSupportLlvmVersion :: LlvmVersion -maxSupportLlvmVersion = 33 +maxSupportLlvmVersion = 34 -- ---------------------------------------------------------------------------- -- * Environment Handling -- --- two maps, one for functions and one for local vars. -newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion, DynFlags) +data LlvmEnv = LlvmEnv + { envVersion :: LlvmVersion -- ^ LLVM version + , envDynFlags :: DynFlags -- ^ Dynamic flags + , envOutput :: BufHandle -- ^ Output buffer + , envUniq :: UniqSupply -- ^ Supply of unique values + , envNextSection :: Int -- ^ Supply of fresh section IDs + , envFreshMeta :: Int -- ^ Supply of fresh metadata IDs + , envUniqMeta :: UniqFM Int -- ^ Global metadata nodes + , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type + , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References] + , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@) + + -- the following get cleared for every function (see @withClearVars@) + , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type + , envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude) + } type LlvmEnvMap = UniqFM LlvmType --- | Get initial Llvm environment. -initLlvmEnv :: DynFlags -> LlvmEnv -initLlvmEnv dflags = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, dflags) - where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions dflags ] +-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad +newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) } +instance Monad LlvmM where + return x = LlvmM $ \env -> return (x, env) + m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env + runLlvmM (f x) env' +instance Functor LlvmM where + fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env + return (f x, env') --- | Here we pre-initialise some functions that are used internally by GHC --- so as to make sure they have the most general type in the case that --- user code also uses these functions but with a different type than GHC --- internally. (Main offender is treating return type as 'void' instead of --- 'void *'. Fixes trac #5486. -ghcInternalFunctions :: DynFlags -> [(LMString, LlvmFunctionDecl)] -ghcInternalFunctions dflags = - [ mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] - , mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] - , mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags] - , mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr] - ] - where - mk n ret args = - let n' = fsLit n - in (n', LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret - FixedArgs (tysToParams args) Nothing) - --- | Clear variables from the environment. -clearVars :: LlvmEnv -> LlvmEnv -clearVars (LlvmEnv (e1, _, n, p)) = {-# SCC "llvm_env_clear" #-} - LlvmEnv (e1, emptyUFM, n, p) - --- | Insert local variables into the environment. -varInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv -varInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_vinsert" #-} - LlvmEnv (e1, addToUFM e2 s t, n, p) - --- | Insert functions into the environment. -funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv -funInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_finsert" #-} - LlvmEnv (addToUFM e1 s t, e2, n, p) - --- | Lookup local variables in the environment. -varLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType -varLookup s (LlvmEnv (_, e2, _, _)) = {-# SCC "llvm_env_vlookup" #-} - lookupUFM e2 s - --- | Lookup functions in the environment. -funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType -funLookup s (LlvmEnv (e1, _, _, _)) = {-# SCC "llvm_env_flookup" #-} - lookupUFM e1 s +instance HasDynFlags LlvmM where + getDynFlags = LlvmM $ \env -> return (envDynFlags env, env) + +-- | Lifting of IO actions. Not exported, as we want to encapsulate IO. +liftIO :: IO a -> LlvmM a +liftIO m = LlvmM $ \env -> do x <- m + return (x, env) + +-- | Get initial Llvm environment. +runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO () +runLlvm dflags ver out us m = do + _ <- runLlvmM m env + return () + where env = LlvmEnv { envFunMap = emptyUFM + , envVarMap = emptyUFM + , envStackRegs = [] + , envUsedVars = [] + , envAliases = emptyUniqSet + , envVersion = ver + , envDynFlags = dflags + , envOutput = out + , envUniq = us + , envFreshMeta = 0 + , envUniqMeta = emptyUFM + , envNextSection = 1 + } + +-- | Get environment (internal) +getEnv :: (LlvmEnv -> a) -> LlvmM a +getEnv f = LlvmM (\env -> return (f env, env)) + +-- | Modify environment (internal) +modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM () +modifyEnv f = LlvmM (\env -> return ((), f env)) + +-- | Lift a stream into the LlvmM monad +liftStream :: Stream.Stream IO a x -> Stream.Stream LlvmM a x +liftStream s = Stream.Stream $ do + r <- liftIO $ Stream.runStream s + case r of + Left b -> return (Left b) + Right (a, r2) -> return (Right (a, liftStream r2)) + +-- | Clear variables from the environment for a subcomputation +withClearVars :: LlvmM a -> LlvmM a +withClearVars m = LlvmM $ \env -> do + (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] } + return (x, env' { envVarMap = emptyUFM, envStackRegs = [] }) + +-- | Insert variables or functions into the environment. +varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM () +varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) s t } +funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) s t } + +-- | Lookup variables or functions in the environment. +varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType) +varLookup s = getEnv (flip lookupUFM s . envVarMap) +funLookup s = getEnv (flip lookupUFM s . envFunMap) + +-- | Set a register as allocated on the stack +markStackReg :: GlobalReg -> LlvmM () +markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env } + +-- | Check whether a register is allocated on the stack +checkStackReg :: GlobalReg -> LlvmM Bool +checkStackReg r = getEnv ((elem r) . envStackRegs) + +-- | Allocate a new global unnamed metadata identifier +getMetaUniqueId :: LlvmM Int +getMetaUniqueId = LlvmM $ \env -> return (envFreshMeta env, env { envFreshMeta = envFreshMeta env + 1}) -- | Get the LLVM version we are generating code for -getLlvmVer :: LlvmEnv -> LlvmVersion -getLlvmVer (LlvmEnv (_, _, n, _)) = n +getLlvmVer :: LlvmM LlvmVersion +getLlvmVer = getEnv envVersion --- | Set the LLVM version we are generating code for -setLlvmVer :: LlvmVersion -> LlvmEnv -> LlvmEnv -setLlvmVer n (LlvmEnv (e1, e2, _, p)) = LlvmEnv (e1, e2, n, p) +-- | Get the platform we are generating code for +getDynFlag :: (DynFlags -> a) -> LlvmM a +getDynFlag f = getEnv (f . envDynFlags) -- | Get the platform we are generating code for -getLlvmPlatform :: LlvmEnv -> Platform -getLlvmPlatform (LlvmEnv (_, _, _, d)) = targetPlatform d +getLlvmPlatform :: LlvmM Platform +getLlvmPlatform = getDynFlag targetPlatform + +-- | Dumps the document if the corresponding flag has been set by the user +dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM () +dumpIfSetLlvm flag hdr doc = do + dflags <- getDynFlags + liftIO $ dumpIfSet_dyn dflags flag hdr doc + +-- | Prints the given contents to the output handle +renderLlvm :: Outp.SDoc -> LlvmM () +renderLlvm sdoc = do + + -- Write to output + dflags <- getDynFlags + out <- getEnv envOutput + let doc = Outp.withPprStyleDoc dflags (Outp.mkCodeStyle Outp.CStyle) sdoc + liftIO $ Prt.bufLeftRender out doc + + -- Dump, if requested + dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc + return () + +-- | Run a @UniqSM@ action with our unique supply +runUs :: UniqSM a -> LlvmM a +runUs m = LlvmM $ \env -> do + let (x, us') = initUs (envUniq env) m + return (x, env { envUniq = us' }) + +-- | Marks a variable as "used" +markUsedVar :: LlvmVar -> LlvmM () +markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env } + +-- | Return all variables marked as "used" so far +getUsedVars :: LlvmM [LlvmVar] +getUsedVars = getEnv envUsedVars + +-- | Saves that at some point we didn't know the type of the label and +-- generated a reference to a type variable instead +saveAlias :: LMString -> LlvmM () +saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl } + +-- | Sets metadata node for a given unique +setUniqMeta :: Unique -> Int -> LlvmM () +setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m } +-- | Gets metadata node for given unique +getUniqMeta :: Unique -> LlvmM (Maybe Int) +getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta) + +-- | Returns a fresh section ID +freshSectionId :: LlvmM Int +freshSectionId = LlvmM $ \env -> return (envNextSection env, env { envNextSection = envNextSection env + 1}) + +-- ---------------------------------------------------------------------------- +-- * Internal functions +-- --- | Get the DynFlags for this compilation pass -getDflags :: LlvmEnv -> DynFlags -getDflags (LlvmEnv (_, _, _, d)) = d +-- | Here we pre-initialise some functions that are used internally by GHC +-- so as to make sure they have the most general type in the case that +-- user code also uses these functions but with a different type than GHC +-- internally. (Main offender is treating return type as 'void' instead of +-- 'void *'). Fixes trac #5486. +ghcInternalFunctions :: LlvmM () +ghcInternalFunctions = do + dflags <- getDynFlags + mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] + mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] + mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags] + mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr] + where + mk n ret args = do + let n' = fsLit n + decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret + FixedArgs (tysToParams args) Nothing + renderLlvm $ ppLlvmFunctionDecl decl + funInsert n' (LMFunction decl) -- ---------------------------------------------------------------------------- -- * Label handling -- -- | Pretty print a 'CLabel'. -strCLabel_llvm :: LlvmEnv -> CLabel -> LMString -strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-} - (fsLit . toString . pprCLabel (getLlvmPlatform env)) l - where dflags = getDflags env - style = Outp.mkCodeStyle Outp.CStyle - toString doc = Outp.renderWithStyle dflags doc style - --- | Create an external definition for a 'CLabel' defined in another module. -genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal -genCmmLabelRef env = genStringLabelRef (getDflags env) . strCLabel_llvm env - --- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'. -genStringLabelRef :: DynFlags -> LMString -> LMGlobal -genStringLabelRef dflags cl - = let ty = LMPointer $ LMArray 0 (llvmWord dflags) - in (LMGlobalVar cl ty External Nothing Nothing False, Nothing) +strCLabel_llvm :: CLabel -> LlvmM LMString +strCLabel_llvm lbl = do + platform <- getLlvmPlatform + dflags <- getDynFlags + let sdoc = pprCLabel platform lbl + str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle) + return (fsLit str) + +strDisplayName_llvm :: CLabel -> LlvmM LMString +strDisplayName_llvm lbl = do + platform <- getLlvmPlatform + dflags <- getDynFlags + let sdoc = pprCLabel platform lbl + depth = Outp.PartWay 1 + style = Outp.mkUserStyle (const Outp.NameNotInScope2, const True) depth + str = Outp.renderWithStyle dflags sdoc style + return (fsLit (dropInfoSuffix str)) + +dropInfoSuffix :: String -> String +dropInfoSuffix = go + where go "_info" = [] + go "_static_info" = [] + go "_con_info" = [] + go (x:xs) = x:go xs + go [] = [] + +strProcedureName_llvm :: CLabel -> LlvmM LMString +strProcedureName_llvm lbl = do + platform <- getLlvmPlatform + dflags <- getDynFlags + let sdoc = pprCLabel platform lbl + depth = Outp.PartWay 1 + style = Outp.mkUserStyle (const Outp.NameUnqual, const False) depth + str = Outp.renderWithStyle dflags sdoc style + return (fsLit str) + +-- ---------------------------------------------------------------------------- +-- * Global variables / forward references +-- + +-- | Create/get a pointer to a global value. Might return an alias if +-- the value in question hasn't been defined yet. We especially make +-- no guarantees on the type of the returned pointer. +getGlobalPtr :: LMString -> LlvmM LlvmVar +getGlobalPtr llvmLbl = do + m_ty <- funLookup llvmLbl + let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing + case m_ty of + -- Directly reference if we have seen it already + Just ty -> return $ mkGlbVar llvmLbl ty Global + -- Otherwise use a forward alias of it + Nothing -> do + saveAlias llvmLbl + return $ mkGlbVar (llvmLbl `appendFS` fsLit "$alias") i8 Alias + +-- | Generate definitions for aliases forward-referenced by @getGlobalPtr@. +-- +-- Must be called at a point where we are sure that no new global definitions +-- will be generated anymore! +generateAliases :: LlvmM ([LMGlobal], [LlvmType]) +generateAliases = do + delayed <- fmap uniqSetToList $ getEnv envAliases + defss <- flip mapM delayed $ \lbl -> do + let var ty = LMGlobalVar lbl (LMPointer ty) External Nothing Nothing Global + aliasLbl = lbl `appendFS` fsLit "$alias" + aliasVar = LMGlobalVar aliasLbl i8Ptr Private Nothing Nothing Alias + -- If we have a definition, set the alias value using a + -- cost. Otherwise, declare it as an undefined external symbol. + m_ty <- funLookup lbl + case m_ty of + Just ty -> return [LMGlobal aliasVar $ Just $ LMBitc (LMStaticPointer (var ty)) i8Ptr] + Nothing -> return [LMGlobal (var i8) Nothing, + LMGlobal aliasVar $ Just $ LMStaticPointer (var i8) ] + -- Reset forward list + modifyEnv $ \env -> env { envAliases = emptyUniqSet } + return (concat defss, []) + +-- Note [Llvm Forward References] +-- +-- The issue here is that LLVM insists on being strongly typed at +-- every corner, so the first time we mention something, we have to +-- settle what type we assign to it. That makes things awkward, as Cmm +-- will often reference things before their definition, and we have no +-- idea what (LLVM) type it is going to be before that point. +-- +-- Our work-around is to define "aliases" of a standard type (i8 *) in +-- these kind of situations, which we later tell LLVM to be either +-- references to their actual local definitions (involving a cast) or +-- an external reference. This obviously only works for pointers. -- ---------------------------------------------------------------------------- -- * Misc diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 915981752e..6f898fa56c 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -29,232 +29,216 @@ import Platform import OrdList import UniqSupply import Unique -import Util -import Data.List ( partition ) +import Data.List ( nub ) +import Data.Maybe ( catMaybes ) type LlvmStatements = OrdList LlvmStatement -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM proc Code generator -- -genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl]) -genLlvmProc env (CmmProc infos lbl live graph) = do +genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl] +genLlvmProc (CmmProc infos lbl live graph) = do let blocks = toBlockListEntryFirstFalseFallthrough graph - (env', lmblocks, lmdata) <- basicBlocksCodeGen env live blocks ([], []) + (lmblocks, lmdata) <- basicBlocksCodeGen live blocks let info = mapLookup (g_entry graph) infos proc = CmmProc info lbl live (ListGraph lmblocks) - return (env', proc:lmdata) + return (proc:lmdata) -genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!" +genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!" -- ----------------------------------------------------------------------------- -- * Block code generation -- --- | Generate code for a list of blocks that make up a complete procedure. -basicBlocksCodeGen :: LlvmEnv - -> LiveGlobalRegs - -> [CmmBlock] - -> ( [LlvmBasicBlock] , [LlvmCmmDecl] ) - -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] ) -basicBlocksCodeGen env live [] (blocks0, tops0) - = return (env, fblocks, tops) - where - dflags = getDflags env - blocks = reverse blocks0 - tops = reverse tops0 - (blocks', allocs) = mapAndUnzip dominateAllocs blocks - allocs' = concat allocs - (BasicBlock id fstmts : rblks) = blocks' - fblocks = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks - -basicBlocksCodeGen env live (block:blocks) (lblocks, ltops) - = do (env', lb, lt) <- basicBlockCodeGen env block - basicBlocksCodeGen env' live blocks (lb : lblocks, reverse lt ++ ltops) +-- | Generate code for a list of blocks that make up a complete +-- procedure. The first block in the list is exepected to be the entry +-- point and will get the prologue. +basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock] + -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl]) +basicBlocksCodeGen _ [] = panic "no entry block!" +basicBlocksCodeGen live (entryBlock:cmmBlocks) + = do (prologue, prologueTops) <- funPrologue live (entryBlock:cmmBlocks) + -- Generate code + (BasicBlock bid entry, entryTops) <- basicBlockCodeGen entryBlock + (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks --- | Allocations need to be extracted so they can be moved to the entry --- of a function to make sure they dominate all possible paths in the CFG. -dominateAllocs :: LlvmBasicBlock -> (LlvmBasicBlock, [LlvmStatement]) -dominateAllocs (BasicBlock id stmts) - = let (allocs, stmts') = partition isAlloc stmts - isAlloc (Assignment _ (Alloca _ _)) = True - isAlloc _other = False - in (BasicBlock id stmts', allocs) + -- Compose + let entryBlock = BasicBlock bid (fromOL prologue ++ entry) + return (entryBlock : blocks, prologueTops ++ entryTops ++ concat topss) -- | Generate code for one block -basicBlockCodeGen :: LlvmEnv - -> CmmBlock - -> UniqSM ( LlvmEnv, LlvmBasicBlock, [LlvmCmmDecl] ) -basicBlockCodeGen env block +basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] ) +basicBlockCodeGen block = do let (CmmEntry id, nodes, tail) = blockSplit block - let stmts = blockToList nodes - (env', mid_instrs, top) <- stmtsToInstrs env stmts (nilOL, []) - (env'', tail_instrs, top') <- stmtToInstrs env' tail + (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes + (tail_instrs, top') <- stmtToInstrs tail let instrs = fromOL (mid_instrs `appOL` tail_instrs) - return (env'', BasicBlock id instrs, top' ++ top) + return (BasicBlock id instrs, top' ++ top) -- ----------------------------------------------------------------------------- -- * CmmNode code generation -- -- A statement conversion return data. --- * LlvmEnv: The new environment -- * LlvmStatements: The compiled LLVM statements. -- * LlvmCmmDecl: Any global data needed. -type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmDecl]) +type StmtData = (LlvmStatements, [LlvmCmmDecl]) -- | Convert a list of CmmNode's to LlvmStatement's -stmtsToInstrs :: LlvmEnv -> [CmmNode e x] -> (LlvmStatements, [LlvmCmmDecl]) - -> UniqSM StmtData -stmtsToInstrs env [] (llvm, top) - = return (env, llvm, top) +stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData +stmtsToInstrs stmts + = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts + return (concatOL instrss, concat topss) -stmtsToInstrs env (stmt : stmts) (llvm, top) - = do (env', instrs, tops) <- stmtToInstrs env stmt - stmtsToInstrs env' stmts (llvm `appOL` instrs, top ++ tops) +-- | Convert a CmmStmt to a list of LlvmStatement's +stmtToInstrs :: CmmNode e x -> LlvmM StmtData +stmtToInstrs stmt = case stmt of --- | Convert a CmmNode to a list of LlvmStatement's -stmtToInstrs :: LlvmEnv -> CmmNode e x - -> UniqSM StmtData -stmtToInstrs env stmt = case stmt of + CmmComment _ -> return (nilOL, []) -- nuke comments - CmmComment _ -> return (env, nilOL, []) -- nuke comments + CmmAssign reg src -> genAssign reg src + CmmStore addr src -> genStore addr src - CmmAssign reg src -> genAssign env reg src - CmmStore addr src -> genStore env addr src - - CmmBranch id -> genBranch env id - CmmCondBranch arg true false -> genCondBranch env arg true false - CmmSwitch arg ids -> genSwitch env arg ids + CmmBranch id -> genBranch id + CmmCondBranch arg true false + -> genCondBranch arg true false + CmmSwitch arg ids -> genSwitch arg ids -- Foreign Call - CmmUnsafeForeignCall target res args -> genCall env target res args + CmmUnsafeForeignCall target res args + -> genCall target res args -- Tail call CmmCall { cml_target = arg, - cml_args_regs = live } -> genJump env arg live + cml_args_regs = live } -> genJump arg live _ -> panic "Llvm.CodeGen.stmtToInstrs" +-- | Wrapper function to declare an instrinct function by function type +getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData +getInstrinct2 fname fty@(LMFunction funSig) = do + + let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Constant + + fn <- funLookup fname + tops <- case fn of + Just _ -> + return [] + Nothing -> do + funInsert fname fty + return [CmmData Data [([],[fty])]] + + return (fv, nilOL, tops) + +getInstrinct2 _ _ = error "getInstrinct2: Non-function type!" + +-- | Declares an instrinct function by return and parameter types +getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData +getInstrinct fname retTy parTys = + let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc retTy + FixedArgs (tysToParams parTys) Nothing + fty = LMFunction funSig + in getInstrinct2 fname fty + -- | Memory barrier instruction for LLVM >= 3.0 -barrier :: LlvmEnv -> UniqSM StmtData -barrier env = do +barrier :: LlvmM StmtData +barrier = do let s = Fence False SyncSeqCst - return (env, unitOL s, []) + return (unitOL s, []) -- | Memory barrier instruction for LLVM < 3.0 -oldBarrier :: LlvmEnv -> UniqSM StmtData -oldBarrier env = do - let dflags = getDflags env - let fname = fsLit "llvm.memory.barrier" - let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid - FixedArgs (tysToParams [i1, i1, i1, i1, i1]) (llvmFunAlign dflags) - let fty = LMFunction funSig - - let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False - let tops = case funLookup fname env of - Just _ -> [] - Nothing -> [CmmData Data [([],[fty])]] +oldBarrier :: LlvmM StmtData +oldBarrier = do + + (fv, _, tops) <- getInstrinct (fsLit "llvm.memory.barrier") LMVoid [i1, i1, i1, i1, i1] let args = [lmTrue, lmTrue, lmTrue, lmTrue, lmTrue] let s1 = Expr $ Call StdCall fv args llvmStdFunAttrs - let env' = funInsert fname fty env - return (env', unitOL s1, tops) + return (unitOL s1, tops) where lmTrue :: LlvmVar lmTrue = mkIntLit i1 (-1) -- | Foreign Calls -genCall :: LlvmEnv -> ForeignTarget -> [CmmFormal] -> [CmmActual] - -> UniqSM StmtData +genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] + -> LlvmM StmtData -- Write barrier needs to be handled specially as it is implemented as an LLVM -- intrinsic function. -genCall env (PrimTarget MO_WriteBarrier) _ _ - | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC] - = return (env, nilOL, []) - | getLlvmVer env > 29 = barrier env - | otherwise = oldBarrier env - -genCall env (PrimTarget MO_Touch) _ _ - = return (env, nilOL, []) - -genCall env (PrimTarget (MO_UF_Conv w)) [dst] [e] = do - let (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst) - ty = cmmToLlvmType $ localRegType dst +genCall (PrimTarget MO_WriteBarrier) _ _ = do + platform <- getLlvmPlatform + ver <- getLlvmVer + case () of + _ | platformArch platform `elem` [ArchX86, ArchX86_64, ArchSPARC] + -> return (nilOL, []) + | ver > 29 -> barrier + | otherwise -> oldBarrier + +genCall (PrimTarget MO_Touch) _ _ + = return (nilOL, []) + +genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = do + dstV <- getCmmReg (CmmLocal dst) + let ty = cmmToLlvmType $ localRegType dst width = widthToLlvmFloat w castV <- mkLocalVar ty - (env2, ve, stmts2, top2) <- exprToVar env1 e + (ve, stmts, top) <- exprToVar e let stmt3 = Assignment castV $ Cast LM_Uitofp ve width stmt4 = Store castV dstV - stmts = stmts1 `appOL` stmts2 `snocOL` stmt3 `snocOL` stmt4 - return (env2, stmts, top1 ++ top2) + return (stmts `snocOL` stmt3 `snocOL` stmt4, top) -genCall _ (PrimTarget (MO_UF_Conv _)) [_] args = +genCall (PrimTarget (MO_UF_Conv _)) [_] args = panic $ "genCall: Too many arguments to MO_UF_Conv. " ++ "Can only handle 1, given" ++ show (length args) ++ "." -- Handle prefetching data -genCall env t@(PrimTarget MO_Prefetch_Data) [] args = do - let dflags = getDflags env - argTy = [i8Ptr, i32, i32, i32] +genCall t@(PrimTarget MO_Prefetch_Data) [] args = do + ver <- getLlvmVer + let argTy | ver <= 29 = [i8Ptr, i32, i32] + | otherwise = [i8Ptr, i32, i32, i32] funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing let (_, arg_hints) = foreignTargetHints t let args_hints' = zip args arg_hints - (env1, argVars, stmts1, top1) <- arg_vars env args_hints' ([], nilOL, []) - (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t - (argVars', stmts3) <- castVars dflags $ zip argVars argTy - - let arguments = argVars' ++ [mkIntLit i32 0, mkIntLit i32 3, mkIntLit i32 1] - call = Expr $ Call StdCall fptr arguments [] + (argVars, stmts1, top1) <- arg_vars args_hints' ([], nilOL, []) + (fptr, stmts2, top2) <- getFunPtr funTy t + (argVars', stmts3) <- castVars $ zip argVars argTy + + trash <- getTrashStmts + let argSuffix | ver <= 29 = [mkIntLit i32 0, mkIntLit i32 3] + | otherwise = [mkIntLit i32 0, mkIntLit i32 3, mkIntLit i32 1] + call = Expr $ Call StdCall fptr (argVars' ++ argSuffix) [] stmts = stmts1 `appOL` stmts2 `appOL` stmts3 - `appOL` trashStmts (getDflags env) `snocOL` call - return (env2, stmts, top1 ++ top2) - --- Handle popcnt function specifically since GHC only really has i32 and i64 --- types and things like Word8 are backed by an i32 and just present a logical --- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM --- is strict about types. -genCall env t@(PrimTarget (MO_PopCnt w)) [dst] args = do - let dflags = getDflags env - width = widthToLlvmInt w - dstTy = cmmToLlvmType $ localRegType dst - funTy = \n -> LMFunction $ LlvmFunctionDecl n ExternallyVisible - CC_Ccc width FixedArgs (tysToParams [width]) Nothing - (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst) + `appOL` trash `snocOL` call + return (stmts, top1 ++ top2) - let (_, arg_hints) = foreignTargetHints t - let args_hints = zip args arg_hints - (env2, argsV, stmts2, top2) <- arg_vars env1 args_hints ([], nilOL, []) - (env3, fptr, stmts3, top3) <- getFunPtr env2 funTy t - (argsV', stmts4) <- castVars dflags $ zip argsV [width] - (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] - ([retV'], stmts5) <- castVars dflags [(retV,dstTy)] - let s2 = Store retV' dstV - - let stmts = stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` - s1 `appOL` stmts5 `snocOL` s2 - return (env3, stmts, top1 ++ top2 ++ top3) +-- Handle PopCnt and BSwap that need to only convert arg and return types +genCall t@(PrimTarget (MO_PopCnt w)) dsts args = + genCallSimpleCast w t dsts args +genCall t@(PrimTarget (MO_BSwap w)) dsts args = + genCallSimpleCast w t dsts args -- Handle memcpy function specifically since llvm's intrinsic version takes -- some extra parameters. -genCall env t@(PrimTarget op) [] args' +genCall t@(PrimTarget op) [] args' | op == MO_Memcpy || op == MO_Memset || op == MO_Memmove = do - let dflags = getDflags env - (args, alignVal) = splitAlignVal args' - (isVolTy, isVolVal) = if getLlvmVer env >= 28 - then ([i1], [mkIntLit i1 0]) else ([], []) + ver <- getLlvmVer + dflags <- getDynFlags + let (args, alignVal) = splitAlignVal args' + (isVolTy, isVolVal) + | ver >= 28 = ([i1], [mkIntLit i1 0]) + | otherwise = ([], []) argTy | op == MO_Memset = [i8Ptr, i8, llvmWord dflags, i32] ++ isVolTy | otherwise = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible @@ -262,16 +246,16 @@ genCall env t@(PrimTarget op) [] args' let (_, arg_hints) = foreignTargetHints t let args_hints = zip args arg_hints - (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, []) - (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t - (argVars', stmts3) <- castVars dflags $ zip argVars argTy + (argVars, stmts1, top1) <- arg_vars args_hints ([], nilOL, []) + (fptr, stmts2, top2) <- getFunPtr funTy t + (argVars', stmts3) <- castVars $ zip argVars argTy + stmts4 <- getTrashStmts let arguments = argVars' ++ (alignVal:isVolVal) call = Expr $ Call StdCall fptr arguments [] stmts = stmts1 `appOL` stmts2 `appOL` stmts3 - `appOL` trashStmts (getDflags env) `snocOL` call - return (env2, stmts, top1 ++ top2) - + `appOL` stmts4 `snocOL` call + return (stmts, top1 ++ top2) where splitAlignVal xs = (init xs, extractLit $ last xs) @@ -284,9 +268,9 @@ genCall env t@(PrimTarget op) [] args' mkIntLit i32 0 -- Handle all other foreign calls and prim ops. -genCall env target res args = do +genCall target res args = do - let dflags = getDflags env + dflags <- getDynFlags -- parameter types let arg_type (_, AddrHint) = i8Ptr @@ -301,10 +285,11 @@ genCall env target res args = do ++ " 0 or 1, given " ++ show (length t) ++ "." -- extract Cmm call convention, and translate to LLVM call convention + platform <- getLlvmPlatform let lmconv = case target of ForeignTarget _ (ForeignConvention conv _ _ _) -> case conv of - StdCallConv -> case platformArch (getLlvmPlatform env) of + StdCallConv -> case platformArch platform of ArchX86 -> CC_X86_Stdcc ArchX86_64 -> CC_X86_Stdcc _ -> CC_Ccc @@ -341,22 +326,22 @@ genCall env target res args = do lmconv retTy FixedArgs argTy (llvmFunAlign dflags) - - (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, []) - (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy target + (argVars, stmts1, top1) <- arg_vars args_hints ([], nilOL, []) + (fptr, stmts2, top2) <- getFunPtr funTy target let retStmt | ccTy == TailCall = unitOL $ Return Nothing | never_returns = unitOL $ Unreachable | otherwise = nilOL - let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts (getDflags env) + stmts3 <- getTrashStmts + let stmts = stmts1 `appOL` stmts2 `appOL` stmts3 -- make the actual call case retTy of LMVoid -> do let s1 = Expr $ Call ccTy fptr argVars fnAttrs let allStmts = stmts `snocOL` s1 `appOL` retStmt - return (env2, allStmts, top1 ++ top2) + return (allStmts, top1 ++ top2) _ -> do (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs @@ -365,13 +350,13 @@ genCall env target res args = do ret_reg t = panic $ "genCall: Bad number of registers! Can only handle" ++ " 1, given " ++ show (length t) ++ "." let creg = ret_reg res - let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg) - let allStmts = stmts `snocOL` s1 `appOL` stmts3 + vreg <- getCmmReg (CmmLocal creg) + let allStmts = stmts `snocOL` s1 if retTy == pLower (getVarType vreg) then do let s2 = Store v1 vreg - return (env3, allStmts `snocOL` s2 `appOL` retStmt, - top1 ++ top2 ++ top3) + return (allStmts `snocOL` s2 `appOL` retStmt, + top1 ++ top2) else do let ty = pLower $ getVarType vreg let op = case ty of @@ -383,102 +368,110 @@ genCall env target res args = do (v2, s2) <- doExpr ty $ Cast op v1 ty let s3 = Store v2 vreg - return (env3, allStmts `snocOL` s2 `snocOL` s3 - `appOL` retStmt, top1 ++ top2 ++ top3) + return (allStmts `snocOL` s2 `snocOL` s3 + `appOL` retStmt, top1 ++ top2) + +-- Handle simple function call that only need simple type casting, of the form: +-- truncate arg >>= \a -> call(a) >>= zext +-- +-- since GHC only really has i32 and i64 types and things like Word8 are backed +-- by an i32 and just present a logical i8 range. So we must handle conversions +-- from i32 to i8 explicitly as LLVM is strict about types. +genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] + -> LlvmM StmtData +genCallSimpleCast w t@(PrimTarget op) [dst] args = do + let width = widthToLlvmInt w + dstTy = cmmToLlvmType $ localRegType dst + + fname <- cmmPrimOpFunctions op + (fptr, _, top3) <- getInstrinct fname width [width] + + dstV <- getCmmReg (CmmLocal dst) + + let (_, arg_hints) = foreignTargetHints t + let args_hints = zip args arg_hints + (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) + (argsV', stmts4) <- castVars $ zip argsV [width] + (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] + ([retV'], stmts5) <- castVars [(retV,dstTy)] + let s2 = Store retV' dstV + let stmts = stmts2 `appOL` stmts4 `snocOL` + s1 `appOL` stmts5 `snocOL` s2 + return (stmts, top2 ++ top3) +genCallSimpleCast _ _ dsts _ = + panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts") -- | Create a function pointer from a target. -getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> ForeignTarget - -> UniqSM ExprData -getFunPtr env funTy targ = case targ of - ForeignTarget (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm env lbl +getFunPtr :: (LMString -> LlvmType) -> ForeignTarget + -> LlvmM ExprData +getFunPtr funTy targ = case targ of + ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do + name <- strCLabel_llvm lbl + getHsFunc' name (funTy name) ForeignTarget expr _ -> do - (env', v1, stmts, top) <- exprToVar env expr + (v1, stmts, top) <- exprToVar expr + dflags <- getDynFlags let fty = funTy $ fsLit "dynamic" cast = case getVarType v1 of ty | isPointer ty -> LM_Bitcast ty | isInt ty -> LM_Inttoptr ty -> panic $ "genCall: Expr is of bad type for function" - ++ " call! (" ++ show (ty) ++ ")" + ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")" (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) - return (env', v2, stmts `snocOL` s1, top) - - PrimTarget mop -> litCase $ cmmPrimOpFunctions env mop - - where - litCase name = do - case funLookup name env of - Just ty'@(LMFunction sig) -> do - -- Function in module in right form - let fun = LMGlobalVar name ty' (funcLinkage sig) - Nothing Nothing False - return (env, fun, nilOL, []) - - Just ty' -> do - -- label in module but not function pointer, convert - let fty@(LMFunction sig) = funTy name - fun = LMGlobalVar name (pLift ty') (funcLinkage sig) - Nothing Nothing False - (v1, s1) <- doExpr (pLift fty) - $ Cast LM_Bitcast fun (pLift fty) - return (env, v1, unitOL s1, []) - - Nothing -> do - -- label not in module, create external reference - let fty@(LMFunction sig) = funTy name - fun = LMGlobalVar name fty (funcLinkage sig) - Nothing Nothing False - top = [CmmData Data [([],[fty])]] - env' = funInsert name fty env - return (env', fun, nilOL, top) + return (v2, stmts `snocOL` s1, top) + PrimTarget mop -> do + name <- cmmPrimOpFunctions mop + let fty = funTy name + getInstrinct2 name fty -- | Conversion of call arguments. -arg_vars :: LlvmEnv - -> [(CmmActual, ForeignHint)] +arg_vars :: [(CmmActual, ForeignHint)] -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) - -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmDecl]) + -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) -arg_vars env [] (vars, stmts, tops) - = return (env, vars, stmts, tops) +arg_vars [] (vars, stmts, tops) + = return (vars, stmts, tops) -arg_vars env ((e, AddrHint):rest) (vars, stmts, tops) - = do (env', v1, stmts', top') <- exprToVar env e +arg_vars ((e, AddrHint):rest) (vars, stmts, tops) + = do (v1, stmts', top') <- exprToVar e + dflags <- getDynFlags let op = case getVarType v1 of ty | isPointer ty -> LM_Bitcast ty | isInt ty -> LM_Inttoptr a -> panic $ "genCall: Can't cast llvmType to i8*! (" - ++ show a ++ ")" + ++ showSDoc dflags (ppr a) ++ ")" (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr - arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, + arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, tops ++ top') -arg_vars env ((e, _):rest) (vars, stmts, tops) - = do (env', v1, stmts', top') <- exprToVar env e - arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top') +arg_vars ((e, _):rest) (vars, stmts, tops) + = do (v1, stmts', top') <- exprToVar e + arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top') -- | Cast a collection of LLVM variables to specific types. -castVars :: DynFlags -> [(LlvmVar, LlvmType)] - -> UniqSM ([LlvmVar], LlvmStatements) -castVars dflags vars = do - done <- mapM (uncurry (castVar dflags)) vars +castVars :: [(LlvmVar, LlvmType)] + -> LlvmM ([LlvmVar], LlvmStatements) +castVars vars = do + done <- mapM (uncurry castVar) vars let (vars', stmts) = unzip done return (vars', toOL stmts) -- | Cast an LLVM variable to a specific type, panicing if it can't be done. -castVar :: DynFlags -> LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement) -castVar dflags v t - | getVarType v == t +castVar :: LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement) +castVar v t | getVarType v == t = return (v, Nop) | otherwise - = let op = case (getVarType v, t) of + = do dflags <- getDynFlags + let op = case (getVarType v, t) of (LMInt n, LMInt m) -> if n < m then LM_Sext else LM_Trunc (vt, _) | isFloat vt && isFloat t @@ -492,14 +485,24 @@ castVar dflags v t (vt, _) | isVector vt && isVector t -> LM_Bitcast (vt, _) -> panic $ "castVars: Can't cast this type (" - ++ show vt ++ ") to (" ++ show t ++ ")" - in doExpr t $ Cast op v t + ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")" + doExpr t $ Cast op v t -- | Decide what C function to use to implement a CallishMachOp -cmmPrimOpFunctions :: LlvmEnv -> CallishMachOp -> LMString -cmmPrimOpFunctions env mop - = case mop of +cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString +cmmPrimOpFunctions mop = do + + ver <- getLlvmVer + dflags <- getDynFlags + let intrinTy1 = (if ver >= 28 + then "p0i8.p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags) + intrinTy2 = (if ver >= 28 + then "p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags) + unsupported = panic ("cmmPrimOpFunctions: " ++ show mop + ++ " not supported here") + + return $ case mop of MO_F32_Exp -> fsLit "expf" MO_F32_Log -> fsLit "logf" MO_F32_Sqrt -> fsLit "llvm.sqrt.f32" @@ -538,7 +541,8 @@ cmmPrimOpFunctions env mop MO_Memmove -> fsLit $ "llvm.memmove." ++ intrinTy1 MO_Memset -> fsLit $ "llvm.memset." ++ intrinTy2 - (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ show (widthToLlvmInt w) + (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + (MO_BSwap w) -> fsLit $ "llvm.bswap." ++ showSDoc dflags (ppr $ widthToLlvmInt w) MO_Prefetch_Data -> fsLit "llvm.prefetch" @@ -551,44 +555,36 @@ cmmPrimOpFunctions env mop MO_Touch -> unsupported MO_UF_Conv _ -> unsupported - where - dflags = getDflags env - intrinTy1 = (if getLlvmVer env >= 28 - then "p0i8.p0i8." else "") ++ show (llvmWord dflags) - intrinTy2 = (if getLlvmVer env >= 28 - then "p0i8." else "") ++ show (llvmWord dflags) - unsupported = panic ("cmmPrimOpFunctions: " ++ show mop - ++ " not supported here") - -- | Tail function calls -genJump :: LlvmEnv -> CmmExpr -> [GlobalReg] -> UniqSM StmtData +genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData -- Call to known function -genJump env (CmmLit (CmmLabel lbl)) live = do - (env', vf, stmts, top) <- getHsFunc env live lbl - (stgRegs, stgStmts) <- funEpilogue env live +genJump (CmmLit (CmmLabel lbl)) live = do + (vf, stmts, top) <- getHsFunc live lbl + (stgRegs, stgStmts) <- funEpilogue live let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs let s2 = Return Nothing - return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top) + return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top) -- Call to unknown function / address -genJump env expr live = do - let fty = llvmFunTy (getDflags env) live - (env', vf, stmts, top) <- exprToVar env expr +genJump expr live = do + fty <- llvmFunTy live + (vf, stmts, top) <- exprToVar expr + dflags <- getDynFlags let cast = case getVarType vf of ty | isPointer ty -> LM_Bitcast ty | isInt ty -> LM_Inttoptr ty -> panic $ "genJump: Expr is of bad type for function call! (" - ++ show (ty) ++ ")" + ++ showSDoc dflags (ppr ty) ++ ")" (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty) - (stgRegs, stgStmts) <- funEpilogue env live + (stgRegs, stgStmts) <- funEpilogue live let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs let s3 = Return Nothing - return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3, + return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3, top) @@ -596,81 +592,81 @@ genJump env expr live = do -- -- We use stack allocated variables for CmmReg. The optimiser will replace -- these with registers when possible. -genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData -genAssign env reg val = do - let dflags = getDflags env - (env1, vreg, stmts1, top1) = getCmmReg env reg - (env2, vval, stmts2, top2) <- exprToVar env1 val - let stmts = stmts1 `appOL` stmts2 +genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData +genAssign reg val = do + vreg <- getCmmReg reg + (vval, stmts2, top2) <- exprToVar val + let stmts = stmts2 let ty = (pLower . getVarType) vreg + dflags <- getDynFlags case ty of -- Some registers are pointer types, so need to cast value to pointer LMPointer _ | getVarType vval == llvmWord dflags -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty let s2 = Store v vreg - return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + return (stmts `snocOL` s1 `snocOL` s2, top2) LMVector _ _ -> do (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty let s2 = Store v vreg - return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + return (stmts `snocOL` s1 `snocOL` s2, top2) _ -> do let s1 = Store vval vreg - return (env2, stmts `snocOL` s1, top1 ++ top2) + return (stmts `snocOL` s1, top2) -- | CmmStore operation -genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData +genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData -- First we try to detect a few common cases and produce better code for -- these then the default case. We are mostly trying to detect Cmm code -- like I32[Sp + n] and use 'getelementptr' operations instead of the -- generic case that uses casts and pointer arithmetic -genStore env addr@(CmmReg (CmmGlobal r)) val - = genStore_fast env addr r 0 val +genStore addr@(CmmReg (CmmGlobal r)) val + = genStore_fast addr r 0 val -genStore env addr@(CmmRegOff (CmmGlobal r) n) val - = genStore_fast env addr r n val +genStore addr@(CmmRegOff (CmmGlobal r) n) val + = genStore_fast addr r n val -genStore env addr@(CmmMachOp (MO_Add _) [ +genStore addr@(CmmMachOp (MO_Add _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) val - = genStore_fast env addr r (fromInteger n) val + = genStore_fast addr r (fromInteger n) val -genStore env addr@(CmmMachOp (MO_Sub _) [ +genStore addr@(CmmMachOp (MO_Sub _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) val - = genStore_fast env addr r (negate $ fromInteger n) val + = genStore_fast addr r (negate $ fromInteger n) val -- generic case -genStore env addr val = genStore_slow env addr val [other] +genStore addr val + = do other <- getTBAAMeta otherN + genStore_slow addr val other -- | CmmStore operation -- This is a special case for storing to a global register pointer -- offset such as I32[Sp+8]. -genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr - -> UniqSM StmtData -genStore_fast env addr r n val - = let dflags = getDflags env - gr = lmGlobalRegVar (getDflags env) r - meta = [getTBAA r] - grt = (pLower . getVarType) gr - (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) - in case isPointer grt && rem == 0 of +genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr + -> LlvmM StmtData +genStore_fast addr r n val + = do dflags <- getDynFlags + (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + meta <- getTBAARegMeta r + let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) + case isPointer grt && rem == 0 of True -> do - (env', vval, stmts, top) <- exprToVar env val - (gv, s1) <- doExpr grt $ Load gr + (vval, stmts, top) <- exprToVar val (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] -- We might need a different pointer type, so check case pLower grt == getVarType vval of -- were fine True -> do let s3 = MetaStmt meta $ Store vval ptr - return (env', stmts `snocOL` s1 `snocOL` s2 + return (stmts `appOL` s1 `snocOL` s2 `snocOL` s3, top) -- cast to pointer type needed @@ -678,68 +674,69 @@ genStore_fast env addr r n val let ty = (pLift . getVarType) vval (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty let s4 = MetaStmt meta $ Store vval ptr' - return (env', stmts `snocOL` s1 `snocOL` s2 + return (stmts `appOL` s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, top) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway. - False -> genStore_slow env addr val meta + False -> genStore_slow addr val meta -- | CmmStore operation -- Generic case. Uses casts and pointer arithmetic if needed. -genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> [MetaData] -> UniqSM StmtData -genStore_slow env addr val meta = do - (env1, vaddr, stmts1, top1) <- exprToVar env addr - (env2, vval, stmts2, top2) <- exprToVar env1 val +genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData +genStore_slow addr val meta = do + (vaddr, stmts1, top1) <- exprToVar addr + (vval, stmts2, top2) <- exprToVar val let stmts = stmts1 `appOL` stmts2 + dflags <- getDynFlags case getVarType vaddr of -- sometimes we need to cast an int to a pointer before storing LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty let s2 = MetaStmt meta $ Store v vaddr - return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) LMPointer _ -> do let s1 = MetaStmt meta $ Store vval vaddr - return (env2, stmts `snocOL` s1, top1 ++ top2) + return (stmts `snocOL` s1, top1 ++ top2) i@(LMInt _) | i == llvmWord dflags -> do let vty = pLift $ getVarType vval (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty let s2 = MetaStmt meta $ Store vval vptr - return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) other -> pprPanic "genStore: ptr not right type!" (PprCmm.pprExpr addr <+> text ( "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ - ", Var: " ++ show vaddr)) - where dflags = getDflags env + ", Var: " ++ showSDoc dflags (ppr vaddr))) -- | Unconditional branch -genBranch :: LlvmEnv -> BlockId -> UniqSM StmtData -genBranch env id = +genBranch :: BlockId -> LlvmM StmtData +genBranch id = let label = blockIdToLlvm id - in return (env, unitOL $ Branch label, []) + in return (unitOL $ Branch label, []) -- | Conditional branch -genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> BlockId -> UniqSM StmtData -genCondBranch env cond idT idF = do +genCondBranch :: CmmExpr -> BlockId -> BlockId -> LlvmM StmtData +genCondBranch cond idT idF = do let labelT = blockIdToLlvm idT let labelF = blockIdToLlvm idF -- See Note [Literals and branch conditions]. - (env', vc, stmts, top) <- exprToVarOpt env i1Option cond + (vc, stmts, top) <- exprToVarOpt i1Option cond if getVarType vc == i1 then do let s1 = BranchIf vc labelT labelF - return $ (env', stmts `snocOL` s1, top) - else - panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")" + return (stmts `snocOL` s1, top) + else do + dflags <- getDynFlags + panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")" {- Note [Literals and branch conditions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -797,9 +794,9 @@ For a real example of this, see ./rts/StgStdThunks.cmm -- -- N.B. We remove Nothing's from the list of branches, as they are 'undefined'. -- However, they may be defined one day, so we better document this behaviour. -genSwitch :: LlvmEnv -> CmmExpr -> [Maybe BlockId] -> UniqSM StmtData -genSwitch env cond maybe_ids = do - (env', vc, stmts, top) <- exprToVar env cond +genSwitch :: CmmExpr -> [Maybe BlockId] -> LlvmM StmtData +genSwitch cond maybe_ids = do + (vc, stmts, top) <- exprToVar cond let ty = getVarType vc let pairs = [ (ix, id) | (ix,Just id) <- zip [0..] maybe_ids ] @@ -808,7 +805,7 @@ genSwitch env cond maybe_ids = do let (_, defLbl) = head labels let s1 = Switch vc defLbl labels - return $ (env', stmts `snocOL` s1, top) + return $ (stmts `snocOL` s1, top) -- ----------------------------------------------------------------------------- @@ -816,11 +813,10 @@ genSwitch env cond maybe_ids = do -- -- | An expression conversion return data: --- * LlvmEnv: The new enviornment -- * LlvmVar: The var holding the result of the expression -- * LlvmStatements: Any statements needed to evaluate the expression -- * LlvmCmmDecl: Any global data needed for this expression -type ExprData = (LlvmEnv, LlvmVar, LlvmStatements, [LlvmCmmDecl]) +type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl]) -- | Values which can be passed to 'exprToVar' to configure its -- behaviour in certain circumstances. @@ -840,47 +836,47 @@ wordOption = EOption False -- | Convert a CmmExpr to a list of LlvmStatements with the result of the -- expression being stored in the returned LlvmVar. -exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData -exprToVar env = exprToVarOpt env wordOption +exprToVar :: CmmExpr -> LlvmM ExprData +exprToVar = exprToVarOpt wordOption -exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData -exprToVarOpt env opt e = case e of +exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData +exprToVarOpt opt e = case e of CmmLit lit - -> genLit opt env lit + -> genLit opt lit CmmLoad e' ty - -> genLoad env e' ty + -> genLoad e' ty -- Cmmreg in expression is the value, so must load. If you want actual -- reg pointer, call getCmmReg directly. CmmReg r -> do - let (env', vreg, stmts, top) = getCmmReg env r - (v1, s1) <- doExpr (pLower $ getVarType vreg) $ Load vreg - case (isPointer . getVarType) v1 of + (v1, ty, s1) <- getCmmRegVal r + case isPointer ty of True -> do -- Cmm wants the value, so pointer types must be cast to ints + dflags <- getDynFlags (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags) - return (env', v2, stmts `snocOL` s1 `snocOL` s2, top) + return (v2, s1 `snocOL` s2, []) - False -> return (env', v1, stmts `snocOL` s1, top) + False -> return (v1, s1, []) CmmMachOp op exprs - -> genMachOp env opt op exprs + -> genMachOp opt op exprs CmmRegOff r i - -> exprToVar env $ expandCmmReg dflags (r, i) + -> do dflags <- getDynFlags + exprToVar $ expandCmmReg dflags (r, i) CmmStackSlot _ _ -> panic "exprToVar: CmmStackSlot not supported!" - where dflags = getDflags env -- | Handle CmmMachOp expressions -genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData +genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData -- Unary Machop -genMachOp env _ op [x] = case op of +genMachOp _ op [x] = case op of MO_Not w -> let all1 = mkIntLit (widthToLlvmInt w) (-1) @@ -980,29 +976,28 @@ genMachOp env _ op [x] = case op of MO_VF_Quot _ _ -> panicOp where - dflags = getDflags env - negate ty v2 negOp = do - (env', vx, stmts, top) <- exprToVar env x + (vx, stmts, top) <- exprToVar x (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx - return (env', v1, stmts `snocOL` s1, top) + return (v1, stmts `snocOL` s1, top) negateVec ty v2 negOp = do - (env', vx, stmts1, top) <- exprToVar env x - ([vx'], stmts2) <- castVars dflags [(vx, ty)] + (vx, stmts1, top) <- exprToVar x + ([vx'], stmts2) <- castVars [(vx, ty)] (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx' - return (env', v1, stmts1 `appOL` stmts2 `snocOL` s1, top) + return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top) fiConv ty convOp = do - (env', vx, stmts, top) <- exprToVar env x + (vx, stmts, top) <- exprToVar x (v1, s1) <- doExpr ty $ Cast convOp vx ty - return (env', v1, stmts `snocOL` s1, top) + return (v1, stmts `snocOL` s1, top) sameConv from ty reduce expand = do - x'@(env', vx, stmts, top) <- exprToVar env x + x'@(vx, stmts, top) <- exprToVar x let sameConv' op = do (v1, s1) <- doExpr ty $ Cast op vx ty - return (env', v1, stmts `snocOL` s1, top) + return (v1, stmts `snocOL` s1, top) + dflags <- getDynFlags let toWidth = llvmWidthInBits dflags ty -- LLVM doesn't like trying to convert to same width, so -- need to check for that as we do get Cmm code doing it. @@ -1015,88 +1010,82 @@ genMachOp env _ op [x] = case op of ++ "with one argument! (" ++ show op ++ ")" -- Handle GlobalRegs pointers -genMachOp env opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] - = genMachOp_fast env opt o r (fromInteger n) e +genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] + = genMachOp_fast opt o r (fromInteger n) e -genMachOp env opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] - = genMachOp_fast env opt o r (negate . fromInteger $ n) e +genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] + = genMachOp_fast opt o r (negate . fromInteger $ n) e -- Generic case -genMachOp env opt op e = genMachOp_slow env opt op e +genMachOp opt op e = genMachOp_slow opt op e -- | Handle CmmMachOp expressions -- This is a specialised method that handles Global register manipulations like -- 'Sp - 16', using the getelementptr instruction. -genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] - -> UniqSM ExprData -genMachOp_fast env opt op r n e - = let dflags = getDflags env - gr = lmGlobalRegVar dflags r - grt = (pLower . getVarType) gr - (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) - in case isPointer grt && rem == 0 of +genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] + -> LlvmM ExprData +genMachOp_fast opt op r n e + = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + dflags <- getDynFlags + let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) + case isPointer grt && rem == 0 of True -> do - (gv, s1) <- doExpr grt $ Load gr (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags) - return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, []) + return (var, s1 `snocOL` s2 `snocOL` s3, []) - False -> genMachOp_slow env opt op e + False -> genMachOp_slow opt op e -- | Handle CmmMachOp expressions -- This handles all the cases not handle by the specialised genMachOp_fast. -genMachOp_slow :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData +genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData -- Element extraction -genMachOp_slow env _ (MO_V_Extract l w) [val, idx] = do - (env1, vval, stmts1, top1) <- exprToVar env val - (env2, vidx, stmts2, top2) <- exprToVar env1 idx - ([vval'], stmts3) <- castVars dflags [(vval, LMVector l ty)] - (v1, s1) <- doExpr ty $ Extract vval' vidx - return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) +genMachOp_slow _ (MO_V_Extract l w) [val, idx] = do + (vval, stmts1, top1) <- exprToVar val + (vidx, stmts2, top2) <- exprToVar idx + ([vval'], stmts3) <- castVars [(vval, LMVector l ty)] + (v1, s1) <- doExpr ty $ Extract vval' vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) where - dflags = getDflags env ty = widthToLlvmInt w -genMachOp_slow env _ (MO_VF_Extract l w) [val, idx] = do - (env1, vval, stmts1, top1) <- exprToVar env val - (env2, vidx, stmts2, top2) <- exprToVar env1 idx - ([vval'], stmts3) <- castVars dflags [(vval, LMVector l ty)] - (v1, s1) <- doExpr ty $ Extract vval' vidx - return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) +genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = do + (vval, stmts1, top1) <- exprToVar val + (vidx, stmts2, top2) <- exprToVar idx + ([vval'], stmts3) <- castVars [(vval, LMVector l ty)] + (v1, s1) <- doExpr ty $ Extract vval' vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) where - dflags = getDflags env ty = widthToLlvmFloat w -- Element insertion -genMachOp_slow env _ (MO_V_Insert l w) [val, elt, idx] = do - (env1, vval, stmts1, top1) <- exprToVar env val - (env2, velt, stmts2, top2) <- exprToVar env1 elt - (env3, vidx, stmts3, top3) <- exprToVar env2 idx - ([vval'], stmts4) <- castVars dflags [(vval, ty)] - (v1, s1) <- doExpr ty $ Insert vval' velt vidx - return (env3, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1, +genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = do + (vval, stmts1, top1) <- exprToVar val + (velt, stmts2, top2) <- exprToVar elt + (vidx, stmts3, top3) <- exprToVar idx + ([vval'], stmts4) <- castVars [(vval, ty)] + (v1, s1) <- doExpr ty $ Insert vval' velt vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1, top1 ++ top2 ++ top3) where - dflags = getDflags env ty = LMVector l (widthToLlvmInt w) -genMachOp_slow env _ (MO_VF_Insert l w) [val, elt, idx] = do - (env1, vval, stmts1, top1) <- exprToVar env val - (env2, velt, stmts2, top2) <- exprToVar env1 elt - (env3, vidx, stmts3, top3) <- exprToVar env2 idx - ([vval'], stmts4) <- castVars dflags [(vval, ty)] - (v1, s1) <- doExpr ty $ Insert vval' velt vidx - return (env3, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1, +genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = do + (vval, stmts1, top1) <- exprToVar val + (velt, stmts2, top2) <- exprToVar elt + (vidx, stmts3, top3) <- exprToVar idx + ([vval'], stmts4) <- castVars [(vval, ty)] + (v1, s1) <- doExpr ty $ Insert vval' velt vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1, top1 ++ top2 ++ top3) where - dflags = getDflags env ty = LMVector l (widthToLlvmFloat w) -- Binary MachOp -genMachOp_slow env opt op [x, y] = case op of +genMachOp_slow opt op [x, y] = case op of MO_Eq _ -> genBinComp opt LM_CMP_Eq MO_Ne _ -> genBinComp opt LM_CMP_Ne @@ -1177,21 +1166,19 @@ genMachOp_slow env opt op [x, y] = case op of MO_VF_Neg {} -> panicOp where - dflags = getDflags env - binLlvmOp ty binOp = do - (env1, vx, stmts1, top1) <- exprToVar env x - (env2, vy, stmts2, top2) <- exprToVar env1 y + (vx, stmts1, top1) <- exprToVar x + (vy, stmts2, top2) <- exprToVar y if getVarType vx == getVarType vy then do (v1, s1) <- doExpr (ty vx) $ binOp vx vy - return (env2, v1, stmts1 `appOL` stmts2 `snocOL` s1, + return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2) else do -- Error. Continue anyway so we can debug the generated ll file. - let dflags = getDflags env - style = mkCodeStyle CStyle + dflags <- getDynFlags + let style = mkCodeStyle CStyle toString doc = renderWithStyle dflags doc style cmmToStr = (lines . toString . PprCmm.pprExpr) let dx = Comment $ map fsLit $ cmmToStr x @@ -1199,31 +1186,32 @@ genMachOp_slow env opt op [x, y] = case op of (v1, s1) <- doExpr (ty vx) $ binOp vx vy let allStmts = stmts1 `appOL` stmts2 `snocOL` dx `snocOL` dy `snocOL` s1 - return (env2, v1, allStmts, top1 ++ top2) + return (v1, allStmts, top1 ++ top2) binCastLlvmOp ty binOp = do - (env1, vx, stmts1, top1) <- exprToVar env x - (env2, vy, stmts2, top2) <- exprToVar env1 y - ([vx', vy'], stmts3) <- castVars dflags [(vx, ty), (vy, ty)] + (vx, stmts1, top1) <- exprToVar x + (vy, stmts2, top2) <- exprToVar y + ([vx', vy'], stmts3) <- castVars [(vx, ty), (vy, ty)] (v1, s1) <- doExpr ty $ binOp vx' vy' - return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) -- | Need to use EOption here as Cmm expects word size results from -- comparisons while LLVM return i1. Need to extend to llvmWord type -- if expected. See Note [Literals and branch conditions]. genBinComp opt cmp = do - ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) + ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) + dflags <- getDynFlags if getVarType v1 == i1 then case i1Expected opt of True -> return ed False -> do let w_ = llvmWord dflags (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_ - return (env', v2, stmts `snocOL` s1, top) + return (v2, stmts `snocOL` s1, top) else panic $ "genBinComp: Compare returned type other then i1! " - ++ (show $ getVarType v1) + ++ (showSDoc dflags $ ppr $ getVarType v1) genBinMach op = binLlvmOp getVarType (LlvmOp op) @@ -1233,11 +1221,12 @@ genMachOp_slow env opt op [x, y] = case op of -- CmmExpr's. This is the LLVM assembly equivalent of the NCG -- implementation. Its much longer due to type information/safety. -- This should actually compile to only about 3 asm instructions. - isSMulOK :: Width -> CmmExpr -> CmmExpr -> UniqSM ExprData + isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData isSMulOK _ x y = do - (env1, vx, stmts1, top1) <- exprToVar env x - (env2, vy, stmts2, top2) <- exprToVar env1 y + (vx, stmts1, top1) <- exprToVar x + (vy, stmts2, top2) <- exprToVar y + dflags <- getDynFlags let word = getVarType vx let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx) let shift = llvmWidthInBits dflags word @@ -1256,127 +1245,151 @@ genMachOp_slow env opt op [x, y] = case op of (dst, s8) <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2 let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4 `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8 - return (env2, dst, stmts1 `appOL` stmts2 `appOL` stmts, + return (dst, stmts1 `appOL` stmts2 `appOL` stmts, top1 ++ top2) else - panic $ "isSMulOK: Not bit type! (" ++ show word ++ ")" + panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")" panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encourntered" ++ "with two arguments! (" ++ show op ++ ")" -- More then two expression, invalid! -genMachOp_slow _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!" +genMachOp_slow _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!" -- | Handle CmmLoad expression. -genLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData +genLoad :: CmmExpr -> CmmType -> LlvmM ExprData -- First we try to detect a few common cases and produce better code for -- these then the default case. We are mostly trying to detect Cmm code -- like I32[Sp + n] and use 'getelementptr' operations instead of the -- generic case that uses casts and pointer arithmetic -genLoad env e@(CmmReg (CmmGlobal r)) ty - = genLoad_fast env e r 0 ty +genLoad e@(CmmReg (CmmGlobal r)) ty + = genLoad_fast e r 0 ty -genLoad env e@(CmmRegOff (CmmGlobal r) n) ty - = genLoad_fast env e r n ty +genLoad e@(CmmRegOff (CmmGlobal r) n) ty + = genLoad_fast e r n ty -genLoad env e@(CmmMachOp (MO_Add _) [ +genLoad e@(CmmMachOp (MO_Add _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) ty - = genLoad_fast env e r (fromInteger n) ty + = genLoad_fast e r (fromInteger n) ty -genLoad env e@(CmmMachOp (MO_Sub _) [ +genLoad e@(CmmMachOp (MO_Sub _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) ty - = genLoad_fast env e r (negate $ fromInteger n) ty + = genLoad_fast e r (negate $ fromInteger n) ty -- generic case -genLoad env e ty = genLoad_slow env e ty [other] +genLoad e ty + = do other <- getTBAAMeta otherN + genLoad_slow e ty other -- | Handle CmmLoad expression. -- This is a special case for loading from a global register pointer -- offset such as I32[Sp+8]. -genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType - -> UniqSM ExprData -genLoad_fast env e r n ty = - let dflags = getDflags env - gr = lmGlobalRegVar dflags r - meta = [getTBAA r] - grt = (pLower . getVarType) gr - ty' = cmmToLlvmType ty +genLoad_fast :: CmmExpr -> GlobalReg -> Int -> CmmType + -> LlvmM ExprData +genLoad_fast e r n ty = do + dflags <- getDynFlags + (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + meta <- getTBAARegMeta r + let ty' = cmmToLlvmType ty (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) - in case isPointer grt && rem == 0 of + case isPointer grt && rem == 0 of True -> do - (gv, s1) <- doExpr grt $ Load gr (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] -- We might need a different pointer type, so check case grt == ty' of -- were fine True -> do - (var, s3) <- doExpr ty' (MetaExpr meta $ Load ptr) - return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, + (var, s3) <- doExpr ty' (MExpr meta $ Load ptr) + return (var, s1 `snocOL` s2 `snocOL` s3, []) -- cast to pointer type needed False -> do let pty = pLift ty' (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty - (var, s4) <- doExpr ty' (MetaExpr meta $ Load ptr') - return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3 + (var, s4) <- doExpr ty' (MExpr meta $ Load ptr') + return (var, s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, []) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway. - False -> genLoad_slow env e ty meta + False -> genLoad_slow e ty meta -- | Handle Cmm load expression. -- Generic case. Uses casts and pointer arithmetic if needed. -genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> [MetaData] -> UniqSM ExprData -genLoad_slow env e ty meta = do - (env', iptr, stmts, tops) <- exprToVar env e +genLoad_slow :: CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData +genLoad_slow e ty meta = do + (iptr, stmts, tops) <- exprToVar e + dflags <- getDynFlags case getVarType iptr of LMPointer _ -> do (dvar, load) <- doExpr (cmmToLlvmType ty) - (MetaExpr meta $ Load iptr) - return (env', dvar, stmts `snocOL` load, tops) + (MExpr meta $ Load iptr) + return (dvar, stmts `snocOL` load, tops) i@(LMInt _) | i == llvmWord dflags -> do let pty = LMPointer $ cmmToLlvmType ty (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty (dvar, load) <- doExpr (cmmToLlvmType ty) - (MetaExpr meta $ Load ptr) - return (env', dvar, stmts `snocOL` cast `snocOL` load, tops) + (MExpr meta $ Load ptr) + return (dvar, stmts `snocOL` cast `snocOL` load, tops) - other -> pprPanic "exprToVar: CmmLoad expression is not right type!" + other -> do dflags <- getDynFlags + pprPanic "exprToVar: CmmLoad expression is not right type!" (PprCmm.pprExpr e <+> text ( "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ - ", Var: " ++ show iptr)) - where dflags = getDflags env - --- | Handle CmmReg expression --- --- We allocate CmmReg on the stack. This avoids having to map a CmmReg to an --- equivalent SSA form and avoids having to deal with Phi node insertion. --- This is also the approach recommended by LLVM developers. -getCmmReg :: LlvmEnv -> CmmReg -> ExprData -getCmmReg env r@(CmmLocal (LocalReg un _)) - = let exists = varLookup un env - (newv, stmts) = allocReg r - nenv = varInsert un (pLower $ getVarType newv) env - in case exists of - Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, []) - Nothing -> (nenv, newv, stmts, []) - -getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar (getDflags env) g, nilOL, []) - - --- | Allocate a CmmReg on the stack + ", Var: " ++ showSDoc dflags (ppr iptr))) + + +-- | Handle CmmReg expression. This will return a pointer to the stack +-- location of the register. Throws an error if it isn't allocated on +-- the stack. +getCmmReg :: CmmReg -> LlvmM LlvmVar +getCmmReg (CmmLocal (LocalReg un _)) + = do exists <- varLookup un + dflags <- getDynFlags + case exists of + Just ety -> return (LMLocalVar un $ pLift ety) + Nothing -> fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!" + -- This should never happen, as every local variable should + -- have been assigned a value at some point, triggering + -- "funPrologue" to allocate it on the stack. + +getCmmReg (CmmGlobal g) + = do onStack <- checkStackReg g + dflags <- getDynFlags + if onStack + then return (lmGlobalRegVar dflags g) + else fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!" + +-- | Return the value of a given register, as well as its type. Might +-- need to be load from stack. +getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements) +getCmmRegVal reg = + case reg of + CmmGlobal g -> do + onStack <- checkStackReg g + dflags <- getDynFlags + if onStack then loadFromStack else do + let r = lmGlobalRegArg dflags g + return (r, getVarType r, nilOL) + _ -> loadFromStack + where loadFromStack = do + ptr <- getCmmReg reg + let ty = pLower $ getVarType ptr + (v, s) <- doExpr ty (Load ptr) + return (v, ty, unitOL s) + +-- | Allocate a local CmmReg on the stack allocReg :: CmmReg -> (LlvmVar, LlvmStatements) allocReg (CmmLocal (LocalReg un ty)) = let ty' = cmmToLlvmType ty @@ -1389,8 +1402,8 @@ allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should" -- | Generate code for a literal -genLit :: EOption -> LlvmEnv -> CmmLit -> UniqSM ExprData -genLit opt env (CmmInt i w) +genLit :: EOption -> CmmLit -> LlvmM ExprData +genLit opt (CmmInt i w) -- See Note [Literals and branch conditions]. = let width | i1Expected opt = i1 | otherwise = LMInt (widthInBits w) @@ -1398,56 +1411,41 @@ genLit opt env (CmmInt i w) -- , fsLit $ "Width : " ++ show w -- , fsLit $ "Width' : " ++ show (widthInBits w) -- ] - in return (env, mkIntLit width i, nilOL, []) + in return (mkIntLit width i, nilOL, []) -genLit _ env (CmmFloat r w) - = return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w), +genLit _ (CmmFloat r w) + = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w), nilOL, []) - -genLit opt env (CmmVec ls) + +genLit opt (CmmVec ls) = do llvmLits <- mapM toLlvmLit ls - return (env, LMLitVar $ LMVectorLit llvmLits, nilOL, []) + return (LMLitVar $ LMVectorLit llvmLits, nilOL, []) where - toLlvmLit :: CmmLit -> UniqSM LlvmLit + toLlvmLit :: CmmLit -> LlvmM LlvmLit toLlvmLit lit = do - (_, llvmLitVar, _, _) <- genLit opt env lit + (llvmLitVar, _, _) <- genLit opt lit case llvmLitVar of LMLitVar llvmLit -> return llvmLit _ -> panic "genLit" -genLit _ env cmm@(CmmLabel l) - = let dflags = getDflags env - label = strCLabel_llvm env l - ty = funLookup label env - lmty = cmmToLlvmType $ cmmLitType dflags cmm - in case ty of - -- Make generic external label definition and then pointer to it - Nothing -> do - let glob@(var, _) = genStringLabelRef dflags label - let ldata = [CmmData Data [([glob], [])]] - let env' = funInsert label (pLower $ getVarType var) env - (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) - return (env', v1, unitOL s1, ldata) - - -- Referenced data exists in this module, retrieve type and make - -- pointer to it. - Just ty' -> do - let var = LMGlobalVar label (LMPointer ty') - ExternallyVisible Nothing Nothing False - (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) - return (env, v1, unitOL s1, []) - -genLit opt env (CmmLabelOff label off) = do - let dflags = getDflags env - (env', vlbl, stmts, stat) <- genLit opt env (CmmLabel label) +genLit _ cmm@(CmmLabel l) + = do var <- getGlobalPtr =<< strCLabel_llvm l + dflags <- getDynFlags + let lmty = cmmToLlvmType $ cmmLitType dflags cmm + (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) + return (v1, unitOL s1, []) + +genLit opt (CmmLabelOff label off) = do + dflags <- getDynFlags + (vlbl, stmts, stat) <- genLit opt (CmmLabel label) let voff = toIWord dflags off (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff - return (env', v1, stmts `snocOL` s1, stat) + return (v1, stmts `snocOL` s1, stat) -genLit opt env (CmmLabelDiffOff l1 l2 off) = do - let dflags = getDflags env - (env1, vl1, stmts1, stat1) <- genLit opt env (CmmLabel l1) - (env2, vl2, stmts2, stat2) <- genLit opt env1 (CmmLabel l2) +genLit opt (CmmLabelDiffOff l1 l2 off) = do + dflags <- getDynFlags + (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1) + (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2) let voff = toIWord dflags off let ty1 = getVarType vl1 let ty2 = getVarType vl2 @@ -1457,16 +1455,16 @@ genLit opt env (CmmLabelDiffOff l1 l2 off) = do then do (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2 (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff - return (env2, v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2, + return (v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2, stat1 ++ stat2) else panic "genLit: CmmLabelDiffOff encountered with different label ty!" -genLit opt env (CmmBlock b) - = genLit opt env (CmmLabel $ infoTblLbl b) +genLit opt (CmmBlock b) + = genLit opt (CmmLabel $ infoTblLbl b) -genLit _ _ CmmHighStackMark +genLit _ CmmHighStackMark = panic "genStaticLit - CmmHighStackMark unsupported!" @@ -1474,51 +1472,82 @@ genLit _ _ CmmHighStackMark -- * Misc -- --- | Function prologue. Load STG arguments into variables for function. -funPrologue :: DynFlags -> LiveGlobalRegs -> [LlvmStatement] -funPrologue dflags live = concat $ map getReg $ activeStgRegs platform - where platform = targetPlatform dflags - isLive r = r `elem` alwaysLive || r `elem` live - getReg rr = - let reg = lmGlobalRegVar dflags rr - arg = lmGlobalRegArg dflags rr - ty = (pLower . getVarType) reg - trash = LMLitVar $ LMUndefLit ty - alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 - in - if isLive rr - then [alloc, Store arg reg] - else [alloc, Store trash reg] - +-- | Find CmmRegs that get assigned and allocate them on the stack +-- +-- Any register that gets written needs to be allcoated on the +-- stack. This avoids having to map a CmmReg to an equivalent SSA form +-- and avoids having to deal with Phi node insertion. This is also +-- the approach recommended by LLVM developers. +-- +-- On the other hand, this is unecessarily verbose if the register in +-- question is never written. Therefore we skip it where we can to +-- save a few lines in the output and hopefully speed compilation up a +-- bit. +funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData +funPrologue live cmmBlocks = do + + trash <- getTrashRegs + let getAssignedRegs :: CmmNode O O -> [CmmReg] + getAssignedRegs (CmmAssign reg _) = [reg] + -- Calls will trash all registers. Unfortunately, this needs them to + -- be stack-allocated in the first place. + getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmGlobal trash ++ map CmmLocal rs + getAssignedRegs _ = [] + getRegsBlock (_, body, _) = concatMap getAssignedRegs $ blockToList body + assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks + isLive r = r `elem` alwaysLive || r `elem` live + + dflags <- getDynFlags + stmtss <- flip mapM assignedRegs $ \reg -> + case reg of + CmmLocal (LocalReg un _) -> do + let (newv, stmts) = allocReg reg + varInsert un (pLower $ getVarType newv) + return stmts + CmmGlobal r -> do + let reg = lmGlobalRegVar dflags r + arg = lmGlobalRegArg dflags r + ty = (pLower . getVarType) reg + trash = LMLitVar $ LMUndefLit ty + rval = if isLive r then arg else trash + alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 + markStackReg r + return $ toOL [alloc, Store rval reg] + + return (concatOL stmtss, []) -- | Function epilogue. Load STG variables to use as argument for call. -- STG Liveness optimisation done here. -funEpilogue :: LlvmEnv -> LiveGlobalRegs -> UniqSM ([LlvmVar], LlvmStatements) +funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements) +funEpilogue live = do + + -- Have information and liveness optimisation is enabled? + let liveRegs = alwaysLive ++ live + isSSE (FloatReg _) = True + isSSE (DoubleReg _) = True + isSSE (XmmReg _) = True + isSSE _ = False + + -- Set to value or "undef" depending on whether the register is + -- actually live + dflags <- getDynFlags + let loadExpr r = do + (v, _, s) <- getCmmRegVal (CmmGlobal r) + return (Just $ v, s) + loadUndef r = do + let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) + return (Just $ LMLitVar $ LMUndefLit ty, nilOL) + platform <- getDynFlag targetPlatform + loads <- flip mapM (activeStgRegs platform) $ \r -> case () of + _ | r `elem` liveRegs -> loadExpr r + | not (isSSE r) -> loadUndef r + | otherwise -> return (Nothing, nilOL) --- Have information and liveness optimisation is enabled -funEpilogue env live = do - loads <- mapM loadExpr (filter isPassed (activeStgRegs platform)) let (vars, stmts) = unzip loads - return (vars, concatOL stmts) - where - dflags = getDflags env - platform = targetPlatform dflags - isLive r = r `elem` alwaysLive || r `elem` live - isPassed r = not (isSSE r) || isLive r - isSSE (FloatReg _) = True - isSSE (DoubleReg _) = True - isSSE (XmmReg _) = True - isSSE _ = False - loadExpr r | isLive r = do - let reg = lmGlobalRegVar dflags r - (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg - return (v, unitOL s) - loadExpr r = do - let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) - return (LMLitVar $ LMUndefLit ty, unitOL Nop) - - --- | A serries of statements to trash all the STG registers. + return (catMaybes vars, concatOL stmts) + + +-- | A series of statements to trash all the STG registers. -- -- In LLVM we pass the STG registers around everywhere in function calls. -- So this means LLVM considers them live across the entire function, when @@ -1529,59 +1558,47 @@ funEpilogue env live = do -- before the call by assigning the 'undef' value to them. The ones we -- need are restored from the Cmm local var and the ones we don't need -- are fine to be trashed. -trashStmts :: DynFlags -> LlvmStatements -trashStmts dflags = concatOL $ map trashReg $ activeStgRegs platform - where platform = targetPlatform dflags - trashReg r = - let reg = lmGlobalRegVar dflags r - ty = (pLower . getVarType) reg - trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg - in case callerSaves (targetPlatform dflags) r of - True -> trash - False -> nilOL - +getTrashStmts :: LlvmM LlvmStatements +getTrashStmts = do + regs <- getTrashRegs + stmts <- flip mapM regs $ \ r -> do + reg <- getCmmReg (CmmGlobal r) + let ty = (pLower . getVarType) reg + return $ Store (LMLitVar $ LMUndefLit ty) reg + return $ toOL stmts + +getTrashRegs :: LlvmM [GlobalReg] +getTrashRegs = do plat <- getLlvmPlatform + return $ filter (callerSaves plat) (activeStgRegs plat) -- | Get a function pointer to the CLabel specified. -- -- This is for Haskell functions, function type is assumed, so doesn't work -- with foreign functions. -getHsFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> UniqSM ExprData -getHsFunc env live lbl - = let dflags = getDflags env - fn = strCLabel_llvm env lbl - ty = funLookup fn env - in case ty of - -- Function in module in right form - Just ty'@(LMFunction sig) -> do - let fun = LMGlobalVar fn ty' (funcLinkage sig) Nothing Nothing False - return (env, fun, nilOL, []) - - -- label in module but not function pointer, convert - Just ty' -> do - let fun = LMGlobalVar fn (pLift ty') ExternallyVisible - Nothing Nothing False - (v1, s1) <- doExpr (pLift (llvmFunTy dflags live)) $ - Cast LM_Bitcast fun (pLift (llvmFunTy dflags live)) - return (env, v1, unitOL s1, []) - - -- label not in module, create external reference - Nothing -> do - let ty' = LMFunction $ llvmFunSig env live lbl ExternallyVisible - let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False - let top = CmmData Data [([],[ty'])] - let env' = funInsert fn ty' env - return (env', fun, nilOL, [top]) - +getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData +getHsFunc live lbl + = do fty <- llvmFunTy live + name <- strCLabel_llvm lbl + getHsFunc' name fty + +getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData +getHsFunc' name fty + = do fun <- getGlobalPtr name + if getVarType fun == fty + then return (fun, nilOL, []) + else do (v1, s1) <- doExpr (pLift fty) + $ Cast LM_Bitcast fun (pLift fty) + return (v1, unitOL s1, []) -- | Create a new local var -mkLocalVar :: LlvmType -> UniqSM LlvmVar +mkLocalVar :: LlvmType -> LlvmM LlvmVar mkLocalVar ty = do - un <- getUniqueUs + un <- runUs getUniqueUs return $ LMLocalVar un ty -- | Execute an expression, assigning result to a var -doExpr :: LlvmType -> LlvmExpression -> UniqSM (LlvmVar, LlvmStatement) +doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement) doExpr ty expr = do v <- mkLocalVar ty return (v, Assignment v expr) @@ -1618,3 +1635,13 @@ panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s pprPanic :: String -> SDoc -> a pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d + +-- | Returns TBAA meta data by unique +getTBAAMeta :: Unique -> LlvmM [MetaAnnot] +getTBAAMeta u = do + mi <- getUniqMeta u + return [MetaAnnot tbaa (MetaNode i) | let Just i = mi] + +-- | Returns TBAA meta data for given register +getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot] +getTBAARegMeta = getTBAAMeta . getTBAA diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index 83b5453aa9..6212cfc9fb 100644 --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -3,7 +3,7 @@ -- module LlvmCodeGen.Data ( - genLlvmData, resolveLlvmDatas, resolveLlvmData + genLlvmData ) where #include "HsVersions.h" @@ -18,8 +18,6 @@ import Cmm import FastString import qualified Outputable -import Data.List (foldl') - -- ---------------------------------------------------------------------------- -- * Constants -- @@ -32,43 +30,23 @@ structStr = fsLit "_struct" -- * Top level -- --- | Pass a CmmStatic section to an equivalent Llvm code. Can't --- complete this completely though as we need to pass all CmmStatic --- sections before all references can be resolved. This last step is --- done by 'resolveLlvmData'. -genLlvmData :: LlvmEnv -> (Section, CmmStatics) -> LlvmUnresData -genLlvmData env (sec, Statics lbl xs) = - let dflags = getDflags env - static = map genData xs - label = strCLabel_llvm env lbl - - types = map getStatTypes static - getStatTypes (Left x) = cmmToLlvmType $ cmmLitType dflags x - getStatTypes (Right x) = getStatType x +-- | Pass a CmmStatic section to an equivalent Llvm code. +genLlvmData :: (Section, CmmStatics) -> LlvmM LlvmData +genLlvmData (sec, Statics lbl xs) = do + label <- strCLabel_llvm lbl + static <- mapM genData xs + let types = map getStatType static strucTy = LMStruct types alias = LMAlias ((label `appendFS` structStr), strucTy) - in (lbl, sec, alias, static) - -resolveLlvmDatas :: LlvmEnv -> [LlvmUnresData] -> (LlvmEnv, [LlvmData]) -resolveLlvmDatas env ldata - = foldl' res (env, []) ldata - where res (e, xs) ll = - let (e', nd) = resolveLlvmData e ll - in (e', nd:xs) - --- | Fix up CLabel references now that we should have passed all CmmData. -resolveLlvmData :: LlvmEnv -> LlvmUnresData -> (LlvmEnv, LlvmData) -resolveLlvmData env (lbl, sec, alias, unres) = - let (env', static, refs) = resDatas env unres ([], []) struct = Just $ LMStaticStruc static alias - label = strCLabel_llvm env lbl link = if (externallyVisibleCLabel lbl) then ExternallyVisible else Internal - const = isSecConstant sec + const = if isSecConstant sec then Constant else Global glob = LMGlobalVar label alias link Nothing Nothing const - in (env', ((glob,struct):refs, [alias])) + + return ([LMGlobal glob struct], [alias]) -- | Should a data in this section be considered constant isSecConstant :: Section -> Bool @@ -82,80 +60,19 @@ isSecConstant (OtherSection _) = False -- ---------------------------------------------------------------------------- --- ** Resolve Data/CLabel references --- - --- | Resolve data list -resDatas :: LlvmEnv -> [UnresStatic] -> ([LlvmStatic], [LMGlobal]) - -> (LlvmEnv, [LlvmStatic], [LMGlobal]) - -resDatas env [] (stats, glob) - = (env, stats, glob) - -resDatas env (cmm:rest) (stats, globs) - = let (env', nstat, nglob) = resData env cmm - in resDatas env' rest (stats ++ [nstat], globs ++ nglob) - --- | Resolve an individual static label if it needs to be. --- --- We check the 'LlvmEnv' to see if the reference has been defined in this --- module. If it has we can retrieve its type and make a pointer, otherwise --- we introduce a generic external definition for the referenced label and --- then make a pointer. -resData :: LlvmEnv -> UnresStatic -> (LlvmEnv, LlvmStatic, [LMGlobal]) - -resData env (Right stat) = (env, stat, []) - -resData env (Left cmm@(CmmLabel l)) = - let dflags = getDflags env - label = strCLabel_llvm env l - ty = funLookup label env - lmty = cmmToLlvmType $ cmmLitType dflags cmm - in case ty of - -- Make generic external label defenition and then pointer to it - Nothing -> - let glob@(var, _) = genStringLabelRef dflags label - env' = funInsert label (pLower $ getVarType var) env - ptr = LMStaticPointer var - in (env', LMPtoI ptr lmty, [glob]) - -- Referenced data exists in this module, retrieve type and make - -- pointer to it. - Just ty' -> - let var = LMGlobalVar label (LMPointer ty') - ExternallyVisible Nothing Nothing False - ptr = LMStaticPointer var - in (env, LMPtoI ptr lmty, []) - -resData env (Left (CmmLabelOff label off)) = - let dflags = getDflags env - (env', var, glob) = resData env (Left (CmmLabel label)) - offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) - in (env', LMAdd var offset, glob) - -resData env (Left (CmmLabelDiffOff l1 l2 off)) = - let dflags = getDflags env - (env1, var1, glob1) = resData env (Left (CmmLabel l1)) - (env2, var2, glob2) = resData env1 (Left (CmmLabel l2)) - var = LMSub var1 var2 - offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) - in (env2, LMAdd var offset, glob1 ++ glob2) - -resData _ _ = panic "resData: Non CLabel expr as left type!" - --- ---------------------------------------------------------------------------- -- * Generate static data -- -- | Handle static data -genData :: CmmStatic -> UnresStatic +genData :: CmmStatic -> LlvmM LlvmStatic -genData (CmmString str) = +genData (CmmString str) = do let v = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) str ve = v ++ [LMStaticLit $ LMIntLit 0 i8] - in Right $ LMStaticArray ve (LMArray (length ve) i8) + return $ LMStaticArray ve (LMArray (length ve) i8) genData (CmmUninitialised bytes) - = Right $ LMUninitType (LMArray bytes i8) + = return $ LMUninitType (LMArray bytes i8) genData (CmmStaticLit lit) = genStaticLit lit @@ -164,27 +81,47 @@ genData (CmmStaticLit lit) -- -- Will either generate the code or leave it unresolved if it is a 'CLabel' -- which isn't yet known. -genStaticLit :: CmmLit -> UnresStatic +genStaticLit :: CmmLit -> LlvmM LlvmStatic genStaticLit (CmmInt i w) - = Right $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w)) + = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w)) genStaticLit (CmmFloat r w) - = Right $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w)) + = return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w)) genStaticLit (CmmVec ls) - = Right $ LMStaticLit (LMVectorLit (map toLlvmLit ls)) + = do sls <- mapM toLlvmLit ls + return $ LMStaticLit (LMVectorLit sls) where - toLlvmLit :: CmmLit -> LlvmLit - toLlvmLit lit = case genStaticLit lit of - Right (LMStaticLit llvmLit) -> llvmLit - _ -> panic "genStaticLit" + toLlvmLit :: CmmLit -> LlvmM LlvmLit + toLlvmLit lit = do + slit <- genStaticLit lit + case slit of + LMStaticLit llvmLit -> return llvmLit + _ -> panic "genStaticLit" -- Leave unresolved, will fix later -genStaticLit c@(CmmLabel _ ) = Left $ c -genStaticLit c@(CmmLabelOff _ _) = Left $ c -genStaticLit c@(CmmLabelDiffOff _ _ _) = Left $ c +genStaticLit cmm@(CmmLabel l) = do + var <- getGlobalPtr =<< strCLabel_llvm l + dflags <- getDynFlags + let ptr = LMStaticPointer var + lmty = cmmToLlvmType $ cmmLitType dflags cmm + return $ LMPtoI ptr lmty + +genStaticLit (CmmLabelOff label off) = do + dflags <- getDynFlags + var <- genStaticLit (CmmLabel label) + let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) + return $ LMAdd var offset + +genStaticLit (CmmLabelDiffOff l1 l2 off) = do + dflags <- getDynFlags + var1 <- genStaticLit (CmmLabel l1) + var2 <- genStaticLit (CmmLabel l2) + let var = LMSub var1 var2 + offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) + return $ LMAdd var offset -genStaticLit (CmmBlock b) = Left $ CmmLabel $ infoTblLbl b +genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b genStaticLit (CmmHighStackMark) = panic "genStaticLit: CmmHighStackMark unsupported!" diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index c699631e9c..1c63d3f67f 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -11,7 +11,6 @@ module LlvmCodeGen.Ppr ( import Llvm import LlvmCodeGen.Base import LlvmCodeGen.Data -import LlvmCodeGen.Regs import CLabel import Cmm @@ -28,12 +27,7 @@ import Unique -- | Header code for LLVM modules pprLlvmHeader :: SDoc -pprLlvmHeader = sdocWithDynFlags $ \dflags -> - moduleLayout - $+$ text "" - $+$ ppLlvmFunctionDecls (map snd (ghcInternalFunctions dflags)) - $+$ ppLlvmMetas stgTBAA - $+$ text "" +pprLlvmHeader = moduleLayout -- | LLVM module layout description for the host target @@ -61,6 +55,9 @@ moduleLayout = sdocWithPlatform $ \platform -> Platform { platformArch = ArchARM {}, platformOS = OSAndroid } -> text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\"" $+$ text "target triple = \"arm-unknown-linux-androideabi\"" + Platform { platformArch = ArchARM {}, platformOS = OSQNXNTO } -> + text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\"" + $+$ text "target triple = \"arm-unknown-nto-qnx8.0.0eabi\"" Platform { platformArch = ArchARM {}, platformOS = OSiOS } -> text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\"" $+$ text "target triple = \"arm-apple-darwin10\"" @@ -72,63 +69,61 @@ moduleLayout = sdocWithPlatform $ \platform -> -- | Pretty print LLVM data code pprLlvmData :: LlvmData -> SDoc pprLlvmData (globals, types) = - let tryConst (v, Just s ) = ppLlvmGlobal (v, Just s) - tryConst g@(_, Nothing) = ppLlvmGlobal g - - ppLlvmTys (LMAlias a) = ppLlvmAlias a + let ppLlvmTys (LMAlias a) = ppLlvmAlias a ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f ppLlvmTys _other = empty types' = vcat $ map ppLlvmTys types - globals' = vcat $ map tryConst globals + globals' = ppLlvmGlobals globals in types' $+$ globals' -- | Pretty print LLVM code -pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (SDoc, [LlvmVar]) -pprLlvmCmmDecl _ _ (CmmData _ lmdata) - = (vcat $ map pprLlvmData lmdata, []) +pprLlvmCmmDecl :: Int -> LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar]) +pprLlvmCmmDecl _ (CmmData _ lmdata) + = return (vcat $ map pprLlvmData lmdata, []) -pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl live (ListGraph blks)) - = let (idoc, ivar) = case mb_info of - Nothing -> (empty, []) +pprLlvmCmmDecl count (CmmProc mb_info entry_lbl live (ListGraph blks)) + = do (idoc, ivar) <- case mb_info of + Nothing -> return (empty, []) Just (Statics info_lbl dat) - -> pprInfoTable env count info_lbl (Statics entry_lbl dat) - in (idoc $+$ ( - let sec = mkLayoutSection (count + 1) - (lbl',sec') = case mb_info of + -> pprInfoTable count info_lbl (Statics entry_lbl dat) + + let sec = mkLayoutSection (count + 1) + (lbl',sec') = case mb_info of Nothing -> (entry_lbl, Nothing) Just (Statics info_lbl _) -> (info_lbl, sec) - link = if externallyVisibleCLabel lbl' + link = if externallyVisibleCLabel lbl' then ExternallyVisible else Internal - lmblocks = map (\(BasicBlock id stmts) -> + lmblocks = map (\(BasicBlock id stmts) -> LlvmBlock (getUnique id) stmts) blks - fun = mkLlvmFunc env live lbl' link sec' lmblocks - in ppLlvmFunction fun - ), ivar) + + fun <- mkLlvmFunc live lbl' link sec' lmblocks + + return (idoc $+$ ppLlvmFunction fun, ivar) -- | Pretty print CmmStatic -pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (SDoc, [LlvmVar]) -pprInfoTable env count info_lbl stat - = let dflags = getDflags env - unres = genLlvmData env (Text, stat) - (_, (ldata, ltypes)) = resolveLlvmData env unres - - setSection ((LMGlobalVar _ ty l _ _ c), d) - = let sec = mkLayoutSection count - ilabel = strCLabel_llvm env info_lbl - `appendFS` fsLit iTableSuf - gv = LMGlobalVar ilabel ty l sec (llvmInfAlign dflags) c - v = if l == Internal then [gv] else [] - in ((gv, d), v) - setSection v = (v,[]) - - (ldata', llvmUsed) = setSection (last ldata) - in if length ldata /= 1 +pprInfoTable :: Int -> CLabel -> CmmStatics -> LlvmM (SDoc, [LlvmVar]) +pprInfoTable count info_lbl stat + = do (ldata, ltypes) <- genLlvmData (Text, stat) + + dflags <- getDynFlags + let setSection (LMGlobal (LMGlobalVar _ ty l _ _ c) d) = do + lbl <- strCLabel_llvm info_lbl + let sec = mkLayoutSection count + ilabel = lbl `appendFS` fsLit iTableSuf + gv = LMGlobalVar ilabel ty l sec (llvmInfAlign dflags) c + v = if l == Internal then [gv] else [] + funInsert ilabel ty + return (LMGlobal gv d, v) + setSection v = return (v,[]) + + (ldata', llvmUsed) <- setSection (last ldata) + if length ldata /= 1 then Outputable.panic "LlvmCodeGen.Ppr: invalid info table!" - else (pprLlvmData ([ldata'], ltypes), llvmUsed) + else return (pprLlvmData ([ldata'], ltypes), llvmUsed) -- | We generate labels for info tables by converting them to the same label diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index 7271c2f3d9..1b87929499 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -4,7 +4,7 @@ module LlvmCodeGen.Regs ( lmGlobalRegArg, lmGlobalRegVar, alwaysLive, - stgTBAA, top, base, stack, heap, rx, other, tbaa, getTBAA + stgTBAA, baseN, stackN, heapN, rxN, otherN, tbaa, getTBAA ) where #include "HsVersions.h" @@ -15,6 +15,7 @@ import CmmExpr import DynFlags import FastString import Outputable ( panic ) +import Unique -- | Get the LlvmVar function variable storing the real register lmGlobalRegVar :: DynFlags -> GlobalReg -> LlvmVar @@ -76,48 +77,38 @@ lmGlobalReg dflags suf reg alwaysLive :: [GlobalReg] alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node] --- | STG Type Based Alias Analysis metadata -stgTBAA :: [LlvmMeta] +-- | STG Type Based Alias Analysis hierarchy +stgTBAA :: [(Unique, LMString, Maybe Unique)] stgTBAA - = [ MetaUnamed topN [MetaStr (fsLit "top")] - , MetaUnamed stackN [MetaStr (fsLit "stack"), MetaNode topN] - , MetaUnamed heapN [MetaStr (fsLit "heap"), MetaNode topN] - , MetaUnamed rxN [MetaStr (fsLit "rx"), MetaNode heapN] - , MetaUnamed baseN [MetaStr (fsLit "base"), MetaNode topN] + = [ (topN, fsLit "top", Nothing) + , (stackN, fsLit "stack", Just topN) + , (heapN, fsLit "heap", Just topN) + , (rxN, fsLit "rx", Just heapN) + , (baseN, fsLit "base", Just topN) -- FIX: Not 100% sure about 'others' place. Might need to be under 'heap'. -- OR I think the big thing is Sp is never aliased, so might want -- to change the hieracy to have Sp on its own branch that is never -- aliased (e.g never use top as a TBAA node). - , MetaUnamed otherN [MetaStr (fsLit "other"), MetaNode topN] + , (otherN, fsLit "other", Just topN) ] -- | Id values -topN, stackN, heapN, rxN, baseN, otherN:: LlvmMetaUnamed -topN = LMMetaUnamed 0 -stackN = LMMetaUnamed 1 -heapN = LMMetaUnamed 2 -rxN = LMMetaUnamed 3 -baseN = LMMetaUnamed 4 -otherN = LMMetaUnamed 5 - --- | The various TBAA types -top, heap, stack, rx, base, other :: MetaData -top = (tbaa, topN) -heap = (tbaa, heapN) -stack = (tbaa, stackN) -rx = (tbaa, rxN) -base = (tbaa, baseN) -other = (tbaa, otherN) +topN, stackN, heapN, rxN, baseN, otherN :: Unique +topN = getUnique (fsLit "LlvmCodeGen.Regs.topN") +stackN = getUnique (fsLit "LlvmCodeGen.Regs.stackN") +heapN = getUnique (fsLit "LlvmCodeGen.Regs.heapN") +rxN = getUnique (fsLit "LlvmCodeGen.Regs.rxN") +baseN = getUnique (fsLit "LlvmCodeGen.Regs.baseN") +otherN = getUnique (fsLit "LlvmCodeGen.Regs.otherN") -- | The TBAA metadata identifier tbaa :: LMString tbaa = fsLit "tbaa" -- | Get the correct TBAA metadata information for this register type -getTBAA :: GlobalReg -> MetaData -getTBAA BaseReg = base -getTBAA Sp = stack -getTBAA Hp = heap -getTBAA (VanillaReg _ _) = rx -getTBAA _ = top - +getTBAA :: GlobalReg -> Unique +getTBAA BaseReg = baseN +getTBAA Sp = stackN +getTBAA Hp = heapN +getTBAA (VanillaReg _ _) = rxN +getTBAA _ = topN diff --git a/compiler/main/Annotations.hs b/compiler/main/Annotations.hs index 277c059b11..7de1a9914b 100644 --- a/compiler/main/Annotations.hs +++ b/compiler/main/Annotations.hs @@ -16,6 +16,7 @@ module Annotations ( deserializeAnns ) where +import Binary import Module ( Module ) import Name import Outputable @@ -23,6 +24,7 @@ import Serialized import UniqFM import Unique +import Control.Monad import Data.Maybe import Data.Typeable import Data.Word ( Word8 ) @@ -64,6 +66,19 @@ instance Outputable name => Outputable (AnnTarget name) where ppr (NamedTarget nm) = text "Named target" <+> ppr nm ppr (ModuleTarget mod) = text "Module target" <+> ppr mod +instance Binary name => Binary (AnnTarget name) where + put_ bh (NamedTarget a) = do + putByte bh 0 + put_ bh a + put_ bh (ModuleTarget a) = do + putByte bh 1 + put_ bh a + get bh = do + h <- getByte bh + case h of + 0 -> liftM NamedTarget $ get bh + _ -> liftM ModuleTarget $ get bh + instance Outputable Annotation where ppr ann = ppr (ann_target ann) diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index d6c096a595..b8b187241b 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -45,6 +45,7 @@ import System.IO \begin{code} codeOutput :: DynFlags -> Module + -> FilePath -> ModLocation -> ForeignStubs -> [PackageId] @@ -52,7 +53,7 @@ codeOutput :: DynFlags -> IO (FilePath, (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})) -codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream +codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream = do { -- Lint each CmmGroup as it goes past @@ -72,10 +73,9 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps cmm_stream } ; showPass dflags "CodeOutput" - ; let filenm = hscOutName dflags ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs ; case hscTarget dflags of { - HscAsm -> outputAsm dflags filenm linted_cmm_stream; + HscAsm -> outputAsm dflags this_mod filenm linted_cmm_stream; HscC -> outputC dflags filenm linted_cmm_stream pkg_deps; HscLlvm -> outputLlvm dflags filenm linted_cmm_stream; HscInterpreted -> panic "codeOutput: HscInterpreted"; @@ -140,8 +140,8 @@ outputC dflags filenm cmm_stream packages %************************************************************************ \begin{code} -outputAsm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO () -outputAsm dflags filenm cmm_stream +outputAsm :: DynFlags -> Module -> FilePath -> Stream IO RawCmmGroup () -> IO () +outputAsm dflags this_mod filenm cmm_stream | cGhcWithNativeCodeGen == "YES" = do ncg_uniqs <- mkSplitUniqSupply 'n' @@ -149,7 +149,7 @@ outputAsm dflags filenm cmm_stream _ <- {-# SCC "OutputAsm" #-} doOutput filenm $ \h -> {-# SCC "NativeCodeGen" #-} - nativeCodeGen dflags h ncg_uniqs cmm_stream + nativeCodeGen dflags this_mod h ncg_uniqs cmm_stream return () | otherwise @@ -168,13 +168,9 @@ outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO () outputLlvm dflags filenm cmm_stream = do ncg_uniqs <- mkSplitUniqSupply 'n' - -- ToDo: make the LLVM backend consume the C-- incrementally, - -- by pushing the cmm_stream inside (c.f. nativeCodeGen) - rawcmms <- Stream.collect cmm_stream - {-# SCC "llvm_output" #-} doOutput filenm $ \f -> {-# SCC "llvm_CodeGen" #-} - llvmCodeGen dflags f ncg_uniqs rawcmms + llvmCodeGen dflags f ncg_uniqs cmm_stream \end{code} diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index bdc2e8e812..c005a46873 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -78,7 +78,7 @@ preprocess :: HscEnv -> IO (DynFlags, FilePath) preprocess hsc_env (filename, mb_phase) = ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) - runPipeline anyHsc hsc_env (filename, mb_phase) + runPipeline anyHsc hsc_env (filename, fmap RealPhase mb_phase) Nothing Temporary Nothing{-no ModLocation-} Nothing{-no stub-} -- --------------------------------------------------------------------------- @@ -148,9 +148,7 @@ compileOne' m_tc_result mHscMessage output_fn <- getOutputFilename next_phase Temporary basename dflags next_phase (Just location) - let dflags' = dflags { hscOutName = output_fn, - extCoreName = basename ++ ".hcr" } - let hsc_env' = hsc_env { hsc_dflags = dflags' } + let extCore_filename = basename ++ ".hcr" -- -fforce-recomp should also work with --make let force_recomp = gopt Opt_ForceRecomp dflags @@ -166,12 +164,12 @@ compileOne' m_tc_result mHscMessage e <- genericHscCompileGetFrontendResult always_do_basic_recompilation_check m_tc_result mHscMessage - hsc_env' summary source_modified mb_old_iface (mod_index, nmods) + hsc_env summary source_modified mb_old_iface (mod_index, nmods) case e of Left iface -> do details <- genModDetails hsc_env iface - MASSERT (isJust maybe_old_linkable) + MASSERT(isJust maybe_old_linkable) return (HomeModInfo{ hm_details = details, hm_iface = iface, hm_linkable = maybe_old_linkable }) @@ -182,19 +180,19 @@ compileOne' m_tc_result mHscMessage HscInterpreted -> case ms_hsc_src summary of HsBootFile -> - do (iface, _changed, details) <- hscSimpleIface hsc_env' tc_result mb_old_hash + do (iface, _changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash return (HomeModInfo{ hm_details = details, hm_iface = iface, hm_linkable = maybe_old_linkable }) - _ -> do guts0 <- hscDesugar hsc_env' summary tc_result - guts <- hscSimplify hsc_env' guts0 - (iface, _changed, details, cgguts) <- hscNormalIface hsc_env' guts mb_old_hash - (hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env' cgguts summary + _ -> do guts0 <- hscDesugar hsc_env summary tc_result + guts <- hscSimplify hsc_env guts0 + (iface, _changed, details, cgguts) <- hscNormalIface hsc_env extCore_filename guts mb_old_hash + (hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env cgguts summary stub_o <- case hasStub of Nothing -> return [] Just stub_c -> do - stub_o <- compileStub hsc_env' stub_c + stub_o <- compileStub hsc_env stub_c return [DotO stub_o] let hs_unlinked = [BCOs comp_bc modBreaks] @@ -212,7 +210,7 @@ compileOne' m_tc_result mHscMessage hm_iface = iface, hm_linkable = Just linkable }) HscNothing -> - do (iface, _changed, details) <- hscSimpleIface hsc_env' tc_result mb_old_hash + do (iface, _changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash let linkable = if isHsBoot src_flavour then maybe_old_linkable else Just (LM (ms_hs_date summary) this_mod []) @@ -223,30 +221,27 @@ compileOne' m_tc_result mHscMessage _ -> case ms_hsc_src summary of HsBootFile -> - do (iface, changed, details) <- hscSimpleIface hsc_env' tc_result mb_old_hash - hscWriteIface dflags' iface changed summary - touchObjectFile dflags' object_filename + do (iface, changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash + hscWriteIface dflags iface changed summary + touchObjectFile dflags object_filename return (HomeModInfo{ hm_details = details, hm_iface = iface, hm_linkable = maybe_old_linkable }) - _ -> do guts0 <- hscDesugar hsc_env' summary tc_result - guts <- hscSimplify hsc_env' guts0 - (iface, changed, details, cgguts) <- hscNormalIface hsc_env' guts mb_old_hash - hscWriteIface dflags' iface changed summary - (_outputFilename, hasStub) <- hscGenHardCode hsc_env' cgguts summary + _ -> do guts0 <- hscDesugar hsc_env summary tc_result + guts <- hscSimplify hsc_env guts0 + (iface, changed, details, cgguts) <- hscNormalIface hsc_env extCore_filename guts mb_old_hash + hscWriteIface dflags iface changed summary -- We're in --make mode: finish the compilation pipeline. - maybe_stub_o <- case hasStub of - Nothing -> return Nothing - Just stub_c -> do - stub_o <- compileStub hsc_env' stub_c - return (Just stub_o) - _ <- runPipeline StopLn hsc_env' (output_fn,Nothing) + let mod_name = ms_mod_name summary + _ <- runPipeline StopLn hsc_env + (output_fn, + Just (HscOut src_flavour mod_name (HscRecomp cgguts summary))) (Just basename) Persistent (Just location) - maybe_stub_o + Nothing -- The object filename comes from the ModLocation o_time <- getModificationUTCTime object_filename let linkable = LM o_time this_mod [DotO object_filename] @@ -375,7 +370,7 @@ linkingNeeded dflags linkables pkg_deps = do Left _ -> return True Right t -> do -- first check object files and extra_ld_inputs - let extra_ld_inputs = ldInputs dflags + let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs let (errs,extra_times) = splitEithers e_extra_times let obj_times = map linkableTime linkables ++ extra_times @@ -475,7 +470,7 @@ compileFile hsc_env stop_phase (src, mb_phase) = do _ -> stop_phase ( _, out_file) <- runPipeline stop_phase' hsc_env - (src, mb_phase) Nothing output + (src, fmap RealPhase mb_phase) Nothing output Nothing{-no ModLocation-} Nothing return out_file @@ -521,12 +516,12 @@ data PipelineOutput runPipeline :: Phase -- ^ When to stop -> HscEnv -- ^ Compilation environment - -> (FilePath,Maybe Phase) -- ^ Input filename (and maybe -x suffix) + -> (FilePath,Maybe PhasePlus) -- ^ Input filename (and maybe -x suffix) -> Maybe FilePath -- ^ original basename (if different from ^^^) -> PipelineOutput -- ^ Output filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module -> Maybe FilePath -- ^ stub object, if we have one - -> IO (DynFlags, FilePath) -- ^ (final flags, output filename) + -> IO (DynFlags, FilePath) -- ^ (final flags, output filename) runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc maybe_stub_o @@ -543,13 +538,14 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) | otherwise = input_basename -- If we were given a -x flag, then use that phase to start from - start_phase = fromMaybe (startPhase suffix') mb_phase + start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase - isHaskell (Unlit _) = True - isHaskell (Cpp _) = True - isHaskell (HsPp _) = True - isHaskell (Hsc _) = True - isHaskell _ = False + isHaskell (RealPhase (Unlit _)) = True + isHaskell (RealPhase (Cpp _)) = True + isHaskell (RealPhase (HsPp _)) = True + isHaskell (RealPhase (Hsc _)) = True + isHaskell (HscOut {}) = True + isHaskell _ = False isHaskellishFile = isHaskell start_phase @@ -568,10 +564,13 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) -- before B in a normal compilation pipeline. let happensBefore' = happensBefore dflags - when (not (start_phase `happensBefore'` stop_phase)) $ - throwGhcExceptionIO (UsageError - ("cannot compile this file to desired target: " - ++ input_fn)) + case start_phase of + RealPhase start_phase' -> + when (not (start_phase' `happensBefore'` stop_phase)) $ + throwGhcExceptionIO (UsageError + ("cannot compile this file to desired target: " + ++ input_fn)) + HscOut {} -> return () debugTraceMsg dflags 4 (text "Running the pipeline") r <- runPipeline' start_phase hsc_env env input_fn @@ -584,7 +583,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do debugTraceMsg dflags 4 (text "Running the pipeline again for -dynamic-too") - let dflags' = doDynamicToo dflags + let dflags' = dynamicTooMkDynamicDynFlags dflags hsc_env' <- newHscEnv dflags' _ <- runPipeline' start_phase hsc_env' env input_fn maybe_loc maybe_stub_o @@ -592,7 +591,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) return r runPipeline' - :: Phase -- ^ When to start + :: PhasePlus -- ^ When to start -> HscEnv -- ^ Compilation environment -> PipeEnv -> FilePath -- ^ Input filename @@ -605,7 +604,7 @@ runPipeline' start_phase hsc_env env input_fn -- Execute the pipeline... let state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o } - evalP (pipeLoop (RealPhase start_phase) input_fn) env state + evalP (pipeLoop start_phase input_fn) env state -- ----------------------------------------------------------------------------- -- The pipeline uses a monad to carry around various bits of information @@ -722,12 +721,12 @@ pipeLoop phase input_fn = do (ptext (sLit "Running phase") <+> ppr phase) (next_phase, output_fn) <- runPhase phase input_fn dflags r <- pipeLoop next_phase output_fn - case next_phase of + case phase of HscOut {} -> whenGeneratingDynamicToo dflags $ do - setDynFlags $ doDynamicToo dflags + setDynFlags $ dynamicTooMkDynamicDynFlags dflags -- TODO shouldn't ignore result: - _ <- pipeLoop next_phase output_fn + _ <- pipeLoop phase input_fn return () _ -> return () @@ -801,7 +800,7 @@ instance Outputable PhasePlus where -- what the rest of the phases will be until part-way through the -- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning -- of a source file can change the latter stages of the pipeline from --- taking the via-C route to using the native code generator. +-- taking the LLVM route to using the native code generator. -- runPhase :: PhasePlus -- ^ Run this phase -> FilePath -- ^ name of the input file @@ -821,9 +820,7 @@ runPhase (RealPhase (Unlit sf)) input_fn dflags = do output_fn <- phaseOutputFilename (Cpp sf) - let unlit_flags = getOpts dflags opt_L - flags = map SysTools.Option unlit_flags ++ - [ -- The -h option passes the file name for unlit to + let flags = [ -- The -h option passes the file name for unlit to -- put in a #line directive SysTools.Option "-h" , SysTools.Option $ escape $ normalise input_fn @@ -870,7 +867,7 @@ runPhase (RealPhase (Cpp sf)) input_fn dflags0 return (RealPhase (HsPp sf), input_fn) else do output_fn <- phaseOutputFilename (HsPp sf) - liftIO $ doCpp dflags1 True{-raw-} False{-no CC opts-} + liftIO $ doCpp dflags1 True{-raw-} input_fn output_fn -- re-read the pragmas now that we've preprocessed the file -- See #2464,#3457 @@ -896,7 +893,6 @@ runPhase (RealPhase (HsPp sf)) input_fn dflags -- to the next phase of the pipeline. return (RealPhase (Hsc sf), input_fn) else do - let hspp_opts = getOpts dflags opt_F PipeEnv{src_basename, src_suffix} <- getPipeEnv let orig_fn = src_basename <.> src_suffix output_fn <- phaseOutputFilename (Hsc sf) @@ -904,8 +900,7 @@ runPhase (RealPhase (HsPp sf)) input_fn dflags ( [ SysTools.Option orig_fn , SysTools.Option input_fn , SysTools.FileOption "" output_fn - ] ++ - map SysTools.Option hspp_opts + ] ) -- re-read pragmas now that we've parsed the file (see #3674) @@ -960,8 +955,6 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 let o_file = ml_obj_file location -- The real object file - setModLocation location - -- Figure out if the source has changed, for recompilation avoidance. -- -- Setting source_unchanged to True means that M.o seems @@ -986,9 +979,8 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 then return SourceUnmodified else return SourceModified - let dflags' = dflags { extCoreName = basename ++ ".hcr" } + let extCore_filename = basename ++ ".hcr" - setDynFlags dflags' PipeState{hsc_env=hsc_env'} <- getPipeState -- Tell the finder cache about this module @@ -1008,7 +1000,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 ms_srcimps = src_imps } -- run the compiler! - result <- liftIO $ hscCompileOneShot hsc_env' + result <- liftIO $ hscCompileOneShot hsc_env' extCore_filename mod_summary source_unchanged return (HscOut src_flavour mod_name result, @@ -1016,6 +1008,8 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 runPhase (HscOut src_flavour mod_name result) _ dflags = do location <- getLocation src_flavour mod_name + setModLocation location + let o_file = ml_obj_file location -- The real object file hsc_lang = hscTarget dflags next_phase = hscPostBackendPhase dflags src_flavour hsc_lang @@ -1038,11 +1032,9 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do HscRecomp cgguts mod_summary -> do output_fn <- phaseOutputFilename next_phase - let dflags' = dflags { hscOutName = output_fn } - setDynFlags dflags' PipeState{hsc_env=hsc_env'} <- getPipeState - (outputFilename, mStub) <- liftIO $ hscGenHardCode hsc_env' cgguts mod_summary + (outputFilename, mStub) <- liftIO $ hscGenHardCode hsc_env' cgguts mod_summary output_fn case mStub of Nothing -> return () Just stub_c -> @@ -1057,26 +1049,21 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do runPhase (RealPhase CmmCpp) input_fn dflags = do output_fn <- phaseOutputFilename Cmm - liftIO $ doCpp dflags False{-not raw-} True{-include CC opts-} + liftIO $ doCpp dflags False{-not raw-} input_fn output_fn return (RealPhase Cmm, output_fn) runPhase (RealPhase Cmm) input_fn dflags = do - PipeEnv{src_basename} <- getPipeEnv let hsc_lang = hscTarget dflags let next_phase = hscPostBackendPhase dflags HsSrcFile hsc_lang output_fn <- phaseOutputFilename next_phase - let dflags' = dflags { hscOutName = output_fn, - extCoreName = src_basename ++ ".hcr" } - - setDynFlags dflags' PipeState{hsc_env} <- getPipeState - liftIO $ hscCompileCmmFile hsc_env input_fn + liftIO $ hscCompileCmmFile hsc_env input_fn output_fn return (RealPhase next_phase, output_fn) @@ -1090,7 +1077,6 @@ runPhase (RealPhase cc_phase) input_fn dflags | any (cc_phase `eqPhase`) [Cc, Ccpp, HCc, Cobjc, Cobjcpp] = do let platform = targetPlatform dflags - cc_opts = getOpts dflags opt_c hcc = cc_phase `eqPhase` HCc let cmdline_include_paths = includePaths dflags @@ -1130,8 +1116,9 @@ runPhase (RealPhase cc_phase) input_fn dflags split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ] | otherwise = [ ] - let cc_opt | optLevel dflags >= 2 = "-O2" - | otherwise = "-O" + let cc_opt | optLevel dflags >= 2 = [ "-O2" ] + | optLevel dflags >= 1 = [ "-O" ] + | otherwise = [] -- Decide next phase let next_phase = As @@ -1154,10 +1141,10 @@ runPhase (RealPhase cc_phase) input_fn dflags -- very weakly typed, being derived from C--. ["-fno-strict-aliasing"] - let gcc_lang_opt | cc_phase `eqPhase` Ccpp = "c++" - | cc_phase `eqPhase` Cobjc = "objective-c" + let gcc_lang_opt | cc_phase `eqPhase` Ccpp = "c++" + | cc_phase `eqPhase` Cobjc = "objective-c" | cc_phase `eqPhase` Cobjcpp = "objective-c++" - | otherwise = "c" + | otherwise = "c" liftIO $ SysTools.runCc dflags ( -- force the C compiler to interpret this file as C when -- compiling .hc files, by adding the -x c option. @@ -1201,10 +1188,10 @@ runPhase (RealPhase cc_phase) input_fn dflags then gcc_extra_viac_flags ++ more_hcc_opts else []) ++ verbFlags - ++ [ "-S", cc_opt ] + ++ [ "-S" ] + ++ cc_opt ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ] ++ framework_paths - ++ cc_opts ++ split_opt ++ include_paths ++ pkg_extra_cc_opts @@ -1263,8 +1250,7 @@ runPhase (RealPhase As) input_fn dflags | otherwise = return SysTools.runAs as_prog <- whichAsProg - let as_opts = getOpts dflags opt_a - cmdline_include_paths = includePaths dflags + let cmdline_include_paths = includePaths dflags next_phase <- maybeMergeStub output_fn <- phaseOutputFilename next_phase @@ -1275,8 +1261,7 @@ runPhase (RealPhase As) input_fn dflags let runAssembler inputFilename outputFilename = liftIO $ as_prog dflags - (map SysTools.Option as_opts - ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ] + ([ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ] -- We only support SparcV9 and better because V8 lacks an atomic CAS -- instruction so we have to make sure that the assembler accepts the @@ -1322,8 +1307,6 @@ runPhase (RealPhase SplitAs) _input_fn dflags liftIO $ mapM_ removeFile $ map (split_odir </>) $ filter (osuf `isSuffixOf`) fs - let as_opts = getOpts dflags opt_a - let (split_s_prefix, n) = case splitInfo dflags of Nothing -> panic "No split info" Just x -> x @@ -1335,8 +1318,7 @@ runPhase (RealPhase SplitAs) _input_fn dflags takeFileName base_o ++ "__" ++ show n <.> osuf let assemble_file n - = SysTools.runAs dflags - (map SysTools.Option as_opts ++ + = SysTools.runAs dflags ( -- We only support SparcV9 and better because V8 lacks an atomic CAS -- instruction so we have to make sure that the assembler accepts the @@ -1392,14 +1374,13 @@ runPhase (RealPhase LlvmOpt) input_fn dflags = do ver <- liftIO $ readIORef (llvmVersion dflags) - let lo_opts = getOpts dflags opt_lo - opt_lvl = max 0 (min 2 $ optLevel dflags) + let opt_lvl = max 0 (min 2 $ optLevel dflags) -- don't specify anything if user has specified commands. We do this -- for opt but not llc since opt is very specifically for optimisation -- passes only, so if the user is passing us extra options we assume -- they know what they are doing and don't get in the way. - optFlag = if null lo_opts - then [SysTools.Option (llvmOpts !! opt_lvl)] + optFlag = if null (getOpts dflags opt_lo) + then map SysTools.Option $ words (llvmOpts !! opt_lvl) else [] tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true" @@ -1413,14 +1394,13 @@ runPhase (RealPhase LlvmOpt) input_fn dflags SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ optFlag - ++ [SysTools.Option tbaa] - ++ map SysTools.Option lo_opts) + ++ [SysTools.Option tbaa]) return (RealPhase LlvmLlc, output_fn) where -- we always (unless -optlo specified) run Opt since we rely on it to -- fix up some pretty big deficiencies in the code we generate - llvmOpts = ["-mem2reg", "-O1", "-O2"] + llvmOpts = ["-mem2reg -globalopt", "-O1", "-O2"] ----------------------------------------------------------------------------- -- LlvmLlc phase @@ -1429,8 +1409,7 @@ runPhase (RealPhase LlvmLlc) input_fn dflags = do ver <- liftIO $ readIORef (llvmVersion dflags) - let lc_opts = getOpts dflags opt_lc - opt_lvl = max 0 (min 2 $ optLevel dflags) + let opt_lvl = max 0 (min 2 $ optLevel dflags) -- iOS requires external references to be loaded indirectly from the -- DATA segment or dyld traps at runtime writing into TEXT: see #7722 rmodel | platformOS (targetPlatform dflags) == OSiOS = "dynamic-no-pic" @@ -1454,7 +1433,6 @@ runPhase (RealPhase LlvmLlc) input_fn dflags SysTools.Option $ "-relocation-model=" ++ rmodel, SysTools.FileOption "" input_fn, SysTools.Option "-o", SysTools.FileOption "" output_fn] - ++ map SysTools.Option lc_opts ++ [SysTools.Option tbaa] ++ map SysTools.Option fpOpts ++ map SysTools.Option abiOpts @@ -1607,7 +1585,6 @@ mkExtraObj dflags extn xs FileOption "" cFile, Option "-o", FileOption "" oFile] - ++ map SysTools.Option (getOpts dflags opt_c) -- see #5528 ++ map (FileOption "-I") (includeDirs rtsDetails)) return oFile @@ -1665,7 +1642,17 @@ mkNoteObjsToLinkIntoBinary dflags dep_packages = do text elfSectionNote, text "\n", - text "\t.ascii \"", info', text "\"\n" ] + text "\t.ascii \"", info', text "\"\n", + + -- ALL generated assembly must have this section to disable + -- executable stacks. See also + -- compiler/nativeGen/AsmCodeGen.lhs for another instance + -- where we need to do this. + (if platformHasGnuNonexecStack (targetPlatform dflags) + then text ".section .note.GNU-stack,\"\",@progbits\n" + else empty) + + ] where info' = text $ escape info @@ -1694,7 +1681,7 @@ getLinkInfo dflags dep_packages = do rtsOpts dflags, rtsOptsEnabled dflags, gopt Opt_NoHsMain dflags, - extra_ld_inputs, + map showOpt extra_ld_inputs, getOpts dflags opt_l) -- return (show link_info) @@ -1828,7 +1815,13 @@ linkBinary dflags o_files dep_packages = do extraLinkObj <- mkExtraObjToLinkIntoBinary dflags noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages - pkg_link_opts <- getPackageLinkOpts dflags dep_packages + pkg_link_opts <- if platformBinariesAreStaticLibs platform + then -- If building an executable really means + -- making a static library (e.g. iOS), then + -- we don't want the options (like -lm) + -- that getPackageLinkOpts gives us. #7720 + return [] + else getPackageLinkOpts dflags dep_packages pkg_framework_path_opts <- if platformUsesFrameworks platform @@ -1860,9 +1853,6 @@ linkBinary dflags o_files dep_packages = do -- probably _stub.o files let extra_ld_inputs = ldInputs dflags - -- opts from -optl-<blah> (including -l<blah> options) - let extra_ld_opts = getOpts dflags opt_l - -- Here are some libs that need to be linked at the *end* of -- the command line, because they contain symbols that are referred to -- by the RTS. We can't therefore use the ordinary way opts for these. @@ -1926,10 +1916,10 @@ linkBinary dflags o_files dep_packages = do else []) ++ o_files + ++ lib_path_opts) ++ extra_ld_inputs - ++ lib_path_opts - ++ extra_ld_opts - ++ rc_objs + ++ map SysTools.Option ( + rc_objs ++ framework_path_opts ++ framework_opts ++ pkg_lib_path_opts @@ -1950,15 +1940,16 @@ linkBinary dflags o_files dep_packages = do exeFileName :: DynFlags -> FilePath exeFileName dflags | Just s <- outputFile dflags = - if platformOS (targetPlatform dflags) == OSMinGW32 - then if null (takeExtension s) - then s <.> "exe" - else s - else s + case platformOS (targetPlatform dflags) of + OSMinGW32 -> s <?.> "exe" + OSiOS -> s <?.> "a" + _ -> s | otherwise = if platformOS (targetPlatform dflags) == OSMinGW32 then "main.exe" else "a.out" + where s <?.> ext | null (takeExtension s) = s <.> ext + | otherwise = s maybeCreateManifest :: DynFlags @@ -2000,12 +1991,10 @@ maybeCreateManifest dflags exe_filename -- show is a bit hackish above, but we need to escape the -- backslashes in the path. - let wr_opts = getOpts dflags opt_windres runWindres dflags $ map SysTools.Option $ ["--input="++rc_filename, "--output="++rc_obj_filename, "--output-format=coff"] - ++ wr_opts -- no FileOptions here: windres doesn't like seeing -- backslashes, apparently @@ -2028,9 +2017,9 @@ linkDynLibCheck dflags o_files dep_packages -- ----------------------------------------------------------------------------- -- Running CPP -doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO () -doCpp dflags raw include_cc_opts input_fn output_fn = do - let hscpp_opts = getOpts dflags opt_P ++ picPOpts dflags +doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO () +doCpp dflags raw input_fn output_fn = do + let hscpp_opts = picPOpts dflags let cmdline_include_paths = includePaths dflags pkg_include_dirs <- getPackageIncludePath dflags [] @@ -2039,10 +2028,6 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do let verbFlags = getVerbFlags dflags - let cc_opts - | include_cc_opts = getOpts dflags opt_c - | otherwise = [] - let cpp_prog args | raw = SysTools.runCpp dflags args | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args) @@ -2069,10 +2054,13 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do ++ map SysTools.Option target_defs ++ map SysTools.Option backend_defs ++ map SysTools.Option hscpp_opts - ++ map SysTools.Option cc_opts ++ map SysTools.Option sse_defs + -- Set the language mode to assembler-with-cpp when preprocessing. This + -- alleviates some of the C99 macro rules relating to whitespace and the hash + -- operator, which we tend to abuse. Clang in particular is not very happy + -- about this. ++ [ SysTools.Option "-x" - , SysTools.Option "c" + , SysTools.Option "assembler-with-cpp" , SysTools.Option input_fn -- We hackily use Option instead of FileOption here, so that the file -- name is not back-slashed on Windows. cpp is capable of diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index af4518f8dc..94a6697418 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -32,7 +32,7 @@ module DynFlags ( lang_set, whenGeneratingDynamicToo, ifGeneratingDynamicToo, whenCannotGenerateDynamicToo, - doDynamicToo, + dynamicTooMkDynamicDynFlags, DynFlags(..), HasDynFlags(..), ContainsDynFlags(..), RtsOptsEnabled(..), @@ -50,7 +50,7 @@ module DynFlags ( printOutputForUser, printInfoForUser, - Way(..), mkBuildTag, wayRTSOnly, updateWays, + Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays, wayGeneralFlags, wayUnsetGeneralFlags, -- ** Safe Haskell @@ -79,6 +79,7 @@ module DynFlags ( defaultFatalMessager, defaultLogAction, defaultLogActionHPrintDoc, + defaultLogActionHPutStrDoc, defaultFlushOut, defaultFlushErr, @@ -129,6 +130,9 @@ module DynFlags ( -- * SSE isSse2Enabled, isSse4_2Enabled, + + -- * Linker information + LinkerInfo(..), ) where #include "HsVersions.h" @@ -274,6 +278,8 @@ data GeneralFlag -- optimisation opts | Opt_Strictness | Opt_LateDmdAnal + | Opt_KillAbsence + | Opt_KillOneShot | Opt_FullLaziness | Opt_FloatIn | Opt_Specialise @@ -350,6 +356,7 @@ data GeneralFlag | Opt_RPath | Opt_RelativeDynlibPaths | Opt_Hpc + | Opt_FlatCache -- PreInlining is on by default. The option is there just to see how -- bad things get if you turn it off! @@ -407,6 +414,8 @@ data WarningFlag = | Opt_WarnIncompletePatterns | Opt_WarnIncompleteUniPatterns | Opt_WarnIncompletePatternsRecUpd + | Opt_WarnOverflowedLiterals + | Opt_WarnEmptyEnumerations | Opt_WarnMissingFields | Opt_WarnMissingImportList | Opt_WarnMissingMethods @@ -527,6 +536,7 @@ data ExtensionFlag | Opt_MagicHash | Opt_EmptyDataDecls | Opt_KindSignatures + | Opt_RoleAnnotations | Opt_ParallelListComp | Opt_TransformListComp | Opt_MonadComprehensions @@ -551,6 +561,7 @@ data ExtensionFlag | Opt_LambdaCase | Opt_MultiWayIf | Opt_TypeHoles + | Opt_NegativeLiterals | Opt_EmptyCase deriving (Eq, Enum, Show) @@ -561,8 +572,6 @@ data DynFlags = DynFlags { ghcLink :: GhcLink, hscTarget :: HscTarget, settings :: Settings, - hscOutName :: String, -- ^ Name of the output file - extCoreName :: String, -- ^ Name of the .hcr output file verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] optLevel :: Int, -- ^ Optimisation level simplPhases :: Int, -- ^ Number of simplifier phases @@ -613,6 +622,14 @@ data DynFlags = DynFlags { dynObjectSuf :: String, dynHiSuf :: String, + -- Packages.isDllName needs to know whether a call is within a + -- single DLL or not. Normally it does this by seeing if the call + -- is to the same package, but for the ghc package, we split the + -- package between 2 DLLs. The dllSplit tells us which sets of + -- modules are in which package. + dllSplitFile :: Maybe FilePath, + dllSplit :: Maybe [Set String], + outputFile :: Maybe String, dynOutputFile :: Maybe String, outputHi :: Maybe String, @@ -626,7 +643,7 @@ data DynFlags = DynFlags { -- Set by @-ddump-file-prefix@ dumpPrefixForce :: Maybe FilePath, - ldInputs :: [String], + ldInputs :: [Option], includePaths :: [String], libraryPaths :: [String], @@ -735,7 +752,10 @@ data DynFlags = DynFlags { nextWrapperNum :: IORef Int, -- | Machine dependant flags (-m<blah> stuff) - sseVersion :: Maybe (Int, Int) -- (major, minor) + sseVersion :: Maybe (Int, Int), -- (major, minor) + + -- | Run-time linker information (what options we need, etc.) + rtldFlags :: IORef (Maybe LinkerInfo) } class HasDynFlags m where @@ -869,11 +889,6 @@ opt_lc dflags = sOpt_lc (settings dflags) -- 'HscNothing' can be used to avoid generating any output, however, note -- that: -- --- * This will not run the desugaring step, thus no warnings generated in --- this step will be output. In particular, this includes warnings related --- to pattern matching. You can run the desugarer manually using --- 'GHC.desugarModule'. --- -- * If a program uses Template Haskell the typechecker may try to run code -- from an imported module. This will fail if no code has been generated -- for this module. You can use 'GHC.needsTemplateHaskell' to detect @@ -1167,27 +1182,35 @@ generateDynamicTooConditional dflags canGen cannotGen notTryingToGen if b then canGen else cannotGen else notTryingToGen -doDynamicToo :: DynFlags -> DynFlags -doDynamicToo dflags0 = let dflags1 = addWay' WayDyn dflags0 - dflags2 = dflags1 { - outputFile = dynOutputFile dflags1, - hiSuf = dynHiSuf dflags1, - objectSuf = dynObjectSuf dflags1 - } - dflags3 = updateWays dflags2 - in dflags3 +dynamicTooMkDynamicDynFlags :: DynFlags -> DynFlags +dynamicTooMkDynamicDynFlags dflags0 + = let dflags1 = addWay' WayDyn dflags0 + dflags2 = dflags1 { + outputFile = dynOutputFile dflags1, + hiSuf = dynHiSuf dflags1, + objectSuf = dynObjectSuf dflags1 + } + dflags3 = updateWays dflags2 + dflags4 = gopt_unset dflags3 Opt_BuildDynamicToo + in dflags4 ----------------------------------------------------------------------------- -- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value initDynFlags :: DynFlags -> IO DynFlags initDynFlags dflags = do - refCanGenerateDynamicToo <- newIORef True + let -- We can't build with dynamic-too on Windows, as labels before + -- the fork point are different depending on whether we are + -- building dynamically or not. + platformCanGenerateDynamicToo + = platformOS (targetPlatform dflags) /= OSMinGW32 + refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo refFilesToClean <- newIORef [] refDirsToClean <- newIORef Map.empty refFilesToNotIntermediateClean <- newIORef [] refGeneratedDumps <- newIORef Set.empty refLlvmVersion <- newIORef 28 + refRtldFlags <- newIORef Nothing wrapperNum <- newIORef 0 canUseUnicodeQuotes <- do let enc = localeEncoding str = "‛’" @@ -1203,7 +1226,8 @@ initDynFlags dflags = do generatedDumps = refGeneratedDumps, llvmVersion = refLlvmVersion, nextWrapperNum = wrapperNum, - useUnicodeQuotes = canUseUnicodeQuotes + useUnicodeQuotes = canUseUnicodeQuotes, + rtldFlags = refRtldFlags } -- | The normal 'DynFlags'. Note that they is not suitable for use in this form @@ -1214,8 +1238,6 @@ defaultDynFlags mySettings = ghcMode = CompManager, ghcLink = LinkBinary, hscTarget = defaultHscTarget (sTargetPlatform mySettings), - hscOutName = "", - extCoreName = "", verbosity = 0, optLevel = 0, simplPhases = 2, @@ -1254,6 +1276,9 @@ defaultDynFlags mySettings = dynObjectSuf = "dyn_" ++ phaseInputExt StopLn, dynHiSuf = "dyn_hi", + dllSplitFile = Nothing, + dllSplit = Nothing, + pluginModNames = [], pluginModNameOpts = [], @@ -1336,7 +1361,8 @@ defaultDynFlags mySettings = llvmVersion = panic "defaultDynFlags: No llvmVersion", interactivePrint = Nothing, nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum", - sseVersion = Nothing + sseVersion = Nothing, + rtldFlags = panic "defaultDynFlags: no rtldFlags" } defaultWays :: Settings -> [Way] @@ -1360,17 +1386,20 @@ defaultFatalMessager = hPutStrLn stderr defaultLogAction :: LogAction defaultLogAction dflags severity srcSpan style msg = case severity of - SevOutput -> printSDoc msg style - SevDump -> printSDoc (msg $$ blankLine) style - SevInfo -> printErrs msg style - SevFatal -> printErrs msg style - _ -> do hPutChar stderr '\n' - printErrs (mkLocMessage severity srcSpan msg) style - -- careful (#2302): printErrs prints in UTF-8, whereas - -- converting to string first and using hPutStr would - -- just emit the low 8 bits of each unicode char. - where printSDoc = defaultLogActionHPrintDoc dflags stdout - printErrs = defaultLogActionHPrintDoc dflags stderr + SevOutput -> printSDoc msg style + SevDump -> printSDoc (msg $$ blankLine) style + SevInteractive -> putStrSDoc msg style + SevInfo -> printErrs msg style + SevFatal -> printErrs msg style + _ -> do hPutChar stderr '\n' + printErrs (mkLocMessage severity srcSpan msg) style + -- careful (#2302): printErrs prints in UTF-8, + -- whereas converting to string first and using + -- hPutStr would just emit the low 8 bits of + -- each unicode char. + where printSDoc = defaultLogActionHPrintDoc dflags stdout + printErrs = defaultLogActionHPrintDoc dflags stderr + putStrSDoc = defaultLogActionHPutStrDoc dflags stdout defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () defaultLogActionHPrintDoc dflags h d sty @@ -1378,6 +1407,12 @@ defaultLogActionHPrintDoc dflags h d sty Pretty.printDoc Pretty.PageMode (pprCols dflags) h doc hFlush h +defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () +defaultLogActionHPutStrDoc dflags h d sty + = do let doc = runSDoc d (initSDocContext dflags sty) + hPutStr h (Pretty.render doc) + hFlush h + newtype FlushOut = FlushOut (IO ()) defaultFlushOut :: FlushOut @@ -1853,9 +1888,23 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do let (dflags4, consistency_warnings) = makeDynFlagsConsistent dflags3 - liftIO $ setUnsafeGlobalDynFlags dflags4 + dflags5 <- case dllSplitFile dflags4 of + Nothing -> return (dflags4 { dllSplit = Nothing }) + Just f -> + case dllSplit dflags4 of + Just _ -> + -- If dllSplit is out of date then it would have + -- been set to Nothing. As it's a Just, it must be + -- up-to-date. + return dflags4 + Nothing -> + do xs <- liftIO $ readFile f + let ss = map (Set.fromList . words) (lines xs) + return $ dflags4 { dllSplit = Just ss } + + liftIO $ setUnsafeGlobalDynFlags dflags5 - return (dflags4, leftover, consistency_warnings ++ sh_warns ++ warns) + return (dflags5, leftover, consistency_warnings ++ sh_warns ++ warns) updateWays :: DynFlags -> DynFlags updateWays dflags @@ -2034,10 +2083,12 @@ dynamic_flags = [ , Flag "shared" (noArg (\d -> d{ ghcLink=LinkDynLib })) , Flag "dynload" (hasArg parseDynLibLoaderMode) , Flag "dylib-install-name" (hasArg setDylibInstallName) + -- -dll-split is an internal flag, used only during the GHC build + , Flag "dll-split" (hasArg (\f d -> d{ dllSplitFile = Just f, dllSplit = Nothing })) ------- Libraries --------------------------------------------------- , Flag "L" (Prefix addLibraryPath) - , Flag "l" (hasArg (addOptl . ("-l" ++))) + , Flag "l" (hasArg (addLdInputs . Option . ("-l" ++))) ------- Frameworks -------------------------------------------------- -- -framework-path should really be -F ... @@ -2389,6 +2440,8 @@ fWarningFlags = [ ( "warn-dodgy-foreign-imports", Opt_WarnDodgyForeignImports, nop ), ( "warn-dodgy-exports", Opt_WarnDodgyExports, nop ), ( "warn-dodgy-imports", Opt_WarnDodgyImports, nop ), + ( "warn-overflowed-literals", Opt_WarnOverflowedLiterals, nop ), + ( "warn-empty-enumerations", Opt_WarnEmptyEnumerations, nop ), ( "warn-duplicate-exports", Opt_WarnDuplicateExports, nop ), ( "warn-duplicate-constraints", Opt_WarnDuplicateConstraints, nop ), ( "warn-hi-shadowing", Opt_WarnHiShadows, nop ), @@ -2508,7 +2561,10 @@ fFlags = [ ( "prof-cafs", Opt_AutoSccsOnIndividualCafs, nop ), ( "hpc", Opt_Hpc, nop ), ( "pre-inlining", Opt_SimplPreInlining, nop ), - ( "use-rpaths", Opt_RPath, nop ) + ( "flat-cache", Opt_FlatCache, nop ), + ( "use-rpaths", Opt_RPath, nop ), + ( "kill-absence", Opt_KillAbsence, nop), + ( "kill-one-shot", Opt_KillOneShot, nop) ] -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ @@ -2587,6 +2643,7 @@ xFlags = [ ( "MagicHash", Opt_MagicHash, nop ), ( "ExistentialQuantification", Opt_ExistentialQuantification, nop ), ( "KindSignatures", Opt_KindSignatures, nop ), + ( "RoleAnnotations", Opt_RoleAnnotations, nop ), ( "EmptyDataDecls", Opt_EmptyDataDecls, nop ), ( "ParallelListComp", Opt_ParallelListComp, nop ), ( "TransformListComp", Opt_TransformListComp, nop ), @@ -2679,6 +2736,7 @@ xFlags = [ ( "IncoherentInstances", Opt_IncoherentInstances, nop ), ( "PackageImports", Opt_PackageImports, nop ), ( "TypeHoles", Opt_TypeHoles, nop ), + ( "NegativeLiterals", Opt_NegativeLiterals, nop ), ( "EmptyCase", Opt_EmptyCase, nop ) ] @@ -2698,6 +2756,7 @@ defaultFlags settings Opt_HelpfulErrors, Opt_ProfCountEntries, Opt_SimplPreInlining, + Opt_FlatCache, Opt_RPath ] @@ -2775,6 +2834,7 @@ optLevelFlags , ([1,2], Opt_FullLaziness) , ([1,2], Opt_Specialise) , ([1,2], Opt_FloatIn) + , ([1,2], Opt_UnboxSmallStrictFields) , ([2], Opt_LiberateCase) , ([2], Opt_SpecConstr) @@ -2808,24 +2868,25 @@ optLevelFlags standardWarnings :: [WarningFlag] standardWarnings - = [ Opt_WarnWarningsDeprecations, + = [ Opt_WarnOverlappingPatterns, + Opt_WarnWarningsDeprecations, Opt_WarnDeprecatedFlags, Opt_WarnUnrecognisedPragmas, - Opt_WarnOverlappingPatterns, + Opt_WarnPointlessPragmas, + Opt_WarnDuplicateConstraints, + Opt_WarnDuplicateExports, + Opt_WarnOverflowedLiterals, + Opt_WarnEmptyEnumerations, Opt_WarnMissingFields, Opt_WarnMissingMethods, - Opt_WarnDuplicateExports, Opt_WarnLazyUnliftedBindings, - Opt_WarnDodgyForeignImports, Opt_WarnWrongDoBind, - Opt_WarnAlternativeLayoutRuleTransitional, - Opt_WarnPointlessPragmas, Opt_WarnUnsupportedCallingConventions, - Opt_WarnUnsupportedLlvmVersion, - Opt_WarnInlineRuleShadowing, - Opt_WarnDuplicateConstraints, + Opt_WarnDodgyForeignImports, + Opt_WarnTypeableInstances, Opt_WarnInlineRuleShadowing, - Opt_WarnTypeableInstances + Opt_WarnAlternativeLayoutRuleTransitional, + Opt_WarnUnsupportedLlvmVersion ] minusWOpts :: [WarningFlag] @@ -3184,6 +3245,9 @@ setMainIs arg where (main_mod, main_fn) = splitLongestPrefix arg (== '.') +addLdInputs :: Option -> DynFlags -> DynFlags +addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]} + ----------------------------------------------------------------------------- -- Paths & Libraries @@ -3359,6 +3423,7 @@ compilerInfo dflags ("Support SMP", cGhcWithSMP), ("Tables next to code", cGhcEnableTablesNextToCode), ("RTS ways", cGhcRTSWays), + ("Support dynamic-too", "YES"), ("Dynamic by default", if dYNAMIC_BY_DEFAULT dflags then "YES" else "NO"), ("GHC Dynamic", if cDYNAMIC_GHC_PROGRAMS @@ -3415,7 +3480,7 @@ makeDynFlagsConsistent dflags else let dflags' = dflags { hscTarget = HscLlvm } warn = "Compiler not unregisterised, so using LLVM rather than compiling via C" in loop dflags' warn - | hscTarget dflags /= HscC && hscTarget dflags /= HscLlvm && + | hscTarget dflags == HscAsm && platformUnregisterised (targetPlatform dflags) = loop (dflags { hscTarget = HscC }) "Compiler unregisterised, so compiling via C" @@ -3484,3 +3549,14 @@ isSse2Enabled dflags = case platformArch (targetPlatform dflags) of isSse4_2Enabled :: DynFlags -> Bool isSse4_2Enabled dflags = sseVersion dflags >= Just (4,2) + +-- ----------------------------------------------------------------------------- +-- Linker information + +-- LinkerInfo contains any extra options needed by the system linker. +data LinkerInfo + = GnuLD [Option] + | GnuGold [Option] + | DarwinLD [Option] + | UnknownLD + deriving Eq diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 3fd92ed473..f9f4387120 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -78,6 +78,7 @@ type MsgDoc = SDoc data Severity = SevOutput | SevDump + | SevInteractive | SevInfo | SevWarning | SevError diff --git a/compiler/main/ErrUtils.lhs-boot b/compiler/main/ErrUtils.lhs-boot index 6f4a373313..fc99c5afde 100644 --- a/compiler/main/ErrUtils.lhs-boot +++ b/compiler/main/ErrUtils.lhs-boot @@ -7,6 +7,7 @@ import SrcLoc (SrcSpan) data Severity = SevOutput | SevDump + | SevInteractive | SevInfo | SevWarning | SevError diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index c72f1f1be6..39e1e0a453 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -157,7 +157,7 @@ module GHC ( TyCon, tyConTyVars, tyConDataCons, tyConArity, isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, - isFamilyTyCon, tyConClass_maybe, + isFamilyTyCon, isOpenFamilyTyCon, tyConClass_maybe, synTyConRhs_maybe, synTyConDefn_maybe, synTyConResKind, -- ** Type variables @@ -182,7 +182,7 @@ module GHC ( pprInstance, pprInstanceHdr, pprFamInst, - FamInst, Branched, + FamInst, -- ** Types and Kinds Type, splitForAllTys, funResultTy, @@ -892,8 +892,10 @@ compileToCoreSimplified = compileCore True -- The resulting .o, .hi, and executable files, if any, are stored in the -- current directory, and named according to the module name. -- This has only so far been tested with a single self-contained module. -compileCoreToObj :: GhcMonad m => Bool -> CoreModule -> m () -compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do +compileCoreToObj :: GhcMonad m + => Bool -> CoreModule -> FilePath -> FilePath -> m () +compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) + output_fn extCore_filename = do dflags <- getSessionDynFlags currentTime <- liftIO $ getCurrentTime cwd <- liftIO $ getCurrentDirectory @@ -919,7 +921,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do } hsc_env <- getSession - liftIO $ hscCompileCore hsc_env simplify (cm_safe cm) modSum (cm_binds cm) + liftIO $ hscCompileCore hsc_env simplify (cm_safe cm) modSum (cm_binds cm) output_fn extCore_filename compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule @@ -1002,7 +1004,7 @@ getBindings = withSession $ \hsc_env -> return $ icInScopeTTs $ hsc_IC hsc_env -- | Return the instances for the current interactive session. -getInsts :: GhcMonad m => m ([ClsInst], [FamInst Branched]) +getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) getInsts = withSession $ \hsc_env -> return $ ic_instances (hsc_IC hsc_env) diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 4970b6725e..c43b18a62a 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -332,8 +332,7 @@ load how_much = do liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1 -- there should be no Nothings where linkables should be, now - ASSERT(all (isJust.hm_linkable) - (eltsUFM (hsc_HPT hsc_env))) do + ASSERT(all (isJust.hm_linkable) (eltsUFM (hsc_HPT hsc_env))) do -- Link everything together linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index f7ae35ff55..2560db37f8 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -8,13 +8,6 @@ -- ----------------------------------------------------------------------------- -{-# 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 HeaderInfo ( getImports , mkPrelImports -- used by the renamer too , getOptionsFromFile, getOptions @@ -25,7 +18,7 @@ module HeaderInfo ( getImports import RdrName import HscTypes -import Parser ( parseHeader ) +import Parser ( parseHeader ) import Lexer import FastString import HsSyn @@ -39,7 +32,7 @@ import Util import Outputable import Pretty () import Maybes -import Bag ( emptyBag, listToBag, unitBag ) +import Bag ( emptyBag, listToBag, unitBag ) import MonadUtils import Exception @@ -74,23 +67,23 @@ getImports dflags buf filename source_filename = do if errorsFound dflags ms then throwIO $ mkSrcErr errs else - case rdr_module of - L _ (HsModule mb_mod _ imps _ _ _) -> - let + case rdr_module of + L _ (HsModule mb_mod _ imps _ _ _) -> + let main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) 1 1) - mod = mb_mod `orElse` L main_loc mAIN_NAME - (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps + mod = mb_mod `orElse` L main_loc mAIN_NAME + (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps - -- GHC.Prim doesn't exist physically, so don't go looking for it. - ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) - ord_idecls + -- GHC.Prim doesn't exist physically, so don't go looking for it. + ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) + ord_idecls implicit_prelude = xopt Opt_ImplicitPrelude dflags implicit_imports = mkPrelImports (unLoc mod) main_loc implicit_prelude imps - in - return (src_idecls, implicit_imports ++ ordinary_imps, mod) + in + return (src_idecls, implicit_imports ++ ordinary_imps, mod) -mkPrelImports :: ModuleName +mkPrelImports :: ModuleName -> SrcSpan -- Attribute the "import Prelude" to this location -> Bool -> [LImportDecl RdrName] -> [LImportDecl RdrName] @@ -108,20 +101,20 @@ mkPrelImports this_mod loc implicit_prelude import_decls where explicit_prelude_import = notNull [ () | L _ (ImportDecl { ideclName = mod - , ideclPkgQual = Nothing }) + , ideclPkgQual = Nothing }) <- import_decls - , unLoc mod == pRELUDE_NAME ] + , unLoc mod == pRELUDE_NAME ] preludeImportDecl :: LImportDecl RdrName preludeImportDecl = L loc $ ImportDecl { ideclName = L loc pRELUDE_NAME, - ideclPkgQual = Nothing, - ideclSource = False, - ideclSafe = False, -- Not a safe import - ideclQualified = False, - ideclImplicit = True, -- Implicit! - ideclAs = Nothing, - ideclHiding = Nothing } + ideclPkgQual = Nothing, + ideclSource = False, + ideclSafe = False, -- Not a safe import + ideclQualified = False, + ideclImplicit = True, -- Implicit! + ideclAs = Nothing, + ideclHiding = Nothing } parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err @@ -138,7 +131,7 @@ getOptionsFromFile :: DynFlags -> IO [Located String] -- ^ Parsed options, if any. getOptionsFromFile dflags filename = Exception.bracket - (openBinaryFile filename ReadMode) + (openBinaryFile filename ReadMode) (hClose) (\handle -> do opts <- fmap (getOptions' dflags) @@ -226,7 +219,7 @@ getOptions' :: DynFlags -> [Located String] -- Options. getOptions' dflags toks = parseToks toks - where + where getToken (L _loc tok) = tok getLoc (L loc _tok) = loc @@ -313,9 +306,9 @@ unsupportedExtnError dflags loc unsup = optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages optionsErrorMsgs dflags unhandled_flags flags_lines _filename = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) - where unhandled_flags_lines = [ L l f | f <- unhandled_flags, - L l f' <- flags_lines, f == f' ] - mkMsg (L flagSpan flag) = + where unhandled_flags_lines = [ L l f | f <- unhandled_flags, + L l f' <- flags_lines, f == f' ] + mkMsg (L flagSpan flag) = ErrUtils.mkPlainErrMsg dflags flagSpan $ text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index c97e3ec724..e884fe5bcf 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -303,7 +303,7 @@ hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do -- "name not found", and the Maybe in the return type -- is used to indicate that. -hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst Branched])) +hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst])) hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv ioMsgMaybe' $ tcRnGetInfo hsc_env name @@ -616,10 +616,11 @@ genericHscFrontend mod_summary -- Compile Haskell, boot and extCore in OneShot mode. hscCompileOneShot :: HscEnv + -> FilePath -> ModSummary -> SourceModified -> IO HscStatus -hscCompileOneShot hsc_env mod_summary src_changed +hscCompileOneShot hsc_env extCore_filename mod_summary src_changed = do -- One-shot mode needs a knot-tying mutable variable for interface -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var. @@ -636,6 +637,7 @@ hscCompileOneShot hsc_env mod_summary src_changed compile mb_old_hash reason = runHsc hsc_env' $ do liftIO $ msg reason tc_result <- genericHscFrontend mod_summary + guts0 <- hscDesugar' (ms_location mod_summary) tc_result dflags <- getDynFlags case hscTarget dflags of HscNothing -> return HscNotGeneratingCode @@ -646,9 +648,8 @@ hscCompileOneShot hsc_env mod_summary src_changed liftIO $ hscWriteIface dflags iface changed mod_summary return HscUpdateBoot _ -> - do guts0 <- hscDesugar' (ms_location mod_summary) tc_result - guts <- hscSimplify' guts0 - (iface, changed, _details, cgguts) <- hscNormalIface' guts mb_old_hash + do guts <- hscSimplify' guts0 + (iface, changed, _details, cgguts) <- hscNormalIface' extCore_filename guts mb_old_hash liftIO $ hscWriteIface dflags iface changed mod_summary return $ HscRecomp cgguts mod_summary @@ -1082,16 +1083,18 @@ hscSimpleIface' tc_result mb_old_iface = do return (new_iface, no_change, details) hscNormalIface :: HscEnv + -> FilePath -> ModGuts -> Maybe Fingerprint -> IO (ModIface, Bool, ModDetails, CgGuts) -hscNormalIface hsc_env simpl_result mb_old_iface = - runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface +hscNormalIface hsc_env extCore_filename simpl_result mb_old_iface = + runHsc hsc_env $ hscNormalIface' extCore_filename simpl_result mb_old_iface -hscNormalIface' :: ModGuts +hscNormalIface' :: FilePath + -> ModGuts -> Maybe Fingerprint -> Hsc (ModIface, Bool, ModDetails, CgGuts) -hscNormalIface' simpl_result mb_old_iface = do +hscNormalIface' extCore_filename simpl_result mb_old_iface = do hsc_env <- getHscEnv (cg_guts, details) <- {-# SCC "CoreTidy" #-} liftIO $ tidyProgram hsc_env simpl_result @@ -1110,7 +1113,7 @@ hscNormalIface' simpl_result mb_old_iface = do -- This should definitely be here and not after CorePrep, -- because CorePrep produces unqualified constructor wrapper declarations, -- so its output isn't valid External Core (without some preprocessing). - liftIO $ emitExternalCore (hsc_dflags hsc_env) cg_guts + liftIO $ emitExternalCore (hsc_dflags hsc_env) extCore_filename cg_guts liftIO $ dumpIfaceStats hsc_env -- Return the prepared code. @@ -1132,13 +1135,13 @@ hscWriteIface dflags iface no_change mod_summary = do -- TODO: Should handle the dynamic hi filename properly let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags) dynIfaceFile' = addBootSuffix_maybe (mi_boot iface) dynIfaceFile - dynDflags = doDynamicToo dflags + dynDflags = dynamicTooMkDynamicDynFlags dflags writeIfaceFile dynDflags dynIfaceFile' iface -- | Compile to hard-code. -hscGenHardCode :: HscEnv -> CgGuts -> ModSummary +hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath -> IO (FilePath, Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f -hscGenHardCode hsc_env cgguts mod_summary = do +hscGenHardCode hsc_env cgguts mod_summary output_filename = do let CgGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. cg_module = this_mod, @@ -1184,8 +1187,8 @@ hscGenHardCode hsc_env cgguts mod_summary = do (output_filename, (_stub_h_exists, stub_c_exists)) <- {-# SCC "codeOutput" #-} - codeOutput dflags this_mod location foreign_stubs - dependencies rawcmms1 + codeOutput dflags this_mod output_filename location + foreign_stubs dependencies rawcmms1 return (output_filename, stub_c_exists) @@ -1226,8 +1229,8 @@ hscInteractive _ _ = panic "GHC not compiled with interpreter" ------------------------------ -hscCompileCmmFile :: HscEnv -> FilePath -> IO () -hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do +hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO () +hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env cmm <- ioMsgMaybe $ parseCmmFile dflags filename liftIO $ do @@ -1236,7 +1239,7 @@ hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do dumpIfSet_dyn dflags Opt_D_dump_cmm "Parsed Cmm" (ppr cmm) (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup) - _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms + _ <- codeOutput dflags no_mod output_filename no_loc NoStubs [] rawCmms return () where no_mod = panic "hscCmmFile: no_mod" @@ -1321,7 +1324,7 @@ myCoreToStg :: DynFlags -> Module -> CoreProgram myCoreToStg dflags this_mod prepd_binds = do stg_binds <- {-# SCC "Core2Stg" #-} - coreToStg dflags prepd_binds + coreToStg dflags this_mod prepd_binds (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-} @@ -1556,13 +1559,13 @@ hscParseThingWithLocation source linenumber parser str return thing hscCompileCore :: HscEnv -> Bool -> SafeHaskellMode -> ModSummary - -> CoreProgram -> IO () -hscCompileCore hsc_env simplify safe_mode mod_summary binds + -> CoreProgram -> FilePath -> FilePath -> IO () +hscCompileCore hsc_env simplify safe_mode mod_summary binds output_filename extCore_filename = runHsc hsc_env $ do guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) safe_mode binds) - (iface, changed, _details, cgguts) <- hscNormalIface' guts Nothing + (iface, changed, _details, cgguts) <- hscNormalIface' extCore_filename guts Nothing liftIO $ hscWriteIface (hsc_dflags hsc_env) iface changed mod_summary - _ <- liftIO $ hscGenHardCode hsc_env cgguts mod_summary + _ <- liftIO $ hscGenHardCode hsc_env cgguts mod_summary output_filename return () where diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index d9fe88bb80..e022ae3eae 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -37,7 +37,7 @@ module HscTypes ( PackageInstEnv, PackageRuleBase, - mkSOName, soExt, + mkSOName, mkHsSOName, soExt, -- * Annotations prepareAnnotations, @@ -159,6 +159,7 @@ import StringBuffer ( StringBuffer ) import Fingerprint import MonadUtils import Bag +import Binary import ErrUtils import Platform import Util @@ -456,7 +457,7 @@ lookupIfaceByModule dflags hpt pit mod -- modules imported by this one, directly or indirectly, and are in the Home -- Package Table. This ensures that we don't see instances from modules @--make@ -- compiled before this one, but which are not below this one. -hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst Branched]) +hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst]) hptInstances hsc_env want_this_module = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do guard (want_this_module (moduleName (mi_module (hm_iface mod_info)))) @@ -717,6 +718,113 @@ data ModIface -- See Note [RnNames . Trust Own Package] } +instance Binary ModIface where + put_ bh (ModIface { + mi_module = mod, + mi_boot = is_boot, + mi_iface_hash= iface_hash, + mi_mod_hash = mod_hash, + mi_flag_hash = flag_hash, + mi_orphan = orphan, + mi_finsts = hasFamInsts, + mi_deps = deps, + mi_usages = usages, + mi_exports = exports, + mi_exp_hash = exp_hash, + mi_used_th = used_th, + mi_fixities = fixities, + mi_warns = warns, + mi_anns = anns, + mi_decls = decls, + mi_insts = insts, + mi_fam_insts = fam_insts, + mi_rules = rules, + mi_orphan_hash = orphan_hash, + mi_vect_info = vect_info, + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg }) = do + put_ bh mod + put_ bh is_boot + put_ bh iface_hash + put_ bh mod_hash + put_ bh flag_hash + put_ bh orphan + put_ bh hasFamInsts + lazyPut bh deps + lazyPut bh usages + put_ bh exports + put_ bh exp_hash + put_ bh used_th + put_ bh fixities + lazyPut bh warns + lazyPut bh anns + put_ bh decls + put_ bh insts + put_ bh fam_insts + lazyPut bh rules + put_ bh orphan_hash + put_ bh vect_info + put_ bh hpc_info + put_ bh trust + put_ bh trust_pkg + + get bh = do + mod_name <- get bh + is_boot <- get bh + iface_hash <- get bh + mod_hash <- get bh + flag_hash <- get bh + orphan <- get bh + hasFamInsts <- get bh + deps <- lazyGet bh + usages <- {-# SCC "bin_usages" #-} lazyGet bh + exports <- {-# SCC "bin_exports" #-} get bh + exp_hash <- get bh + used_th <- get bh + fixities <- {-# SCC "bin_fixities" #-} get bh + warns <- {-# SCC "bin_warns" #-} lazyGet bh + anns <- {-# SCC "bin_anns" #-} lazyGet bh + decls <- {-# SCC "bin_tycldecls" #-} get bh + insts <- {-# SCC "bin_insts" #-} get bh + fam_insts <- {-# SCC "bin_fam_insts" #-} get bh + rules <- {-# SCC "bin_rules" #-} lazyGet bh + orphan_hash <- get bh + vect_info <- get bh + hpc_info <- get bh + trust <- get bh + trust_pkg <- get bh + return (ModIface { + mi_module = mod_name, + mi_boot = is_boot, + mi_iface_hash = iface_hash, + mi_mod_hash = mod_hash, + mi_flag_hash = flag_hash, + mi_orphan = orphan, + mi_finsts = hasFamInsts, + mi_deps = deps, + mi_usages = usages, + mi_exports = exports, + mi_exp_hash = exp_hash, + mi_used_th = used_th, + mi_anns = anns, + mi_fixities = fixities, + mi_warns = warns, + mi_decls = decls, + mi_globals = Nothing, + mi_insts = insts, + mi_fam_insts = fam_insts, + mi_rules = rules, + mi_orphan_hash = orphan_hash, + mi_vect_info = vect_info, + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg, + -- And build the cached values + mi_warn_fn = mkIfaceWarnCache warns, + mi_fix_fn = mkIfaceFixCache fixities, + mi_hash_fn = mkIfaceHashCache decls }) + -- | The original names declared of a certain module that are exported type IfaceExport = AvailInfo @@ -777,7 +885,7 @@ data ModDetails md_exports :: [AvailInfo], md_types :: !TypeEnv, -- ^ Local type environment for this particular module md_insts :: ![ClsInst], -- ^ 'DFunId's for the instances in this module - md_fam_insts :: ![FamInst Branched], + md_fam_insts :: ![FamInst], md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules md_anns :: ![Annotation], -- ^ Annotations present in this module: currently -- they only annotate things also declared in this module @@ -823,7 +931,7 @@ data ModGuts mg_tcs :: ![TyCon], -- ^ TyCons declared in this module -- (includes TyCons for classes) mg_insts :: ![ClsInst], -- ^ Class instances declared in this module - mg_fam_insts :: ![FamInst Branched], + mg_fam_insts :: ![FamInst], -- ^ Family instances declared in this module mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains -- See Note [Overall plumbing for rules] in Rules.lhs @@ -953,7 +1061,7 @@ data InteractiveContext -- ^ Variables defined automatically by the system (e.g. -- record field selectors). See Notes [ic_sys_vars] - ic_instances :: ([ClsInst], [FamInst Branched]), + ic_instances :: ([ClsInst], [FamInst]), -- ^ All instances and family instances created during -- this session. These are grabbed en masse after each -- update to be sure that proper overlapping is retained. @@ -1280,10 +1388,12 @@ implicitTyConThings tc extras_plus :: TyThing -> [TyThing] extras_plus thing = thing : implicitTyThings thing --- For newtypes (only) add the implicit coercion tycon +-- For newtypes and closed type families (only) add the implicit coercion tycon implicitCoTyCon :: TyCon -> [TyThing] implicitCoTyCon tc | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co] + | Just co <- isClosedSynFamilyTyCon_maybe tc + = [ACoAxiom co] | otherwise = [] -- | Returns @True@ if there should be no interface-file declaration @@ -1379,12 +1489,12 @@ mkTypeEnvWithImplicits things = `plusNameEnv` mkTypeEnv (concatMap implicitTyThings things) -typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst Branched] -> TypeEnv +typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv typeEnvFromEntities ids tcs famInsts = mkTypeEnv ( map AnId ids ++ map ATyCon all_tcs ++ concatMap implicitTyConThings all_tcs - ++ map (ACoAxiom . famInstAxiom) famInsts + ++ map (ACoAxiom . toBranchedAxiom . famInstAxiom) famInsts ) where all_tcs = tcs ++ famInstsRepTyCons famInsts @@ -1525,6 +1635,24 @@ data Warnings -- a Name to its fixity declaration. deriving( Eq ) +instance Binary Warnings where + put_ bh NoWarnings = putByte bh 0 + put_ bh (WarnAll t) = do + putByte bh 1 + put_ bh t + put_ bh (WarnSome ts) = do + putByte bh 2 + put_ bh ts + + get bh = do + h <- getByte bh + case h of + 0 -> return NoWarnings + 1 -> do aa <- get bh + return (WarnAll aa) + _ -> do aa <- get bh + return (WarnSome aa) + -- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface' mkIfaceWarnCache :: Warnings -> Name -> Maybe WarningTxt mkIfaceWarnCache NoWarnings = \_ -> Nothing @@ -1623,6 +1751,19 @@ data Dependencies -- Equality used only for old/new comparison in MkIface.addFingerprints -- See 'TcRnTypes.ImportAvails' for details on dependencies. +instance Binary Dependencies where + put_ bh deps = do put_ bh (dep_mods deps) + put_ bh (dep_pkgs deps) + put_ bh (dep_orphs deps) + put_ bh (dep_finsts deps) + + get bh = do ms <- get bh + ps <- get bh + os <- get bh + fis <- get bh + return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, + dep_finsts = fis }) + noDependencies :: Dependencies noDependencies = Deps [] [] [] [] @@ -1671,6 +1812,49 @@ data Usage -- import M() -- And of course, for modules that aren't imported directly we don't -- depend on their export lists + +instance Binary Usage where + put_ bh usg@UsagePackageModule{} = do + putByte bh 0 + put_ bh (usg_mod usg) + put_ bh (usg_mod_hash usg) + put_ bh (usg_safe usg) + + put_ bh usg@UsageHomeModule{} = do + putByte bh 1 + put_ bh (usg_mod_name usg) + put_ bh (usg_mod_hash usg) + put_ bh (usg_exports usg) + put_ bh (usg_entities usg) + put_ bh (usg_safe usg) + + put_ bh usg@UsageFile{} = do + putByte bh 2 + put_ bh (usg_file_path usg) + put_ bh (usg_mtime usg) + + get bh = do + h <- getByte bh + case h of + 0 -> do + nm <- get bh + mod <- get bh + safe <- get bh + return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe } + 1 -> do + nm <- get bh + mod <- get bh + exps <- get bh + ents <- get bh + safe <- get bh + return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, + usg_exports = exps, usg_entities = ents, usg_safe = safe } + 2 -> do + fp <- get bh + mtime <- get bh + return UsageFile { usg_file_path = fp, usg_mtime = mtime } + i -> error ("Binary.get(Usage): " ++ show i) + \end{code} @@ -1796,6 +1980,9 @@ mkSOName platform root OSMinGW32 -> root <.> "dll" _ -> ("lib" ++ root) <.> "so" +mkHsSOName :: Platform -> FilePath -> FilePath +mkHsSOName platform root = ("lib" ++ root) <.> soExt platform + soExt :: Platform -> FilePath soExt platform = case platformOS platform of @@ -2055,6 +2242,21 @@ instance Outputable VectInfo where , ptext (sLit "parallel vars :") <+> ppr (vectInfoParallelVars info) , ptext (sLit "parallel tycons :") <+> ppr (vectInfoParallelTyCons info) ] + +instance Binary IfaceVectInfo where + put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + return (IfaceVectInfo a1 a2 a3 a4 a5) \end{code} %************************************************************************ @@ -2106,6 +2308,10 @@ instance Outputable IfaceTrustInfo where ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy" ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe" ppr (TrustInfo Sf_SafeInferred) = ptext $ sLit "safe-inferred" + +instance Binary IfaceTrustInfo where + put_ bh iftrust = putByte bh $ trustInfoToNum iftrust + get bh = getByte bh >>= (return . numToTrustInfo) \end{code} %************************************************************************ diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 391de5a42f..635c194a92 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -45,7 +45,7 @@ import HscMain import HsSyn import HscTypes import InstEnv -import FamInstEnv ( FamInst, Branched, orphNamesOfFamInst ) +import FamInstEnv ( FamInst, orphNamesOfFamInst ) import TyCon import Type hiding( typeKind ) import TcType hiding( typeKind ) @@ -890,7 +890,7 @@ moduleIsInterpreted modl = withSession $ \h -> -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many! -- The exact choice of which ones to show, and which to hide, is a judgement call. -- (see Trac #1581) -getInfo :: GhcMonad m => Bool -> Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst Branched])) +getInfo :: GhcMonad m => Bool -> Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst])) getInfo allInfo name = withSession $ \hsc_env -> do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 54d9d1b66b..cc8dfe3eb7 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -1039,13 +1039,24 @@ missingDependencyMsg (Just parent) -- ----------------------------------------------------------------------------- -- | Will the 'Name' come from a dynamically linked library? -isDllName :: DynFlags -> PackageId -> Name -> Bool +isDllName :: DynFlags -> PackageId -> Module -> Name -> Bool -- Despite the "dll", I think this function just means that -- the synbol comes from another dynamically-linked package, -- and applies on all platforms, not just Windows -isDllName dflags this_pkg name +isDllName dflags this_pkg this_mod name | gopt Opt_Static dflags = False - | Just mod <- nameModule_maybe name = modulePackageId mod /= this_pkg + | Just mod <- nameModule_maybe name + = if modulePackageId mod /= this_pkg + then True + else case dllSplit dflags of + Nothing -> False + Just ss -> + let findMod m = let modStr = moduleNameString (moduleName m) + in case find (modStr `Set.member`) ss of + Just i -> i + Nothing -> panic ("Can't find " ++ modStr ++ "in DLL split") + in findMod mod /= findMod this_mod + | otherwise = False -- no, it is not even an external name -- ----------------------------------------------------------------------------- diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index c14b853145..b95c69902a 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -29,9 +29,11 @@ import GHC ( TyThing(..) ) import DataCon import Id import TyCon -import Coercion( pprCoAxiom ) +import Coercion( pprCoAxiom, pprCoAxBranch ) +import CoAxiom( CoAxiom(..), brListMap ) import HscTypes( tyThingParent_maybe ) import Type( tidyTopType, tidyOpenType ) +import TypeRep( pprTvBndrs ) import TcType import Name import VarEnv( emptyTidyEnv ) @@ -106,6 +108,7 @@ ppr_ty_thing pefas _ (AnId id) = pprId pefas id ppr_ty_thing pefas _ (ADataCon dataCon) = pprDataConSig pefas dataCon ppr_ty_thing pefas ss (ATyCon tyCon) = pprTyCon pefas ss tyCon ppr_ty_thing _ _ (ACoAxiom ax) = pprCoAxiom ax + pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc pprTyConHdr pefas tyCon | Just (fam_tc, tys) <- tyConFamInst_maybe tyCon @@ -113,7 +116,7 @@ pprTyConHdr pefas tyCon | Just cls <- tyConClass_maybe tyCon = pprClassHdr pefas cls | otherwise - = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars) + = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> pprTvBndrs vars where vars | GHC.isPrimTyCon tyCon || GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars @@ -138,10 +141,9 @@ pprDataConSig pefas dataCon pprClassHdr :: PrintExplicitForalls -> GHC.Class -> SDoc pprClassHdr _ cls = ptext (sLit "class") <+> - GHC.pprThetaArrowTy (GHC.classSCTheta cls) <+> - ppr_bndr cls <+> - hsep (map ppr tyVars) <+> - GHC.pprFundeps funDeps + sep [ GHC.pprThetaArrowTy (GHC.classSCTheta cls) + , ppr_bndr cls <+> pprTvBndrs tyVars + , GHC.pprFundeps funDeps ] where (tyVars, funDeps) = GHC.classTvsFds cls @@ -174,16 +176,25 @@ pprTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc pprTyCon pefas ss tyCon | Just syn_rhs <- GHC.synTyConRhs_maybe tyCon = case syn_rhs of - SynFamilyTyCon {} -> pprTyConHdr pefas tyCon <+> dcolon <+> - pprTypeForUser pefas (GHC.synTyConResKind tyCon) + OpenSynFamilyTyCon -> pprTyConHdr pefas tyCon <+> dcolon <+> + pprTypeForUser pefas (GHC.synTyConResKind tyCon) + ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) -> + hang closed_family_header + 2 (vcat (brListMap (pprCoAxBranch tyCon) branches)) + AbstractClosedSynFamilyTyCon -> closed_family_header <+> ptext (sLit "..") SynonymTyCon rhs_ty -> hang (pprTyConHdr pefas tyCon <+> equals) - 2 (pprTypeForUser pefas rhs_ty) - + 2 (ppr rhs_ty) -- Don't suppress foralls on RHS type! + -- e.g. type T = forall a. a->a | Just cls <- GHC.tyConClass_maybe tyCon = pprClass pefas ss cls | otherwise = pprAlgTyCon pefas ss tyCon + where + closed_family_header + = pprTyConHdr pefas tyCon <+> dcolon <+> + pprTypeForUser pefas (GHC.synTyConResKind tyCon) <+> ptext (sLit "where") + pprAlgTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc pprAlgTyCon pefas ss tyCon | gadt = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$ @@ -228,7 +239,7 @@ pprDataConDecl pefas ss gadt_style dataCon user_ify bang = bang maybe_show_label (lbl,bty) - | showSub ss lbl = Just (ppr lbl <+> dcolon <+> pprBangTy bty) + | showSub ss lbl = Just (ppr_bndr lbl <+> dcolon <+> pprBangTy bty) | otherwise = Nothing ppr_fields [ty1, ty2] diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index c982d14b33..09d5772637 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -1,10 +1,3 @@ -{-# 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 - {-# OPTIONS -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly @@ -23,27 +16,29 @@ module StaticFlags ( -- entry point parseStaticFlags, - staticFlags, + staticFlags, initStaticOpts, - -- Output style options - opt_PprStyle_Debug, + -- Output style options + opt_PprStyle_Debug, opt_NoDebugOutput, - -- language opts - opt_DictsStrict, + -- language opts + opt_DictsStrict, - -- optimisation opts - opt_NoStateHack, - opt_CprOff, - opt_NoOptCoercion, - opt_NoFlatCache, + -- optimisation opts + opt_NoStateHack, + opt_CprOff, + opt_NoOptCoercion, -- For the parser addOpt, removeOpt, v_opt_C_ready, -- Saving/restoring globals - saveStaticFlagGlobals, restoreStaticFlagGlobals + saveStaticFlagGlobals, restoreStaticFlagGlobals, + + -- For options autocompletion + flagsStatic, flagsStaticNames ) where #include "HsVersions.h" @@ -52,13 +47,13 @@ import CmdLineParser import FastString import SrcLoc import Util --- import Maybes ( firstJusts ) +-- import Maybes ( firstJusts ) import Panic import Control.Monad import Data.Char import Data.IORef -import System.IO.Unsafe ( unsafePerformIO ) +import System.IO.Unsafe ( unsafePerformIO ) ----------------------------------------------------------------------------- @@ -114,7 +109,7 @@ staticFlags = unsafePerformIO $ do -- All the static flags should appear in this list. It describes how each -- static flag should be processed. Two main purposes: -- (a) if a command-line flag doesn't appear in the list, GHC can complain --- (b) a command-line flag may remove, or add, other flags; e.g. the "-fno-X" +-- (b) a command-line flag may remove, or add, other flags; e.g. the "-fno-X" -- things -- -- The common (PassFlag addOpt) action puts the static flag into the bunch of @@ -147,18 +142,16 @@ flagsStatic = [ ] + isStaticFlag :: String -> Bool -isStaticFlag f = - f `elem` [ +isStaticFlag f = f `elem` flagsStaticNames + + +flagsStaticNames :: [String] +flagsStaticNames = [ "fdicts-strict", - "fspec-inline-join-points", - "fno-hi-version-check", - "dno-black-holing", "fno-state-hack", - "fruntime-types", "fno-opt-coercion", - "fno-flat-cache", - "fhardwire-lib-paths", "fcpr-off" ] @@ -198,10 +191,10 @@ opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output") -- language opts opt_DictsStrict :: Bool -opt_DictsStrict = lookUp (fsLit "-fdicts-strict") +opt_DictsStrict = lookUp (fsLit "-fdicts-strict") opt_NoStateHack :: Bool -opt_NoStateHack = lookUp (fsLit "-fno-state-hack") +opt_NoStateHack = lookUp (fsLit "-fno-state-hack") -- Switch off CPR analysis in the new demand analyser opt_CprOff :: Bool @@ -210,9 +203,6 @@ opt_CprOff = lookUp (fsLit "-fcpr-off") opt_NoOptCoercion :: Bool opt_NoOptCoercion = lookUp (fsLit "-fno-opt-coercion") -opt_NoFlatCache :: Bool -opt_NoFlatCache = lookUp (fsLit "-fno-flat-cache") - ----------------------------------------------------------------------------- -- Convert sizes like "3.5M" into integers @@ -254,45 +244,28 @@ foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO () lookup_str :: String -> Maybe String lookup_str sw = case firstJusts (map (stripPrefix sw) staticFlags) of - Just ('=' : str) -> Just str - Just str -> Just str - Nothing -> Nothing + Just ('=' : str) -> Just str + Just str -> Just str + Nothing -> Nothing lookup_def_int :: String -> Int -> Int lookup_def_int sw def = case (lookup_str sw) of - Nothing -> def -- Use default - Just xx -> try_read sw xx + Nothing -> def -- Use default + Just xx -> try_read sw xx lookup_def_float :: String -> Float -> Float lookup_def_float sw def = case (lookup_str sw) of - Nothing -> def -- Use default - Just xx -> try_read sw xx + Nothing -> def -- Use default + Just xx -> try_read sw xx try_read :: Read a => String -> String -> a -- (try_read sw str) tries to read s; if it fails, it -- bleats about flag sw try_read sw str = case reads str of - ((x,_):_) -> x -- Be forgiving: ignore trailing goop, and alternative parses - [] -> throwGhcException (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw)) - -- ToDo: hack alert. We should really parse the arguments - -- and announce errors in a more civilised way. --} - - -{- - Putting the compiler options into temporary at-files - may turn out to be necessary later on if we turn hsc into - a pure Win32 application where I think there's a command-line - length limit of 255. unpacked_opts understands the @ option. - -unpacked_opts :: [String] -unpacked_opts = - concat $ - map (expandAts) $ - map unpackFS argv -- NOT ARGV any more: v_Static_hsc_opts - where - expandAts ('@':fname) = words (unsafePerformIO (readFile fname)) - expandAts l = [l] + ((x,_):_) -> x -- Be forgiving: ignore trailing goop, and alternative parses + [] -> throwGhcException (UsageError ("Malformed argument " ++ str ++ " for flag " ++ sw)) + -- ToDo: hack alert. We should really parse the arguments + -- and announce errors in a more civilised way. -} diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index bacd53e937..d43826a046 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -24,6 +24,8 @@ module SysTools ( figureLlvmVersion, readElfSection, + getLinkerInfo, + linkDynLib, askCc, @@ -371,30 +373,35 @@ findTopDir Nothing \begin{code} runUnlit :: DynFlags -> [Option] -> IO () runUnlit dflags args = do - let p = pgm_L dflags - runSomething dflags "Literate pre-processor" p args + let prog = pgm_L dflags + opts = getOpts dflags opt_L + runSomething dflags "Literate pre-processor" prog + (map Option opts ++ args) runCpp :: DynFlags -> [Option] -> IO () runCpp dflags args = do let (p,args0) = pgm_P dflags - args1 = args0 ++ args + args1 = map Option (getOpts dflags opt_P) args2 = if gopt Opt_WarnIsError dflags - then Option "-Werror" : args1 - else args1 + then [Option "-Werror"] + else [] mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "C pre-processor" p args2 mb_env + runSomethingFiltered dflags id "C pre-processor" p + (args0 ++ args1 ++ args2 ++ args) mb_env runPp :: DynFlags -> [Option] -> IO () runPp dflags args = do - let p = pgm_F dflags - runSomething dflags "Haskell pre-processor" p args + let prog = pgm_F dflags + opts = map Option (getOpts dflags opt_F) + runSomething dflags "Haskell pre-processor" prog (opts ++ args) runCc :: DynFlags -> [Option] -> IO () runCc dflags args = do let (p,args0) = pgm_c dflags - args1 = args0 ++ args - mb_env <- getGccEnv args1 - runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env + args1 = map Option (getOpts dflags opt_c) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingFiltered dflags cc_filter "C Compiler" p args2 mb_env where -- discard some harmless warnings from gcc that we can't turn off cc_filter = unlines . doFilter . lines @@ -452,9 +459,10 @@ xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) askCc :: DynFlags -> [Option] -> IO String askCc dflags args = do let (p,args0) = pgm_c dflags - args1 = args0 ++ args - mb_env <- getGccEnv args1 - runSomethingWith dflags "gcc" p args1 $ \real_args -> + args1 = map Option (getOpts dflags opt_c) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingWith dflags "gcc" p args2 $ \real_args -> readCreateProcess (proc p real_args){ env = mb_env } -- Version of System.Process.readProcessWithExitCode that takes an environment @@ -507,21 +515,24 @@ runSplit dflags args = do runAs :: DynFlags -> [Option] -> IO () runAs dflags args = do let (p,args0) = pgm_a dflags - args1 = args0 ++ args - mb_env <- getGccEnv args1 - runSomethingFiltered dflags id "Assembler" p args1 mb_env + args1 = map Option (getOpts dflags opt_a) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "Assembler" p args2 mb_env -- | Run the LLVM Optimiser runLlvmOpt :: DynFlags -> [Option] -> IO () runLlvmOpt dflags args = do let (p,args0) = pgm_lo dflags - runSomething dflags "LLVM Optimiser" p (args0++args) + args1 = map Option (getOpts dflags opt_lo) + runSomething dflags "LLVM Optimiser" p (args0 ++ args1 ++ args) -- | Run the LLVM Compiler runLlvmLlc :: DynFlags -> [Option] -> IO () runLlvmLlc dflags args = do let (p,args0) = pgm_lc dflags - runSomething dflags "LLVM Compiler" p (args0++args) + args1 = map Option (getOpts dflags opt_lc) + runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args) -- | Run the clang compiler (used as an assembler for the LLVM -- backend on OS X as LLVM doesn't support the OS X system @@ -533,10 +544,11 @@ runClang dflags args = do -- be careful what options we call clang with -- see #5903 and #7617 for bugs caused by this. (_,args0) = pgm_a dflags - args1 = args0 ++ args - mb_env <- getGccEnv args1 + args1 = map Option (getOpts dflags opt_a) + args2 = args0 ++ args1 ++ args + mb_env <- getGccEnv args2 Exception.catch (do - runSomethingFiltered dflags id "Clang (Assembler)" clang args1 mb_env + runSomethingFiltered dflags id "Clang (Assembler)" clang args2 mb_env ) (\(err :: SomeException) -> do errorMsg dflags $ @@ -586,14 +598,124 @@ figureLlvmVersion dflags = do text "Make sure you have installed LLVM"] return Nothing) return ver - + + +{- Note [Run-time linker info] + +See also: Trac #5240, Trac #6063 + +Before 'runLink', we need to be sure to get the relevant information +about the linker we're using at runtime to see if we need any extra +options. For example, GNU ld requires '--reduce-memory-overheads' and +'--hash-size=31' in order to use reasonable amounts of memory (see +trac #5240.) But this isn't supported in GNU gold. + +Generally, the linker changing from what was detected at ./configure +time has always been possible using -pgml, but on Linux it can happen +'transparently' by installing packages like binutils-gold, which +change what /usr/bin/ld actually points to. + +Clang vs GCC notes: + +For gcc, 'gcc -Wl,--version' gives a bunch of output about how to +invoke the linker before the version information string. For 'clang', +the version information for 'ld' is all that's output. For this +reason, we typically need to slurp up all of the standard error output +and look through it. + +Other notes: + +We cache the LinkerInfo inside DynFlags, since clients may link +multiple times. The definition of LinkerInfo is there to avoid a +circular dependency. + +-} + + +neededLinkArgs :: LinkerInfo -> [Option] +neededLinkArgs (GnuLD o) = o +neededLinkArgs (GnuGold o) = o +neededLinkArgs (DarwinLD o) = o +neededLinkArgs UnknownLD = [] + +-- Grab linker info and cache it in DynFlags. +getLinkerInfo :: DynFlags -> IO LinkerInfo +getLinkerInfo dflags = do + info <- readIORef (rtldFlags dflags) + case info of + Just v -> return v + Nothing -> do + v <- getLinkerInfo' dflags + writeIORef (rtldFlags dflags) (Just v) + return v + +-- See Note [Run-time linker info]. +getLinkerInfo' :: DynFlags -> IO LinkerInfo +getLinkerInfo' dflags = do + let platform = targetPlatform dflags + os = platformOS platform + (pgm,_) = pgm_l dflags + + -- Try to grab the info from the process output. + parseLinkerInfo stdo _stde _exitc + | any ("GNU ld" `isPrefixOf`) stdo = + -- GNU ld specifically needs to use less memory. This especially + -- hurts on small object files. Trac #5240. + return (GnuLD $ map Option ["-Wl,--hash-size=31", + "-Wl,--reduce-memory-overheads"]) + + | any ("GNU gold" `isPrefixOf`) stdo = + -- GNU gold does not require any special arguments. + return (GnuGold []) + + -- Unknown linker. + | otherwise = fail "invalid --version output, or linker is unsupported" + + -- Process the executable call + info <- catchIO (do + case os of + OSDarwin -> + -- Darwin has neither GNU Gold or GNU LD, but a strange linker + -- that doesn't support --version. We can just assume that's + -- what we're using. + return $ DarwinLD [] + OSMinGW32 -> + -- GHC doesn't support anything but GNU ld on Windows anyway. + -- Process creation is also fairly expensive on win32, so + -- we short-circuit here. + return $ GnuLD $ map Option ["-Wl,--hash-size=31", + "-Wl,--reduce-memory-overheads"] + _ -> do + -- In practice, we use the compiler as the linker here. Pass + -- -Wl,--version to get linker version info. + (exitc, stdo, stde) <- readProcessWithExitCode pgm + ["-Wl,--version"] "" + -- Split the output by lines to make certain kinds + -- of processing easier. In particular, 'clang' and 'gcc' + -- have slightly different outputs for '-Wl,--version', but + -- it's still easy to figure out. + parseLinkerInfo (lines stdo) (lines stde) exitc + ) + (\err -> do + debugTraceMsg dflags 2 + (text "Error (figuring out linker information):" <+> + text (show err)) + errorMsg dflags $ hang (text "Warning:") 9 $ + text "Couldn't figure out linker information!" $$ + text "Make sure you're using GNU ld, GNU gold" <+> + text "or the built in OS X linker, etc." + return UnknownLD) + return info runLink :: DynFlags -> [Option] -> IO () runLink dflags args = do + -- See Note [Run-time linker info] + linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags let (p,args0) = pgm_l dflags - args1 = args0 ++ args - mb_env <- getGccEnv args1 - runSomethingFiltered dflags id "Linker" p args1 mb_env + args1 = map Option (getOpts dflags opt_l) + args2 = args0 ++ args1 ++ args ++ linkargs + mb_env <- getGccEnv args2 + runSomethingFiltered dflags id "Linker" p args2 mb_env runMkDLL :: DynFlags -> [Option] -> IO () runMkDLL dflags args = do @@ -606,6 +728,7 @@ runWindres :: DynFlags -> [Option] -> IO () runWindres dflags args = do let (gcc, gcc_args) = pgm_c dflags windres = pgm_windres dflags + opts = map Option (getOpts dflags opt_windres) quote x = "\"" ++ x ++ "\"" args' = -- If windres.exe and gcc.exe are in a directory containing -- spaces then windres fails to run gcc. We therefore need @@ -613,6 +736,7 @@ runWindres dflags args = do Option ("--preprocessor=" ++ unwords (map quote (gcc : map showOpt gcc_args ++ + map showOpt opts ++ ["-E", "-xc", "-DRC_INVOKED"]))) -- ...but if we do that then if windres calls popen then -- it can't understand the quoting, so we have to use @@ -1051,10 +1175,22 @@ linesPlatform xs = #endif linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () -linkDynLib dflags o_files dep_packages +linkDynLib dflags0 o_files dep_packages = do - let verbFlags = getVerbFlags dflags - let o_file = outputFile dflags + let -- This is a rather ugly hack to fix dynamically linked + -- GHC on Windows. If GHC is linked with -threaded, then + -- it links against libHSrts_thr. But if base is linked + -- against libHSrts, then both end up getting loaded, + -- and things go wrong. We therefore link the libraries + -- with the same RTS flags that we link GHC with. + dflags1 = if cGhcThreaded then addWay' WayThreaded dflags0 + else dflags0 + dflags2 = if cGhcDebugged then addWay' WayDebug dflags1 + else dflags1 + dflags = updateWays dflags2 + + verbFlags = getVerbFlags dflags + o_file = outputFile dflags pkgs <- getPreloadPackagesAnd dflags dep_packages @@ -1089,8 +1225,6 @@ linkDynLib dflags o_files dep_packages -- probably _stub.o files let extra_ld_inputs = ldInputs dflags - let extra_ld_opts = getOpts dflags opt_l - case os of OSMinGW32 -> do ------------------------------------------------------------- @@ -1110,15 +1244,14 @@ linkDynLib dflags o_files dep_packages | gopt Opt_SharedImplib dflags ] ++ map (FileOption "") o_files - ++ map Option ( -- Permit the linker to auto link _symbol to _imp_symbol -- This lets us link against DLLs without needing an "import library" - ["-Wl,--enable-auto-import"] + ++ [Option "-Wl,--enable-auto-import"] ++ extra_ld_inputs - ++ lib_path_opts - ++ extra_ld_opts + ++ map Option ( + lib_path_opts ++ pkg_lib_path_opts ++ pkg_link_opts )) @@ -1169,19 +1302,19 @@ linkDynLib dflags o_files dep_packages , Option "-o" , FileOption "" output_fn ] - ++ map Option ( - o_files - ++ [ "-undefined", "dynamic_lookup", "-single_module" ] + ++ map Option o_files + ++ [ Option "-undefined", + Option "dynamic_lookup", + Option "-single_module" ] ++ (if platformArch platform == ArchX86_64 then [ ] - else [ "-Wl,-read_only_relocs,suppress" ]) - ++ [ "-install_name", instName ] + else [ Option "-Wl,-read_only_relocs,suppress" ]) + ++ [ Option "-install_name", Option instName ] + ++ map Option lib_path_opts ++ extra_ld_inputs - ++ lib_path_opts - ++ extra_ld_opts - ++ pkg_lib_path_opts - ++ pkg_link_opts - )) + ++ map Option pkg_lib_path_opts + ++ map Option pkg_link_opts + ) _ -> do ------------------------------------------------------------------- -- Making a DSO @@ -1202,18 +1335,15 @@ linkDynLib dflags o_files dep_packages ++ [ Option "-o" , FileOption "" output_fn ] - ++ map Option ( - o_files - ++ [ "-shared" ] - ++ bsymbolicFlag + ++ map Option o_files + ++ [ Option "-shared" ] + ++ map Option bsymbolicFlag -- Set the library soname. We use -h rather than -soname as -- Solaris 10 doesn't support the latter: - ++ [ "-Wl,-h," ++ takeFileName output_fn ] + ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ] + ++ map Option lib_path_opts ++ extra_ld_inputs - ++ lib_path_opts - ++ extra_ld_opts - ++ pkg_lib_path_opts - ++ pkg_link_opts - )) - + ++ map Option pkg_lib_path_opts + ++ map Option pkg_link_opts + ) \end{code} diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 8d152d78fe..7b3695dbed 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -36,7 +36,6 @@ import Name hiding (varName) import NameSet import NameEnv import Avail -import PrelNames import IfaceEnv import TcEnv import TcRnMonad @@ -153,7 +152,7 @@ mkBootModDetailsTc hsc_env } where -mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst Branched] -> TypeEnv +mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv mkBootTypeEnv exports ids tcs fam_insts = tidyTypeEnv True $ typeEnvFromEntities final_ids tcs fam_insts @@ -328,7 +327,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod -- See Note [Which rules to expose] ; (tidy_env, tidy_binds) - <- tidyTopBinds hsc_env unfold_env tidy_occ_env binds + <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env binds ; let { final_ids = [ id | id <- bindersOfBinds tidy_binds, isExternalName (idName id)] @@ -818,7 +817,8 @@ dffvLetBndr vanilla_unfold id | otherwise -> return () _ -> dffvExpr rhs - go_unf (DFunUnfolding _ _ args) = mapM_ dffvExpr (dfunArgExprs args) + go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = extendScopeList bndrs $ mapM_ dffvExpr args go_unf _ = return () go_rule (BuiltinRule {}) = return () @@ -974,14 +974,14 @@ rules are externalised (see init_ext_ids in function -- * subst_env: A Var->Var mapping that substitutes the new Var for the old tidyTopBinds :: HscEnv + -> Module -> UnfoldEnv -> TidyOccEnv -> CoreProgram -> IO (TidyEnv, CoreProgram) -tidyTopBinds hsc_env unfold_env init_occ_env binds - = do mkIntegerId <- liftM tyThingId - $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName) +tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds + = do mkIntegerId <- lookupMkIntegerName dflags hsc_env return $ tidy mkIntegerId init_env binds where dflags = hsc_dflags hsc_env @@ -991,7 +991,7 @@ tidyTopBinds hsc_env unfold_env init_occ_env binds this_pkg = thisPackage dflags tidy _ env [] = (env, []) - tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind dflags this_pkg mkIntegerId unfold_env env b + tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind dflags this_pkg this_mod mkIntegerId unfold_env env b (env2, bs') = tidy mkIntegerId env1 bs in (env2, b':bs') @@ -999,22 +999,23 @@ tidyTopBinds hsc_env unfold_env init_occ_env binds ------------------------ tidyTopBind :: DynFlags -> PackageId + -> Module -> Id -> UnfoldEnv -> TidyEnv -> CoreBind -> (TidyEnv, CoreBind) -tidyTopBind dflags this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs) +tidyTopBind dflags this_pkg this_mod mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs) = (tidy_env2, NonRec bndr' rhs') where Just (name',show_unfold) = lookupVarEnv unfold_env bndr - caf_info = hasCafRefs dflags this_pkg (mkIntegerId, subst1) (idArity bndr) rhs + caf_info = hasCafRefs dflags this_pkg this_mod (mkIntegerId, subst1) (idArity bndr) rhs (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name' (bndr, rhs) subst2 = extendVarEnv subst1 bndr bndr' tidy_env2 = (occ_env, subst2) -tidyTopBind dflags this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) +tidyTopBind dflags this_pkg this_mod mkIntegerId unfold_env (occ_env,subst1) (Rec prs) = (tidy_env2, Rec prs') where prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs) @@ -1031,7 +1032,7 @@ tidyTopBind dflags this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) -- the CafInfo for a recursive group says whether *any* rhs in -- the group may refer indirectly to a CAF (because then, they all do). caf_info - | or [ mayHaveCafRefs (hasCafRefs dflags this_pkg (mkIntegerId, subst1) (idArity bndr) rhs) + | or [ mayHaveCafRefs (hasCafRefs dflags this_pkg this_mod (mkIntegerId, subst1) (idArity bndr) rhs) | (bndr,rhs) <- prs ] = MayHaveCafRefs | otherwise = NoCafRefs @@ -1167,14 +1168,15 @@ it as a CAF. In these cases however, we would need to use an additional CAF list to keep track of non-collectable CAFs. \begin{code} -hasCafRefs :: DynFlags -> PackageId -> (Id, VarEnv Var) -> Arity -> CoreExpr +hasCafRefs :: DynFlags -> PackageId -> Module + -> (Id, VarEnv Var) -> Arity -> CoreExpr -> CafInfo -hasCafRefs dflags this_pkg p arity expr +hasCafRefs dflags this_pkg this_mod p arity expr | is_caf || mentions_cafs = MayHaveCafRefs | otherwise = NoCafRefs where mentions_cafs = isFastTrue (cafRefsE dflags p expr) - is_dynamic_name = isDllName dflags this_pkg + is_dynamic_name = isDllName dflags this_pkg this_mod is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name expr) -- NB. we pass in the arity of the expression, which is expected diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 34c43090e8..a999f8f45a 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -151,14 +151,14 @@ data NcgImpl statics instr jumpDest = NcgImpl { } -------------------- -nativeCodeGen :: DynFlags -> Handle -> UniqSupply +nativeCodeGen :: DynFlags -> Module -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO UniqSupply -nativeCodeGen dflags h us cmms +nativeCodeGen dflags this_mod h us cmms = let platform = targetPlatform dflags nCG' :: (Outputable statics, Outputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO UniqSupply - nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms + nCG' ncgImpl = nativeCodeGen' dflags this_mod ncgImpl h us cmms in case platformArch platform of ArchX86 -> nCG' (x86NcgImpl dflags) ArchX86_64 -> nCG' (x86_64NcgImpl dflags) @@ -255,19 +255,20 @@ type NativeGenAcc statics instr nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags + -> Module -> NcgImpl statics instr jumpDest -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO UniqSupply -nativeCodeGen' dflags ncgImpl h us cmms +nativeCodeGen' dflags this_mod ncgImpl h us cmms = do let split_cmms = Stream.map add_split cmms -- BufHandle is a performance hack. We could hide it inside -- Pretty if it weren't for the fact that we do lots of little -- printDocs here (in order to do codegen in constant space). bufh <- newBufHandle h - (ngs, us') <- cmmNativeGenStream dflags ncgImpl bufh us split_cmms ([], []) + (ngs, us') <- cmmNativeGenStream dflags this_mod ncgImpl bufh us split_cmms ([], []) finishNativeGen dflags ncgImpl bufh ngs return us' @@ -335,6 +336,7 @@ finishNativeGen dflags ncgImpl bufh@(BufHandle _ _ h) (imports, prof) cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags + -> Module -> NcgImpl statics instr jumpDest -> BufHandle -> UniqSupply @@ -342,19 +344,20 @@ cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr) -> NativeGenAcc statics instr -> IO (NativeGenAcc statics instr, UniqSupply) -cmmNativeGenStream dflags ncgImpl h us cmm_stream ngs@(impAcc, profAcc) +cmmNativeGenStream dflags this_mod ncgImpl h us cmm_stream ngs@(impAcc, profAcc) = do r <- Stream.runStream cmm_stream case r of Left () -> return ((reverse impAcc, reverse profAcc) , us) Right (cmms, cmm_stream') -> do - (ngs',us') <- cmmNativeGens dflags ncgImpl h us cmms ngs 0 - cmmNativeGenStream dflags ncgImpl h us' cmm_stream' ngs' + (ngs',us') <- cmmNativeGens dflags this_mod ncgImpl h us cmms ngs 0 + cmmNativeGenStream dflags this_mod ncgImpl h us' cmm_stream' ngs' -- | Do native code generation on all these cmms. -- cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags + -> Module -> NcgImpl statics instr jumpDest -> BufHandle -> UniqSupply @@ -363,13 +366,13 @@ cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr) -> Int -> IO (NativeGenAcc statics instr, UniqSupply) -cmmNativeGens _ _ _ us [] ngs _ +cmmNativeGens _ _ _ _ us [] ngs _ = return (ngs, us) -cmmNativeGens dflags ncgImpl h us (cmm : cmms) (impAcc, profAcc) count +cmmNativeGens dflags this_mod ncgImpl h us (cmm : cmms) (impAcc, profAcc) count = do (us', native, imports, colorStats, linearStats) - <- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count + <- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags this_mod ncgImpl us cmm count {-# SCC "pprNativeCode" #-} Pretty.bufLeftRender h $ withPprStyleDoc dflags (mkCodeStyle AsmStyle) @@ -386,7 +389,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) (impAcc, profAcc) count -- force evaluation all this stuff to avoid space leaks {-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports) - cmmNativeGens dflags ncgImpl h + cmmNativeGens dflags this_mod ncgImpl h us' cmms ((imports : impAcc), ((lsPprNative, colorStats, linearStats) : profAcc)) count' @@ -401,6 +404,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) (impAcc, profAcc) count cmmNativeGen :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags + -> Module -> NcgImpl statics instr jumpDest -> UniqSupply -> RawCmmDecl -- ^ the cmm to generate code for @@ -411,7 +415,7 @@ cmmNativeGen , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators -cmmNativeGen dflags ncgImpl us cmm count +cmmNativeGen dflags this_mod ncgImpl us cmm count = do let platform = targetPlatform dflags @@ -423,7 +427,7 @@ cmmNativeGen dflags ncgImpl us cmm count -- cmm to cmm optimisations let (opt_cmm, imports) = {-# SCC "cmmToCmm" #-} - cmmToCmm dflags fixed_cmm + cmmToCmm dflags this_mod fixed_cmm dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" @@ -432,7 +436,7 @@ cmmNativeGen dflags ncgImpl us cmm count -- generate native code from cmm let ((native, lastMinuteImports), usGen) = {-# SCC "genMachCode" #-} - initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm + initUs us $ genMachCode dflags this_mod (cmmTopCodeGen ncgImpl) opt_cmm dumpIfSet_dyn dflags Opt_D_dump_asm_native "Native code" @@ -816,15 +820,16 @@ apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks)) genMachCode :: DynFlags + -> Module -> (RawCmmDecl -> NatM [NatCmmDecl statics instr]) -> RawCmmDecl -> UniqSM ( [NatCmmDecl statics instr] , [CLabel]) -genMachCode dflags cmmTopCodeGen cmm_top +genMachCode dflags this_mod cmmTopCodeGen cmm_top = do { initial_us <- getUs - ; let initial_st = mkNatM_State initial_us 0 dflags + ; let initial_st = mkNatM_State initial_us 0 dflags this_mod (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top) final_delta = natm_delta final_st final_imports = natm_imports final_st @@ -858,31 +863,36 @@ Ideas for other things we could do (put these in Hoopl please!): temp assignments, and certain assigns to mem...) -} -cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel]) -cmmToCmm _ top@(CmmData _ _) = (top, []) -cmmToCmm dflags (CmmProc info lbl live graph) = runCmmOpt dflags $ do - blocks' <- mapM cmmBlockConFold (toBlockList graph) - return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks') +cmmToCmm :: DynFlags -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel]) +cmmToCmm _ _ top@(CmmData _ _) = (top, []) +cmmToCmm dflags this_mod (CmmProc info lbl live graph) + = runCmmOpt dflags this_mod $ + do blocks' <- mapM cmmBlockConFold (toBlockList graph) + return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks') -newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) +newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> (# a, [CLabel] #)) instance Monad CmmOptM where - return x = CmmOptM $ \(imports, _) -> (# x,imports #) + return x = CmmOptM $ \_ _ imports -> (# x, imports #) (CmmOptM f) >>= g = - CmmOptM $ \(imports, dflags) -> - case f (imports, dflags) of + CmmOptM $ \dflags this_mod imports -> + case f dflags this_mod imports of (# x, imports' #) -> case g x of - CmmOptM g' -> g' (imports', dflags) + CmmOptM g' -> g' dflags this_mod imports' + +instance CmmMakeDynamicReferenceM CmmOptM where + addImport = addImportCmmOpt + getThisModule = CmmOptM $ \_ this_mod imports -> (# this_mod, imports #) addImportCmmOpt :: CLabel -> CmmOptM () -addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #) +addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> (# (), lbl:imports #) instance HasDynFlags CmmOptM where - getDynFlags = CmmOptM $ \(imports, dflags) -> (# dflags, imports #) + getDynFlags = CmmOptM $ \dflags _ imports -> (# dflags, imports #) -runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel]) -runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of +runCmmOpt :: DynFlags -> Module -> CmmOptM a -> (a, [CLabel]) +runCmmOpt dflags this_mod (CmmOptM f) = case f dflags this_mod [] of (# result, imports #) -> (result, imports) cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock @@ -986,10 +996,10 @@ cmmExprNative referenceKind expr = do CmmLit (CmmLabel lbl) -> do - cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl + cmmMakeDynamicReference dflags referenceKind lbl CmmLit (CmmLabelOff lbl off) -> do - dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl + dynRef <- cmmMakeDynamicReference dflags referenceKind lbl -- need to optimize here, since it's late return $ cmmMachOpFold dflags (MO_Add (wordWidth dflags)) [ dynRef, diff --git a/compiler/nativeGen/CPrim.hs b/compiler/nativeGen/CPrim.hs index dd9d38f434..a6f4cab7bd 100644 --- a/compiler/nativeGen/CPrim.hs +++ b/compiler/nativeGen/CPrim.hs @@ -1,6 +1,7 @@ -- | Generating C symbol names emitted by the compiler. module CPrim ( popCntLabel + , bSwapLabel , word2FloatLabel ) where @@ -16,6 +17,14 @@ popCntLabel w = "hs_popcnt" ++ pprWidth w pprWidth W64 = "64" pprWidth w = pprPanic "popCntLabel: Unsupported word width " (ppr w) +bSwapLabel :: Width -> String +bSwapLabel w = "hs_bswap" ++ pprWidth w + where + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "bSwapLabel: Unsupported word width " (ppr w) + word2FloatLabel :: Width -> String word2FloatLabel w = "hs_word2float" ++ pprWidth w where diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs index 619bf9a5fc..fec6805b4e 100644 --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -16,6 +16,7 @@ module NCGMonad ( mapAccumLNat, setDeltaNat, getDeltaNat, + getThisModuleNat, getBlockIdNat, getNewLabelNat, getNewRegNat, @@ -38,14 +39,16 @@ import CLabel ( CLabel, mkAsmTempLabel ) import UniqSupply import Unique ( Unique ) import DynFlags +import Module data NatM_State = NatM_State { - natm_us :: UniqSupply, - natm_delta :: Int, - natm_imports :: [(CLabel)], - natm_pic :: Maybe Reg, - natm_dflags :: DynFlags + natm_us :: UniqSupply, + natm_delta :: Int, + natm_imports :: [(CLabel)], + natm_pic :: Maybe Reg, + natm_dflags :: DynFlags, + natm_this_module :: Module } newtype NatM result = NatM (NatM_State -> (result, NatM_State)) @@ -53,9 +56,9 @@ newtype NatM result = NatM (NatM_State -> (result, NatM_State)) unNat :: NatM a -> NatM_State -> (a, NatM_State) unNat (NatM a) = a -mkNatM_State :: UniqSupply -> Int -> DynFlags -> NatM_State -mkNatM_State us delta dflags - = NatM_State us delta [] Nothing dflags +mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> NatM_State +mkNatM_State us delta dflags this_mod + = NatM_State us delta [] Nothing dflags this_mod initNat :: NatM_State -> NatM a -> (a, NatM_State) initNat init_st m @@ -89,30 +92,29 @@ mapAccumLNat f b (x:xs) return (b__3, x__2:xs__2) getUniqueNat :: NatM Unique -getUniqueNat = NatM $ \ (NatM_State us delta imports pic dflags) -> - case takeUniqFromSupply us of - (uniq, us') -> (uniq, (NatM_State us' delta imports pic dflags)) +getUniqueNat = NatM $ \ st -> + case takeUniqFromSupply $ natm_us st of + (uniq, us') -> (uniq, st {natm_us = us'}) instance HasDynFlags NatM where - getDynFlags = NatM $ \ (NatM_State us delta imports pic dflags) -> - (dflags, (NatM_State us delta imports pic dflags)) + getDynFlags = NatM $ \ st -> (natm_dflags st, st) getDeltaNat :: NatM Int -getDeltaNat - = NatM $ \ st -> (natm_delta st, st) +getDeltaNat = NatM $ \ st -> (natm_delta st, st) setDeltaNat :: Int -> NatM () -setDeltaNat delta - = NatM $ \ (NatM_State us _ imports pic dflags) -> - ((), NatM_State us delta imports pic dflags) +setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta}) + + +getThisModuleNat :: NatM Module +getThisModuleNat = NatM $ \ st -> (natm_this_module st, st) addImportNat :: CLabel -> NatM () addImportNat imp - = NatM $ \ (NatM_State us delta imports pic dflags) -> - ((), NatM_State us delta (imp:imports) pic dflags) + = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st}) getBlockIdNat :: NatM BlockId diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index 5fff8cbdbb..b36c0ae1e8 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -35,6 +35,7 @@ module PIC ( cmmMakeDynamicReference, + CmmMakeDynamicReferenceM(..), ReferenceKind(..), needImportedSymbols, pprImportedSymbol, @@ -69,6 +70,7 @@ import CLabel ( mkForeignLabel ) import BasicTypes +import Module import Outputable @@ -96,26 +98,32 @@ data ReferenceKind | JumpReference deriving(Eq) +class Monad m => CmmMakeDynamicReferenceM m where + addImport :: CLabel -> m () + getThisModule :: m Module -cmmMakeDynamicReference, cmmMakeDynamicReference' - :: Monad m => DynFlags - -> (CLabel -> m ()) -- a monad & a function - -- used for recording imported symbols - -> ReferenceKind -- whether this is the target of a jump - -> CLabel -- the label - -> m CmmExpr +instance CmmMakeDynamicReferenceM NatM where + addImport = addImportNat + getThisModule = getThisModuleNat -cmmMakeDynamicReference = cmmMakeDynamicReference' +cmmMakeDynamicReference + :: CmmMakeDynamicReferenceM m + => DynFlags + -> ReferenceKind -- whether this is the target of a jump + -> CLabel -- the label + -> m CmmExpr -cmmMakeDynamicReference' dflags addImport referenceKind lbl +cmmMakeDynamicReference dflags referenceKind lbl | Just _ <- dynamicLinkerLabelInfo lbl = return $ CmmLit $ CmmLabel lbl -- already processed it, pass through | otherwise - = case howToAccessLabel + = do this_mod <- getThisModule + case howToAccessLabel dflags (platformArch $ targetPlatform dflags) (platformOS $ targetPlatform dflags) + this_mod referenceKind lbl of AccessViaStub -> do @@ -186,7 +194,7 @@ data LabelAccessStyle | AccessDirectly howToAccessLabel - :: DynFlags -> Arch -> OS -> ReferenceKind -> CLabel -> LabelAccessStyle + :: DynFlags -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle -- Windows @@ -210,7 +218,7 @@ howToAccessLabel -- into the same .exe file. In this case we always access symbols directly, -- and never use __imp_SYMBOL. -- -howToAccessLabel dflags _ OSMinGW32 _ lbl +howToAccessLabel dflags _ OSMinGW32 this_mod _ lbl -- Assume all symbols will be in the same PE, so just access them directly. | gopt Opt_Static dflags @@ -218,7 +226,7 @@ howToAccessLabel dflags _ OSMinGW32 _ lbl -- If the target symbol is in another PE we need to access it via the -- appropriate __imp_SYMBOL pointer. - | labelDynamic dflags (thisPackage dflags) lbl + | labelDynamic dflags (thisPackage dflags) this_mod lbl = AccessViaSymbolPtr -- Target symbol is in the same PE as the caller, so just access it directly. @@ -234,9 +242,9 @@ howToAccessLabel dflags _ OSMinGW32 _ lbl -- It is always possible to access something indirectly, -- even when it's not necessary. -- -howToAccessLabel dflags arch OSDarwin DataReference lbl +howToAccessLabel dflags arch OSDarwin this_mod DataReference lbl -- data access to a dynamic library goes via a symbol pointer - | labelDynamic dflags (thisPackage dflags) lbl + | labelDynamic dflags (thisPackage dflags) this_mod lbl = AccessViaSymbolPtr -- when generating PIC code, all cross-module data references must @@ -255,21 +263,21 @@ howToAccessLabel dflags arch OSDarwin DataReference lbl | otherwise = AccessDirectly -howToAccessLabel dflags arch OSDarwin JumpReference lbl +howToAccessLabel dflags arch OSDarwin this_mod JumpReference lbl -- dyld code stubs don't work for tailcalls because the -- stack alignment is only right for regular calls. -- Therefore, we have to go via a symbol pointer: | arch == ArchX86 || arch == ArchX86_64 - , labelDynamic dflags (thisPackage dflags) lbl + , labelDynamic dflags (thisPackage dflags) this_mod lbl = AccessViaSymbolPtr -howToAccessLabel dflags arch OSDarwin _ lbl +howToAccessLabel dflags arch OSDarwin this_mod _ lbl -- Code stubs are the usual method of choice for imported code; -- not needed on x86_64 because Apple's new linker, ld64, generates -- them automatically. | arch /= ArchX86_64 - , labelDynamic dflags (thisPackage dflags) lbl + , labelDynamic dflags (thisPackage dflags) this_mod lbl = AccessViaStub | otherwise @@ -286,7 +294,7 @@ howToAccessLabel dflags arch OSDarwin _ lbl -- from position independent code. It is also required from the main program -- when dynamic libraries containing Haskell code are used. -howToAccessLabel _ ArchPPC_64 os kind _ +howToAccessLabel _ ArchPPC_64 os _ kind _ | osElfTarget os = if kind == DataReference -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC @@ -294,7 +302,7 @@ howToAccessLabel _ ArchPPC_64 os kind _ -- actually, .label instead of label else AccessDirectly -howToAccessLabel dflags _ os _ _ +howToAccessLabel dflags _ os _ _ _ -- no PIC -> the dynamic linker does everything for us; -- if we don't dynamically link to Haskell code, -- it actually manages to do so without messing thins up. @@ -302,11 +310,11 @@ howToAccessLabel dflags _ os _ _ , not (gopt Opt_PIC dflags) && gopt Opt_Static dflags = AccessDirectly -howToAccessLabel dflags arch os DataReference lbl +howToAccessLabel dflags arch os this_mod DataReference lbl | osElfTarget os = case () of -- A dynamic label needs to be accessed via a symbol pointer. - _ | labelDynamic dflags (thisPackage dflags) lbl + _ | labelDynamic dflags (thisPackage dflags) this_mod lbl -> AccessViaSymbolPtr -- For PowerPC32 -fPIC, we have to access even static data @@ -332,24 +340,24 @@ howToAccessLabel dflags arch os DataReference lbl -- (AccessDirectly, because we get an implicit symbol stub) -- and calling functions from PIC code on non-i386 platforms (via a symbol stub) -howToAccessLabel dflags arch os CallReference lbl +howToAccessLabel dflags arch os this_mod CallReference lbl | osElfTarget os - , labelDynamic dflags (thisPackage dflags) lbl && not (gopt Opt_PIC dflags) + , labelDynamic dflags (thisPackage dflags) this_mod lbl && not (gopt Opt_PIC dflags) = AccessDirectly | osElfTarget os , arch /= ArchX86 - , labelDynamic dflags (thisPackage dflags) lbl && gopt Opt_PIC dflags + , labelDynamic dflags (thisPackage dflags) this_mod lbl && gopt Opt_PIC dflags = AccessViaStub -howToAccessLabel dflags _ os _ lbl +howToAccessLabel dflags _ os this_mod _ lbl | osElfTarget os - = if labelDynamic dflags (thisPackage dflags) lbl + = if labelDynamic dflags (thisPackage dflags) this_mod lbl then AccessViaSymbolPtr else AccessDirectly -- all other platforms -howToAccessLabel dflags _ _ _ _ +howToAccessLabel dflags _ _ _ _ _ | not (gopt Opt_PIC dflags) = AccessDirectly @@ -771,19 +779,11 @@ initializePicBase_x86 ArchX86 os picReg BasicBlock bID (X86.FETCHGOT picReg : insns) initializePicBase_x86 ArchX86 OSDarwin picReg - (CmmProc info lab live (ListGraph blocks) : statics) - = return (CmmProc info lab live (ListGraph blocks') : statics) - - where blocks' = case blocks of - [] -> [] - (b:bs) -> fetchPC b : map maybeFetchPC bs - - maybeFetchPC b@(BasicBlock bID _) - | bID `mapMember` info = fetchPC b - | otherwise = b + (CmmProc info lab live (ListGraph (entry:blocks)) : statics) + = return (CmmProc info lab live (ListGraph (block':blocks)) : statics) - fetchPC (BasicBlock bID insns) = - BasicBlock bID (X86.FETCHPC picReg : insns) + where BasicBlock bID insns = entry + block' = BasicBlock bID (X86.FETCHPC picReg : insns) initializePicBase_x86 _ _ _ _ = panic "initializePicBase_x86: not needed" diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 92eff362f8..65533d8f9a 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -561,7 +561,7 @@ getRegister' _ (CmmLit (CmmInt i rep)) getRegister' _ (CmmLit (CmmFloat f frep)) = do lbl <- getNewLabelNat dflags <- getDynFlags - dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl + dynRef <- cmmMakeDynamicReference dflags DataReference lbl Amode addr addr_code <- getAmode dynRef let size = floatSize frep code dst = @@ -913,7 +913,7 @@ genCCall' _ _ (PrimTarget MO_Touch) _ _ = return $ nilOL genCCall' dflags gcp target dest_regs args0 - = ASSERT (not $ any (`elem` [II16]) $ map cmmTypeSize argReps) + = ASSERT(not $ any (`elem` [II16]) $ map cmmTypeSize argReps) -- we rely on argument promotion in the codeGen do (finalStack,passArgumentsCode,usedRegs) <- passArguments @@ -1107,7 +1107,7 @@ genCCall' dflags gcp target dest_regs args0 outOfLineMachOp mop = do dflags <- getDynFlags - mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $ + mopExpr <- cmmMakeDynamicReference dflags CallReference $ mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction let mopLabelOrExpr = case mopExpr of CmmLit (CmmLabel lbl) -> Left lbl @@ -1155,6 +1155,7 @@ genCCall' dflags gcp target dest_regs args0 MO_Memset -> (fsLit "memset", False) MO_Memmove -> (fsLit "memmove", False) + MO_BSwap w -> (fsLit $ bSwapLabel w, False) MO_PopCnt w -> (fsLit $ popCntLabel w, False) MO_S_QuotRem {} -> unsupported @@ -1179,7 +1180,7 @@ genSwitch dflags expr ids tmp <- getNewRegNat II32 lbl <- getNewLabelNat dflags <- getDynFlags - dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl + dynRef <- cmmMakeDynamicReference dflags DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef let code = e_code `appOL` t_code `appOL` toOL [ SLW tmp reg (RIImm (ImmInt 2)), @@ -1382,7 +1383,7 @@ coerceInt2FP fromRep toRep x = do itmp <- getNewRegNat II32 ftmp <- getNewRegNat FF64 dflags <- getDynFlags - dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl + dynRef <- cmmMakeDynamicReference dflags DataReference lbl Amode addr addr_code <- getAmode dynRef let code' dst = code `appOL` maybe_exts `appOL` toOL [ diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index 30ffcd9d9a..5d2b9a9d6d 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -588,7 +588,7 @@ outOfLineMachOp mop = outOfLineMachOp_table mop dflags <- getDynFlags - mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference + mopExpr <- cmmMakeDynamicReference dflags CallReference $ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction let mopLabelOrExpr @@ -647,6 +647,7 @@ outOfLineMachOp_table mop MO_Memset -> fsLit "memset" MO_Memmove -> fsLit "memmove" + MO_BSwap w -> fsLit $ bSwapLabel w MO_PopCnt w -> fsLit $ popCntLabel w MO_S_QuotRem {} -> unsupported diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 36aebea2c7..f6143d3fb9 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -1170,7 +1170,6 @@ memConstant align lit = do (addr, addr_code) <- if target32Bit (targetPlatform dflags) then do dynRef <- cmmMakeDynamicReference dflags - addImportNat DataReference lbl Amode addr addr_code <- getAmode dynRef @@ -1659,6 +1658,29 @@ genCCall _ (PrimTarget MO_Touch) _ _ = return nilOL genCCall _ (PrimTarget MO_Prefetch_Data) _ _ = return nilOL +genCCall is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] = do + dflags <- getDynFlags + let platform = targetPlatform dflags + let dst_r = getRegisterReg platform False (CmmLocal dst) + case width of + W64 | is32Bit -> do + ChildCode64 vcode rlo <- iselExpr64 src + let dst_rhi = getHiVRegFromLo dst_r + rhi = getHiVRegFromLo rlo + return $ vcode `appOL` + toOL [ MOV II32 (OpReg rlo) (OpReg dst_rhi), + MOV II32 (OpReg rhi) (OpReg dst_r), + BSWAP II32 dst_rhi, + BSWAP II32 dst_r ] + W16 -> do code_src <- getAnyReg src + return $ code_src dst_r `appOL` + unitOL (BSWAP II32 dst_r) `appOL` + unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r)) + _ -> do code_src <- getAnyReg src + return $ code_src dst_r `appOL` unitOL (BSWAP size dst_r) + where + size = intSize width + genCCall is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst] args@[src] = do sse4_2 <- sse4_2Enabled @@ -1677,7 +1699,7 @@ genCCall is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst] unitOL (POPCNT size (OpReg src_r) (getRegisterReg platform False (CmmLocal dst)))) else do - targetExpr <- cmmMakeDynamicReference dflags addImportNat + targetExpr <- cmmMakeDynamicReference dflags CallReference lbl let target = ForeignTarget targetExpr (ForeignConvention CCallConv [NoHint] [NoHint] @@ -1689,7 +1711,7 @@ genCCall is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst] genCCall is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args = do dflags <- getDynFlags - targetExpr <- cmmMakeDynamicReference dflags addImportNat + targetExpr <- cmmMakeDynamicReference dflags CallReference lbl let target = ForeignTarget targetExpr (ForeignConvention CCallConv [NoHint] [NoHint] @@ -1835,7 +1857,7 @@ genCCall32' dflags target dest_regs args = do use_sse2 <- sse2Enabled push_codes <- mapM (push_arg use_sse2) (reverse prom_args) delta <- getDeltaNat - MASSERT (delta == delta0 - tot_arg_size) + MASSERT(delta == delta0 - tot_arg_size) -- deal with static vs dynamic call targets (callinsns,cconv) <- @@ -2271,7 +2293,7 @@ outOfLineCmmOp :: CallishMachOp -> Maybe CmmFormal -> [CmmActual] -> NatM InstrB outOfLineCmmOp mop res args = do dflags <- getDynFlags - targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl + targetExpr <- cmmMakeDynamicReference dflags CallReference lbl let target = ForeignTarget targetExpr (ForeignConvention CCallConv [] [] CmmMayReturn) @@ -2326,6 +2348,7 @@ outOfLineCmmOp mop res args MO_Memmove -> fsLit "memmove" MO_PopCnt _ -> fsLit "popcnt" + MO_BSwap _ -> fsLit "bswap" MO_UF_Conv _ -> unsupported @@ -2351,7 +2374,7 @@ genSwitch dflags expr ids (reg,e_code) <- getSomeReg expr lbl <- getNewLabelNat dflags <- getDynFlags - dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl + dynRef <- cmmMakeDynamicReference dflags DataReference lbl (tableReg,t_code) <- getSomeReg $ dynRef let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (wORD_SIZE dflags)) (ImmInt 0)) diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 76f0e8bd91..266a4ea58a 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -208,6 +208,7 @@ data Instr | XOR Size Operand Operand | NOT Size Operand | NEGI Size Operand -- NEG instruction (name clash with Cond) + | BSWAP Size Reg -- Shifts (amount may be immediate or %cl only) | SHL Size Operand{-amount-} Operand @@ -351,6 +352,7 @@ x86_regUsageOfInstr platform instr XOR _ src dst -> usageRM src dst NOT _ op -> usageM op + BSWAP _ reg -> mkRU [reg] [reg] NEGI _ op -> usageM op SHL _ imm dst -> usageRM imm dst SAR _ imm dst -> usageRM imm dst @@ -489,6 +491,7 @@ x86_patchRegsOfInstr instr env OR sz src dst -> patch2 (OR sz) src dst XOR sz src dst -> patch2 (XOR sz) src dst NOT sz op -> patch1 (NOT sz) op + BSWAP sz reg -> BSWAP sz (env reg) NEGI sz op -> patch1 (NEGI sz) op SHL sz imm dst -> patch1 (SHL sz imm) dst SAR sz imm dst -> patch1 (SAR sz imm) dst diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 75d18a1ff4..7f9c6901da 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -578,6 +578,7 @@ pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor") size src dst pprInstr (POPCNT size src dst) = pprOpOp (sLit "popcnt") size src (OpReg dst) pprInstr (NOT size op) = pprSizeOp (sLit "not") size op +pprInstr (BSWAP size op) = pprSizeOp (sLit "bswap") size (OpReg op) pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 68712109c5..95880946bb 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -57,6 +57,8 @@ module Lexer ( extension, bangPatEnabled, datatypeContextsEnabled, traditionalRecordSyntaxEnabled, typeLiteralsEnabled, + explicitForallEnabled, + inRulePrag, explicitNamespacesEnabled, sccProfilingOn, hpcEnabled, addWarning, lexTokenStream @@ -362,14 +364,14 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } @qual @varid { idtoken qvarid } @qual @conid { idtoken qconid } @varid { varid } - @conid { idtoken conid } + @conid { conid } } <0> { @qual @varid "#"+ / { ifExtension magicHashEnabled } { idtoken qvarid } @qual @conid "#"+ / { ifExtension magicHashEnabled } { idtoken qconid } @varid "#"+ / { ifExtension magicHashEnabled } { varid } - @conid "#"+ / { ifExtension magicHashEnabled } { idtoken conid } + @conid "#"+ / { ifExtension magicHashEnabled } { conid } } -- ToDo: - move `var` and (sym) into lexical syntax? @@ -385,12 +387,16 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } -- when trying to be close to Haskell98 <0> { -- Normal integral literals (:: Num a => a, from Integer) - @decimal { tok_num positive 0 0 decimal } - 0[oO] @octal { tok_num positive 2 2 octal } - 0[xX] @hexadecimal { tok_num positive 2 2 hexadecimal } + @decimal { tok_num positive 0 0 decimal } + 0[oO] @octal { tok_num positive 2 2 octal } + 0[xX] @hexadecimal { tok_num positive 2 2 hexadecimal } + @negative @decimal / { ifExtension negativeLiteralsEnabled } { tok_num negative 1 1 decimal } + @negative 0[oO] @octal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 octal } + @negative 0[xX] @hexadecimal / { ifExtension negativeLiteralsEnabled } { tok_num negative 3 3 hexadecimal } -- Normal rational literals (:: Fractional a => a, from Rational) - @floating_point { strtoken tok_float } + @floating_point { strtoken tok_float } + @negative @floating_point / { ifExtension negativeLiteralsEnabled } { strtoken tok_float } } <0> { @@ -471,6 +477,9 @@ data Token | ITgroup | ITby | ITusing + | ITnominal + | ITrepresentational + | ITphantom -- Pragmas | ITinline_prag InlineSpec RuleMatchInfo @@ -660,11 +669,19 @@ reservedWordsFM = listToUFM $ ( "capi", ITcapiconv, bit cApiFfiBit), ( "prim", ITprimcallconv, bit ffiBit), - ( "rec", ITrec, bit arrowsBit .|. + ( "rec", ITrec, bit arrowsBit .|. bit recursiveDoBit), ( "proc", ITproc, bit arrowsBit) ] +reservedUpcaseWordsFM :: UniqFM (Token, Int) +reservedUpcaseWordsFM = listToUFM $ + map (\(x, y, z) -> (mkFastString x, (y, z))) + [ ( "N", ITnominal, 0 ), -- no extension bit for better error msgs + ( "R", ITrepresentational, 0 ), + ( "P", ITphantom, 0 ) + ] + reservedSymsFM :: UniqFM (Token, Int -> Bool) reservedSymsFM = listToUFM $ map (\ (x,y,z) -> (mkFastString x,(y,z))) @@ -696,8 +713,7 @@ reservedSymsFM = listToUFM $ ,("∷", ITdcolon, unicodeSyntaxEnabled) ,("⇒", ITdarrow, unicodeSyntaxEnabled) - ,("∀", ITforall, \i -> unicodeSyntaxEnabled i && - explicitForallEnabled i) + ,("∀", ITforall, unicodeSyntaxEnabled) ,("→", ITrarrow, unicodeSyntaxEnabled) ,("←", ITlarrow, unicodeSyntaxEnabled) @@ -1010,8 +1026,20 @@ varid span buf len = where !fs = lexemeToFastString buf len -conid :: StringBuffer -> Int -> Token -conid buf len = ITconid $! lexemeToFastString buf len +conid :: Action +conid span buf len = + case lookupUFM reservedUpcaseWordsFM fs of + Just (keyword, 0) -> return $ L span keyword + + Just (keyword, exts) -> do + extsEnabled <- extension $ \i -> exts .&. i /= 0 + if extsEnabled + then return $ L span keyword + else return $ L span $ ITconid fs + + Nothing -> return $ L span $ ITconid fs + where + !fs = lexemeToFastString buf len qvarsym, qconsym, prefixqvarsym, prefixqconsym :: StringBuffer -> Int -> Token qvarsym buf len = ITqvarsym $! splitQualName buf len False @@ -1870,6 +1898,8 @@ explicitNamespacesBit :: Int explicitNamespacesBit = 29 lambdaCaseBit :: Int lambdaCaseBit = 30 +negativeLiteralsBit :: Int +negativeLiteralsBit = 31 always :: Int -> Bool @@ -1902,8 +1932,8 @@ datatypeContextsEnabled :: Int -> Bool datatypeContextsEnabled flags = testBit flags datatypeContextsBit qqEnabled :: Int -> Bool qqEnabled flags = testBit flags qqBit --- inRulePrag :: Int -> Bool --- inRulePrag flags = testBit flags inRulePragBit +inRulePrag :: Int -> Bool +inRulePrag flags = testBit flags inRulePragBit rawTokenStreamEnabled :: Int -> Bool rawTokenStreamEnabled flags = testBit flags rawTokenStreamBit alternativeLayoutRule :: Int -> Bool @@ -1925,6 +1955,8 @@ explicitNamespacesEnabled :: Int -> Bool explicitNamespacesEnabled flags = testBit flags explicitNamespacesBit lambdaCaseEnabled :: Int -> Bool lambdaCaseEnabled flags = testBit flags lambdaCaseBit +negativeLiteralsEnabled :: Int -> Bool +negativeLiteralsEnabled flags = testBit flags negativeLiteralsBit -- PState for parsing options pragmas -- @@ -1988,6 +2020,7 @@ mkPState flags buf loc = .|. typeLiteralsBit `setBitIf` xopt Opt_DataKinds flags .|. explicitNamespacesBit `setBitIf` xopt Opt_ExplicitNamespaces flags .|. lambdaCaseBit `setBitIf` xopt Opt_LambdaCase flags + .|. negativeLiteralsBit `setBitIf` xopt Opt_NegativeLiterals flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 18651b97c2..9d087068bf 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -26,8 +26,16 @@ throw away inlinings as it would normally do in -O0 mode. -- CPP tricks because we want the directives in the output of the -- first CPP pass. +-- +-- Clang note, 6/17/2013 by aseipp: It is *extremely* important (for +-- some reason) that there be a line of whitespace between the two +-- definitions here, and the subsequent use of __IF_GHC_77__ - this +-- seems to be a bug in clang or something, where having the line of +-- whitespace will make the preprocessor correctly format the rendered +-- lines in the 'two step' CPP pass. No, this is not a joke. #define __IF_GHC_77__ #if __GLASGOW_HASKELL__ >= 707 -#define __ENDIF__ #endif +#define __ENDIF__ #endif + __IF_GHC_77__ -- Required on x86 to avoid the register allocator running out of -- stack slots when compiling this module with -fPIC -dynamic. @@ -51,6 +59,7 @@ import Type ( funTyCon ) import ForeignCall import OccName ( varName, dataName, tcClsName, tvName ) import DataCon ( DataCon, dataConName ) +import CoAxiom ( Role(..) ) import SrcLoc import Module import Kind ( Kind, liftedTypeKind, unliftedTypeKind, mkArrowKind ) @@ -145,7 +154,7 @@ Conflicts: 38 shift/reduce (1.25) (x::T -> T) -> .. -- Rhs is ... 10 for ambiguity in 'e :: a `b` c'. Does this mean [States 11, 253] - (e::a) `b` c, or + (e::a) `b` c, or (e :: (a `b` c)) As well as `b` we can have !, VARSYM, QCONSYM, and CONSYM, hence 5 cases Same duplication between states 11 and 253 as the previous case @@ -170,7 +179,7 @@ Conflicts: 38 shift/reduce (1.25) 1 for ambiguity when the source file starts with "-- | doc". We need another token of lookahead to determine if a top declaration or the 'module' keyword - follows. Shift parses as if the 'module' keyword follows. + follows. Shift parses as if the 'module' keyword follows. -- --------------------------------------------------------------------------- -- Adding location info @@ -221,9 +230,9 @@ incorrect. %token '_' { L _ ITunderscore } -- Haskell keywords 'as' { L _ ITas } - 'case' { L _ ITcase } - 'class' { L _ ITclass } - 'data' { L _ ITdata } + 'case' { L _ ITcase } + 'class' { L _ ITclass } + 'data' { L _ ITdata } 'default' { L _ ITdefault } 'deriving' { L _ ITderiving } 'do' { L _ ITdo } @@ -249,7 +258,7 @@ incorrect. 'forall' { L _ ITforall } -- GHC extension keywords 'foreign' { L _ ITforeign } 'export' { L _ ITexport } - 'label' { L _ ITlabel } + 'label' { L _ ITlabel } 'dynamic' { L _ ITdynamic } 'safe' { L _ ITsafe } 'interruptible' { L _ ITinterruptible } @@ -265,6 +274,9 @@ incorrect. 'group' { L _ ITgroup } -- for list transform extension 'by' { L _ ITby } -- for list transform extension 'using' { L _ ITusing } -- for list transform extension + 'N' { L _ ITnominal } -- Nominal role + 'R' { L _ ITrepresentational } -- Representational role + 'P' { L _ ITphantom } -- Phantom role '{-# INLINE' { L _ (ITinline_prag _ _) } '{-# SPECIALISE' { L _ ITspec_prag } @@ -343,7 +355,7 @@ incorrect. STRING { L _ (ITstring _) } INTEGER { L _ (ITinteger _) } RATIONAL { L _ (ITrational _) } - + PRIMCHAR { L _ (ITprimchar _) } PRIMSTRING { L _ (ITprimstring _) } PRIMINTEGER { L _ (ITprimint _) } @@ -356,11 +368,11 @@ incorrect. DOCNAMED { L _ (ITdocCommentNamed _) } DOCSECTION { L _ (ITdocSection _ _) } --- Template Haskell -'[|' { L _ ITopenExpQuote } -'[p|' { L _ ITopenPatQuote } -'[t|' { L _ ITopenTypQuote } -'[d|' { L _ ITopenDecQuote } +-- Template Haskell +'[|' { L _ ITopenExpQuote } +'[p|' { L _ ITopenPatQuote } +'[t|' { L _ ITopenTypQuote } +'[d|' { L _ ITopenDecQuote } '|]' { L _ ITcloseQuote } TH_ID_SPLICE { L _ (ITidEscape _) } -- $x '$(' { L _ ITparenEscape } -- $( exp ) @@ -461,34 +473,34 @@ header_body2 :: { [LImportDecl RdrName] } -- The Export List maybeexports :: { Maybe [LIE RdrName] } - : '(' exportlist ')' { Just $2 } + : '(' exportlist ')' { Just (fromOL $2) } | {- empty -} { Nothing } -exportlist :: { [LIE RdrName] } - : expdoclist ',' expdoclist { $1 ++ $3 } +exportlist :: { OrdList (LIE RdrName) } + : expdoclist ',' expdoclist { $1 `appOL` $3 } | exportlist1 { $1 } -exportlist1 :: { [LIE RdrName] } - : expdoclist export expdoclist ',' exportlist { $1 ++ ($2 : $3) ++ $5 } - | expdoclist export expdoclist { $1 ++ ($2 : $3) } +exportlist1 :: { OrdList (LIE RdrName) } + : expdoclist export expdoclist ',' exportlist1 { $1 `appOL` $2 `appOL` $3 `appOL` $5 } + | expdoclist export expdoclist { $1 `appOL` $2 `appOL` $3 } | expdoclist { $1 } -expdoclist :: { [LIE RdrName] } - : exp_doc expdoclist { $1 : $2 } - | {- empty -} { [] } +expdoclist :: { OrdList (LIE RdrName) } + : exp_doc expdoclist { $1 `appOL` $2 } + | {- empty -} { nilOL } -exp_doc :: { LIE RdrName } - : docsection { L1 (case (unLoc $1) of (n, doc) -> IEGroup n doc) } - | docnamed { L1 (IEDocNamed ((fst . unLoc) $1)) } - | docnext { L1 (IEDoc (unLoc $1)) } +exp_doc :: { OrdList (LIE RdrName) } + : docsection { unitOL (L1 (case (unLoc $1) of (n, doc) -> IEGroup n doc)) } + | docnamed { unitOL (L1 (IEDocNamed ((fst . unLoc) $1))) } + | docnext { unitOL (L1 (IEDoc (unLoc $1))) } -- No longer allow things like [] and (,,,) to be exported -- They are built in syntax, always available -export :: { LIE RdrName } - : qcname_ext export_subspec { LL (mkModuleImpExp (unLoc $1) - (unLoc $2)) } - | 'module' modid { LL (IEModuleContents (unLoc $2)) } +export :: { OrdList (LIE RdrName) } + : qcname_ext export_subspec { unitOL (LL (mkModuleImpExp (unLoc $1) + (unLoc $2))) } + | 'module' modid { unitOL (LL (IEModuleContents (unLoc $2))) } export_subspec :: { Located ImpExpSubSpec } : {- empty -} { L0 ImpExpAbs } @@ -523,7 +535,7 @@ importdecls :: { [LImportDecl RdrName] } | {- empty -} { [] } importdecl :: { LImportDecl RdrName } - : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec + : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec { L (comb4 $1 $6 $7 $8) $ ImportDecl { ideclName = $6, ideclPkgQual = $5 , ideclSource = $2, ideclSafe = $3 @@ -555,8 +567,8 @@ maybeimpspec :: { Located (Maybe (Bool, [LIE RdrName])) } | {- empty -} { noLoc Nothing } impspec :: { Located (Bool, [LIE RdrName]) } - : '(' exportlist ')' { LL (False, $2) } - | 'hiding' '(' exportlist ')' { LL (True, $3) } + : '(' exportlist ')' { LL (False, fromOL $2) } + | 'hiding' '(' exportlist ')' { LL (True, fromOL $3) } ----------------------------------------------------------------------------- -- Fixity Declarations @@ -594,17 +606,17 @@ topdecl :: { OrdList (LHsDecl RdrName) } | '{-# RULES' rules '#-}' { $2 } | '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ LL $ VectD (HsVect $2 $4) } | '{-# NOVECTORISE' qvar '#-}' { unitOL $ LL $ VectD (HsNoVect $2) } - | '{-# VECTORISE' 'type' gtycon '#-}' - { unitOL $ LL $ + | '{-# VECTORISE' 'type' gtycon '#-}' + { unitOL $ LL $ VectD (HsVectTypeIn False $3 Nothing) } - | '{-# VECTORISE_SCALAR' 'type' gtycon '#-}' - { unitOL $ LL $ + | '{-# VECTORISE_SCALAR' 'type' gtycon '#-}' + { unitOL $ LL $ VectD (HsVectTypeIn True $3 Nothing) } - | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}' - { unitOL $ LL $ + | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}' + { unitOL $ LL $ VectD (HsVectTypeIn False $3 (Just $5)) } - | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}' - { unitOL $ LL $ + | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}' + { unitOL $ LL $ VectD (HsVectTypeIn True $3 (Just $5)) } | '{-# VECTORISE' 'class' gtycon '#-}' { unitOL $ LL $ VectD (HsVectClassIn $3) } | annotation { unitOL $1 } @@ -612,9 +624,9 @@ topdecl :: { OrdList (LHsDecl RdrName) } -- Template Haskell Extension -- The $(..) form is one possible form of infixexp - -- but we treat an arbitrary expression just as if + -- but we treat an arbitrary expression just as if -- it had a $(..) wrapped around it - | infixexp { unitOL (LL $ mkTopSpliceDecl $1) } + | infixexp { unitOL (LL $ mkTopSpliceDecl $1) } -- Type classes -- @@ -632,30 +644,30 @@ ty_decl :: { LTyClDecl RdrName } -- Instead we just say b is out of scope -- -- Note the use of type for the head; this allows - -- infix type constructors to be declared + -- infix type constructors to be declared {% mkTySynonym (comb2 $1 $4) $2 $4 } -- type family declarations - | 'type' 'family' type opt_kind_sig + | 'type' 'family' type opt_kind_sig where_type_family -- Note the use of type for the head; this allows -- infix type constructors to be declared - {% do { L loc decl <- mkFamDecl (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) + {% do { L loc decl <- mkFamDecl (comb4 $1 $3 $4 $5) (unLoc $5) $3 (unLoc $4) ; return (L loc (FamDecl decl)) } } -- ordinary data type or newtype declaration | data_or_newtype capi_ctype tycl_hdr constrs deriving - {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3 + {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3 Nothing (reverse (unLoc $4)) (unLoc $5) } - -- We need the location on tycl_hdr in case + -- We need the location on tycl_hdr in case -- constrs and deriving are both empty -- ordinary GADT declaration - | data_or_newtype capi_ctype tycl_hdr opt_kind_sig + | data_or_newtype capi_ctype tycl_hdr opt_kind_sig gadt_constrlist deriving - {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3 + {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3 (unLoc $4) (unLoc $5) (unLoc $6) } - -- We need the location on tycl_hdr in case + -- We need the location on tycl_hdr in case -- constrs and deriving are both empty -- data/newtype family @@ -676,9 +688,6 @@ inst_decl :: { LInstDecl RdrName } {% do { L loc tfi <- mkTyFamInst (comb2 $1 $3) $3 ; return (L loc (TyFamInstD { tfid_inst = tfi })) } } - | 'type' 'instance' 'where' ty_fam_inst_eqn_list - { LL (TyFamInstD { tfid_inst = mkTyFamInstGroup (unLoc $4) }) } - -- data/newtype instance declaration | data_or_newtype 'instance' tycl_hdr constrs deriving {% do { L loc d <- mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) Nothing $3 @@ -686,21 +695,28 @@ inst_decl :: { LInstDecl RdrName } ; return (L loc (DataFamInstD { dfid_inst = d })) } } -- GADT instance declaration - | data_or_newtype 'instance' tycl_hdr opt_kind_sig + | data_or_newtype 'instance' tycl_hdr opt_kind_sig gadt_constrlist deriving {% do { L loc d <- mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) Nothing $3 (unLoc $4) (unLoc $5) (unLoc $6) ; return (L loc (DataFamInstD { dfid_inst = d })) } } - --- Type instance groups + +-- Closed type families + +where_type_family :: { Located (FamilyInfo RdrName) } + : {- empty -} { noLoc OpenTypeFamily } + | 'where' ty_fam_inst_eqn_list + { LL (ClosedTypeFamily (reverse (unLoc $2))) } ty_fam_inst_eqn_list :: { Located [LTyFamInstEqn RdrName] } : '{' ty_fam_inst_eqns '}' { LL (unLoc $2) } | vocurly ty_fam_inst_eqns close { $2 } + | '{' '..' '}' { LL [] } + | vocurly '..' close { let L loc _ = $2 in L loc [] } ty_fam_inst_eqns :: { Located [LTyFamInstEqn RdrName] } - : ty_fam_inst_eqn ';' ty_fam_inst_eqns { LL ($1 : unLoc $3) } + : ty_fam_inst_eqns ';' ty_fam_inst_eqn { LL ($3 : unLoc $1) } | ty_fam_inst_eqns ';' { LL (unLoc $1) } | ty_fam_inst_eqn { LL [$1] } @@ -708,7 +724,8 @@ ty_fam_inst_eqn :: { LTyFamInstEqn RdrName } : type '=' ctype -- Note the use of type for the head; this allows -- infix type constructors and type patterns - {% mkTyFamInstEqn (comb2 $1 $3) $1 $3 } + {% do { eqn <- mkTyFamInstEqn $1 $3 + ; return (LL eqn) } } -- Associated type family declarations -- @@ -717,14 +734,14 @@ ty_fam_inst_eqn :: { LTyFamInstEqn RdrName } -- -- * They also need to be separate from instances; otherwise, data family -- declarations without a kind signature cause parsing conflicts with empty --- data declarations. +-- data declarations. -- at_decl_cls :: { LHsDecl RdrName } -- family declarations : 'type' type opt_kind_sig -- Note the use of type for the head; this allows -- infix type constructors to be declared. - {% do { L loc decl <- mkFamDecl (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3) + {% do { L loc decl <- mkFamDecl (comb3 $1 $2 $3) OpenTypeFamily $2 (unLoc $3) ; return (L loc (TyClD (FamDecl decl))) } } | 'data' type opt_kind_sig @@ -750,14 +767,14 @@ at_decl_inst :: { LTyFamInstDecl RdrName } adt_decl_inst :: { LDataFamInstDecl RdrName } -- data/newtype instance declaration : data_or_newtype capi_ctype tycl_hdr constrs deriving - {% mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3 + {% mkFamInstData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3 Nothing (reverse (unLoc $4)) (unLoc $5) } -- GADT instance declaration - | data_or_newtype capi_ctype tycl_hdr opt_kind_sig + | data_or_newtype capi_ctype tycl_hdr opt_kind_sig gadt_constrlist deriving - {% mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3 + {% mkFamInstData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3 (unLoc $4) (unLoc $5) (unLoc $6) } data_or_newtype :: { Located NewOrData } @@ -838,7 +855,7 @@ decls_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed | decl_inst { $1 } | {- empty -} { noLoc nilOL } -decllist_inst +decllist_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed : '{' decls_inst '}' { LL (unLoc $2) } | vocurly decls_inst close { $2 } @@ -853,7 +870,7 @@ where_inst :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed -- Declarations in binding groups other than classes and instances -- -decls :: { Located (OrdList (LHsDecl RdrName)) } +decls :: { Located (OrdList (LHsDecl RdrName)) } : decls ';' decl { let { this = unLoc $3; rest = unLoc $1; these = rest `appOL` this } @@ -892,12 +909,12 @@ rules :: { OrdList (LHsDecl RdrName) } rule :: { LHsDecl RdrName } : STRING rule_activation rule_forall infixexp '=' exp - { LL $ RuleD (HsRule (getSTRING $1) - ($2 `orElse` AlwaysActive) + { LL $ RuleD (HsRule (getSTRING $1) + ($2 `orElse` AlwaysActive) $3 $4 placeHolderNames $6 placeHolderNames) } -- Rules can be specified to be NeverActive, unlike inline/specialize pragmas -rule_activation :: { Maybe Activation } +rule_activation :: { Maybe Activation } : {- empty -} { Nothing } | rule_explicit_activation { Just $1 } @@ -967,7 +984,7 @@ annotation :: { LHsDecl RdrName } fdecl :: { LHsDecl RdrName } fdecl : 'import' callconv safety fspec {% mkImport $2 $3 (unLoc $4) >>= return.LL } - | 'import' callconv fspec + | 'import' callconv fspec {% do { d <- mkImport $2 PlaySafe (unLoc $3); return (LL d) } } | 'export' callconv fspec @@ -1022,22 +1039,19 @@ sigtypes1 :: { [LHsType RdrName] } -- Always HsForAllTys ----------------------------------------------------------------------------- -- Types -infixtype :: { LHsType RdrName } - : btype qtyconop type { LL $ mkHsOpTy $1 $2 $3 } - | btype tyvarop type { LL $ mkHsOpTy $1 $2 $3 } - strict_mark :: { Located HsBang } : '!' { L1 (HsUserBang Nothing True) } | '{-# UNPACK' '#-}' { LL (HsUserBang (Just True) False) } | '{-# NOUNPACK' '#-}' { LL (HsUserBang (Just False) True) } | '{-# UNPACK' '#-}' '!' { LL (HsUserBang (Just True) True) } | '{-# NOUNPACK' '#-}' '!' { LL (HsUserBang (Just False) True) } - -- Although UNPAACK with no '!' is illegal, we get a + -- Although UNPACK with no '!' is illegal, we get a -- better error message if we parse it here -- A ctype is a for-all type ctype :: { LHsType RdrName } - : 'forall' tv_bndrs '.' ctype { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 } + : 'forall' tv_bndrs '.' ctype {% hintExplicitForall (getLoc $1) >> + return (LL $ mkExplicitHsForAllTy $2 (noLoc []) $4) } | context '=>' ctype { LL $ mkImplicitHsForAllTy $1 $3 } -- A type of form (context => type) is an *implicit* HsForAllTy | ipvar '::' type { LL (HsIParamTy (unLoc $1) $3) } @@ -1045,17 +1059,18 @@ ctype :: { LHsType RdrName } ---------------------- -- Notes for 'ctypedoc' --- It would have been nice to simplify the grammar by unifying `ctype` and +-- It would have been nice to simplify the grammar by unifying `ctype` and -- ctypedoc` into one production, allowing comments on types everywhere (and -- rejecting them after parsing, where necessary). This is however not possible -- since it leads to ambiguity. The reason is the support for comments on record --- fields: +-- fields: -- data R = R { field :: Int -- ^ comment on the field } -- If we allow comments on types here, it's not clear if the comment applies -- to 'field' or to 'Int'. So we must use `ctype` to describe the type. ctypedoc :: { LHsType RdrName } - : 'forall' tv_bndrs '.' ctypedoc { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 } + : 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >> + return (LL $ mkExplicitHsForAllTy $2 (noLoc []) $4) } | context '=>' ctypedoc { LL $ mkImplicitHsForAllTy $1 $3 } -- A type of form (context => type) is an *implicit* HsForAllTy | ipvar '::' type { LL (HsIParamTy (unLoc $1) $3) } @@ -1068,7 +1083,7 @@ ctypedoc :: { LHsType RdrName } -- (Eq a, Ord a) -- looks so much like a tuple type. We can't tell until we find the => --- We have the t1 ~ t2 form both in 'context' and in type, +-- We have the t1 ~ t2 form both in 'context' and in type, -- to permit an individual equational constraint without parenthesis. -- Thus for some reason we allow f :: a~b => blah -- but not f :: ?x::Int => blah @@ -1112,12 +1127,13 @@ atype :: { LHsType RdrName } | '{' fielddecls '}' {% checkRecordSyntax (LL $ HsRecTy $2) } -- Constructor sigs only | '(' ')' { LL $ HsTupleTy HsBoxedOrConstraintTuple [] } | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy HsBoxedOrConstraintTuple ($2:$4) } - | '(#' '#)' { LL $ HsTupleTy HsUnboxedTuple [] } + | '(#' '#)' { LL $ HsTupleTy HsUnboxedTuple [] } | '(#' comma_types1 '#)' { LL $ HsTupleTy HsUnboxedTuple $2 } | '[' ctype ']' { LL $ HsListTy $2 } | '[:' ctype ':]' { LL $ HsPArrTy $2 } | '(' ctype ')' { LL $ HsParTy $2 } | '(' ctype '::' kind ')' { LL $ HsKindSig $2 $4 } + | atype '@' role { LL $ HsRoleAnnot $1 (unLoc $3) } | quasiquote { L1 (HsQuasiQuoteTy (unLoc $1)) } | '$(' exp ')' { LL $ mkHsSpliceTy $2 } | TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $ @@ -1155,8 +1171,8 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] } | {- empty -} { [] } tv_bndr :: { LHsTyVarBndr RdrName } - : tyvar { L1 (UserTyVar (unLoc $1)) } - | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) $4) } + : tyvar { L1 (HsTyVarBndr (unLoc $1) Nothing Nothing) } + | '(' tyvar '::' kind ')' { LL (HsTyVarBndr (unLoc $2) (Just $4) Nothing) } fds :: { Located [Located (FunDep RdrName)] } : {- empty -} { noLoc [] } @@ -1174,6 +1190,11 @@ varids0 :: { Located [RdrName] } : {- empty -} { noLoc [] } | varids0 tyvar { LL (unLoc $2 : unLoc $1) } +role :: { Located Role } + : 'N' { LL Nominal } + | 'R' { LL Representational } + | 'P' { LL Phantom } + ----------------------------------------------------------------------------- -- Kinds @@ -1250,7 +1271,7 @@ gadt_constrs :: { Located [LConDecl RdrName] } gadt_constr :: { [LConDecl RdrName] } -- Returns a list because of: C,D :: ty : con_list '::' sigtype - { map (sL (comb2 $1 $3)) (mkGadtDecl (unLoc $1) $3) } + { map (sL (comb2 $1 $3)) (mkGadtDecl (unLoc $1) $3) } -- Deprecated syntax for GADT record declarations | oqtycon '{' fielddecls '}' '::' sigtype @@ -1266,12 +1287,12 @@ constrs1 :: { Located [LConDecl RdrName] } | constr { L1 [$1] } constr :: { LConDecl RdrName } - : maybe_docnext forall context '=>' constr_stuff maybe_docprev - { let (con,details) = unLoc $5 in + : maybe_docnext forall context '=>' constr_stuff maybe_docprev + { let (con,details) = unLoc $5 in addConDoc (L (comb4 $2 $3 $4 $5) (mkSimpleConDecl con (unLoc $2) $3 details)) ($1 `mplus` $6) } | maybe_docnext forall constr_stuff maybe_docprev - { let (con,details) = unLoc $3 in + { let (con,details) = unLoc $3 in addConDoc (L (comb2 $2 $3) (mkSimpleConDecl con (unLoc $2) (noLoc []) details)) ($1 `mplus` $4) } @@ -1280,7 +1301,7 @@ forall :: { Located [LHsTyVarBndr RdrName] } | {- empty -} { noLoc [] } constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) } --- We parse the constructor declaration +-- We parse the constructor declaration -- C t1 t2 -- as a btype (treating C as a type constructor) and then convert C to be -- a data constructor. Reason: it might continue like this: @@ -1301,7 +1322,7 @@ fielddecls1 :: { [ConDeclField RdrName] } | fielddecl { $1 } fielddecl :: { [ConDeclField RdrName] } -- A list because of f,g :: Int - : maybe_docnext sig_vars '::' ctype maybe_docprev { [ ConDeclField fld $4 ($1 `mplus` $5) + : maybe_docnext sig_vars '::' ctype maybe_docprev { [ ConDeclField fld $4 ($1 `mplus` $5) | fld <- reverse (unLoc $2) ] } -- We allow the odd-looking 'inst_type' in a deriving clause, so that @@ -1311,10 +1332,10 @@ fielddecl :: { [ConDeclField RdrName] } -- A list because of f,g :: Int deriving :: { Located (Maybe [LHsType RdrName]) } : {- empty -} { noLoc Nothing } | 'deriving' qtycon { let { L loc tv = $2 } - in LL (Just [L loc (HsTyVar tv)]) } + in LL (Just [L loc (HsTyVar tv)]) } | 'deriving' '(' ')' { LL (Just []) } | 'deriving' '(' inst_types1 ')' { LL (Just $3) } - -- Glasgow extension: allow partial + -- Glasgow extension: allow partial -- applications in derivings ----------------------------------------------------------------------------- @@ -1333,12 +1354,12 @@ There's an awkward overlap with a type signature. Consider ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var instead of qvar, we get another shift/reduce-conflict. Consider the following programs: - + { (^^) :: Int->Int ; } Type signature; only var allowed { (^^) :: Int->Int = ... ; } Value defn with result signature; qvar allowed (because of instance decls) - + We can't tell whether to reduce var to qvar until after we've read the signatures. -} @@ -1379,20 +1400,20 @@ gdrh :: { LGRHS RdrName (LHsExpr RdrName) } : '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 } sigdecl :: { Located (OrdList (LHsDecl RdrName)) } - : + : -- See Note [Declaration/signature overlap] for why we need infixexp here infixexp '::' sigtypedoc - {% do s <- checkValSig $1 $3 + {% do s <- checkValSig $1 $3 ; return (LL $ unitOL (LL $ SigD s)) } | var ',' sig_vars '::' sigtypedoc { LL $ toOL [ LL $ SigD (TypeSig ($1 : unLoc $3) $5) ] } | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1)))) | n <- unLoc $3 ] } - | '{-# INLINE' activation qvar '#-}' + | '{-# INLINE' activation qvar '#-}' { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) } | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}' { let inl_prag = mkInlinePragma (EmptyInlineSpec, FunLike) $2 - in LL $ toOL [ LL $ SigD (SpecSig $3 t inl_prag) + in LL $ toOL [ LL $ SigD (SpecSig $3 t inl_prag) | t <- $5] } | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma (getSPEC_INLINE $1) $2)) @@ -1400,7 +1421,7 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } | '{-# SPECIALISE' 'instance' inst_type '#-}' { LL $ unitOL (LL $ SigD (SpecInstSig $3)) } -activation :: { Maybe Activation } +activation :: { Maybe Activation } : {- empty -} { Nothing } | explicit_activation { Just $1 } @@ -1434,7 +1455,7 @@ infixexp :: { LHsExpr RdrName } | infixexp qop exp10 { LL (OpApp $1 $2 (panic "fixity") $3) } exp10 :: { LHsExpr RdrName } - : '\\' apat apats opt_asig '->' exp + : '\\' apat apats opt_asig '->' exp { LL $ HsLam (mkMatchGroup [LL $ Match ($2:$3) $4 (unguardedGRHSs $6) ]) } @@ -1461,8 +1482,8 @@ exp10 :: { LHsExpr RdrName } then HsTickPragma (unLoc $1) $2 else HsPar $2 } } - | 'proc' aexp '->' exp - {% checkPattern empty $2 >>= \ p -> + | 'proc' aexp '->' exp + {% checkPattern empty $2 >>= \ p -> checkCommand $4 >>= \ cmd -> return (LL $ HsProc p (LL $ HsCmdTop cmd placeHolderType placeHolderType undefined)) } @@ -1531,20 +1552,20 @@ aexp2 :: { LHsExpr RdrName } | '[' list ']' { LL (unLoc $2) } | '[:' parr ':]' { LL (unLoc $2) } | '_' { L1 EWildPat } - + -- Template Haskell Extension - | TH_ID_SPLICE { L1 $ HsSpliceE (mkHsSplice - (L1 $ HsVar (mkUnqual varName - (getTH_ID_SPLICE $1)))) } - | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } + | TH_ID_SPLICE { L1 $ HsSpliceE (mkHsSplice + (L1 $ HsVar (mkUnqual varName + (getTH_ID_SPLICE $1)))) } + | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } | SIMPLEQUOTE qvar { LL $ HsBracket (VarBr True (unLoc $2)) } | SIMPLEQUOTE qcon { LL $ HsBracket (VarBr True (unLoc $2)) } | TH_TY_QUOTE tyvar { LL $ HsBracket (VarBr False (unLoc $2)) } | TH_TY_QUOTE gtycon { LL $ HsBracket (VarBr False (unLoc $2)) } - | '[|' exp '|]' { LL $ HsBracket (ExpBr $2) } - | '[t|' ctype '|]' { LL $ HsBracket (TypBr $2) } + | '[|' exp '|]' { LL $ HsBracket (ExpBr $2) } + | '[t|' ctype '|]' { LL $ HsBracket (TypBr $2) } | '[p|' infixexp '|]' {% checkPattern empty $2 >>= \p -> return (LL $ HsBracket (PatBr p)) } | '[d|' cvtopbody '|]' { LL $ HsBracket (DecBrL $2) } @@ -1572,7 +1593,7 @@ cvtopdecls0 :: { [LHsDecl RdrName] } ----------------------------------------------------------------------------- -- Tuple expressions --- "texp" is short for tuple expressions: +-- "texp" is short for tuple expressions: -- things that can appear unparenthesized as long as they're -- inside parens or delimitted by commas texp :: { LHsExpr RdrName } @@ -1623,9 +1644,9 @@ list :: { LHsExpr RdrName } | texp ',' exp '..' { LL $ ArithSeq noPostTcExpr Nothing (FromThen $1 $3) } | texp '..' exp { LL $ ArithSeq noPostTcExpr Nothing (FromTo $1 $3) } | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr Nothing (FromThenTo $1 $3 $5) } - | texp '|' flattenedpquals + | texp '|' flattenedpquals {% checkMonadComp >>= \ ctxt -> - return (sL (comb2 $1 $>) $ + return (sL (comb2 $1 $>) $ mkHsComp ctxt (unLoc $3) $1) } lexps :: { Located [LHsExpr RdrName] } @@ -1638,10 +1659,10 @@ lexps :: { Located [LHsExpr RdrName] } flattenedpquals :: { Located [LStmt RdrName (LHsExpr RdrName)] } : pquals { case (unLoc $1) of [qs] -> L1 qs - -- We just had one thing in our "parallel" list so + -- We just had one thing in our "parallel" list so -- we simply return that thing directly - - qss -> L1 [L1 $ ParStmt [ParStmtBlock qs undefined noSyntaxExpr | qs <- qss] + + qss -> L1 [L1 $ ParStmt [ParStmtBlock qs undefined noSyntaxExpr | qs <- qss] noSyntaxExpr noSyntaxExpr] -- We actually found some actual parallel lists so -- we wrap them into as a ParStmt @@ -1651,7 +1672,7 @@ pquals :: { Located [[LStmt RdrName (LHsExpr RdrName)]] } : squals '|' pquals { L (getLoc $2) (reverse (unLoc $1) : unLoc $3) } | squals { L (getLoc $1) [reverse (unLoc $1)] } -squals :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- In reverse order, because the last +squals :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- In reverse order, because the last -- one can "grab" the earlier ones : squals ',' transformqual { LL [L (getLoc $3) ((unLoc $3) (reverse (unLoc $1)))] } | squals ',' qual { LL ($3 : unLoc $1) } @@ -1689,7 +1710,7 @@ transformqual :: { Located ([LStmt RdrName (LHsExpr RdrName)] -> Stmt RdrName (L parr :: { LHsExpr RdrName } : { noLoc (ExplicitPArr placeHolderType []) } | texp { L1 $ ExplicitPArr placeHolderType [$1] } - | lexps { L1 $ ExplicitPArr placeHolderType + | lexps { L1 $ ExplicitPArr placeHolderType (reverse (unLoc $1)) } | texp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) } | texp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) } @@ -1754,7 +1775,7 @@ bindpat :: { LPat RdrName } bindpat : exp {% checkPattern (text "Possibly caused by a missing 'do'?") $1 } | '!' aexp {% checkPattern (text "Possibly caused by a missing 'do'?") (LL (SectionR (L1 (HsVar bang_RDR)) $2)) } -apat :: { LPat RdrName } +apat :: { LPat RdrName } apat : aexp {% checkPattern empty $1 } | '!' aexp {% checkPattern empty (LL (SectionR (L1 (HsVar bang_RDR)) $2)) } @@ -1783,7 +1804,7 @@ stmts_help :: { Located [LStmt RdrName (LHsExpr RdrName)] } -- might be empty : ';' stmts { LL (unLoc $2) } | {- empty -} { noLoc [] } --- For typing stmts at the GHCi prompt, where +-- For typing stmts at the GHCi prompt, where -- the input may consist of just comments. maybe_stmt :: { Maybe (LStmt RdrName (LHsExpr RdrName)) } : stmt { Just $1 } @@ -1806,10 +1827,10 @@ fbinds :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) } | {- empty -} { ([], False) } fbinds1 :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) } - : fbind ',' fbinds1 { case $3 of (flds, dd) -> ($1 : flds, dd) } + : fbind ',' fbinds1 { case $3 of (flds, dd) -> ($1 : flds, dd) } | fbind { ([$1], False) } | '..' { ([], True) } - + fbind :: { HsRecField RdrName (LHsExpr RdrName) } : qvar '=' texp { HsRecField $1 $3 False } -- RHS is a 'texp', allowing view patterns (Trac #6038) @@ -1872,7 +1893,7 @@ sysdcon :: { Located DataCon } -- Wired in data constructors | '[' ']' { LL nilDataCon } conop :: { Located RdrName } - : consym { $1 } + : consym { $1 } | '`' conid '`' { LL (unLoc $2) } qconop :: { Located RdrName } @@ -1883,7 +1904,7 @@ qconop :: { Located RdrName } -- Type constructors --- See Note [Unit tuples] in HsTypes for the distinction +-- See Note [Unit tuples] in HsTypes for the distinction -- between gtycon and ntgtycon gtycon :: { Located RdrName } -- A "general" qualified tycon, including unit tuples : ntgtycon { $1 } @@ -1915,7 +1936,7 @@ qtycon :: { Located RdrName } -- Qualified or unqualified | tycon { $1 } tycon :: { Located RdrName } -- Unqualified - : CONID { L1 $! mkUnqual tcClsName (getCONID $1) } + : upcase_id { L1 $! mkUnqual tcClsName (unLoc $1) } qtyconsym :: { Located RdrName } : QCONSYM { L1 $! mkQual tcClsName (getQCONSYM $1) } @@ -1966,8 +1987,8 @@ tyvar : tyvarid { $1 } tyvarop :: { Located RdrName } tyvarop : '`' tyvarid '`' { LL (unLoc $2) } - | '.' {% parseErrorSDoc (getLoc $1) - (vcat [ptext (sLit "Illegal symbol '.' in type"), + | '.' {% parseErrorSDoc (getLoc $1) + (vcat [ptext (sLit "Illegal symbol '.' in type"), ptext (sLit "Perhaps you intended -XRankNTypes or similar flag"), ptext (sLit "to enable explicit-forall syntax: forall <tvs>. <type>")]) } @@ -1980,7 +2001,7 @@ tyvarid :: { Located RdrName } | 'interruptible' { L1 $! mkUnqual tvName (fsLit "interruptible") } ----------------------------------------------------------------------------- --- Variables +-- Variables var :: { Located RdrName } : varid { $1 } @@ -2028,10 +2049,10 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-' | special_sym { L1 $ mkUnqual varName (unLoc $1) } --- These special_ids are treated as keywords in various places, +-- These special_ids are treated as keywords in various places, -- but as ordinary ids elsewhere. 'special_id' collects all these -- except 'unsafe', 'interruptible', 'forall', and 'family' whose treatment differs --- depending on context +-- depending on context special_id :: { Located FastString } special_id : 'as' { L1 (fsLit "as") } @@ -2060,7 +2081,7 @@ qconid :: { Located RdrName } -- Qualified or unqualified | PREFIXQCONSYM { L1 $! mkQual dataName (getPREFIXQCONSYM $1) } conid :: { Located RdrName } - : CONID { L1 $ mkUnqual dataName (getCONID $1) } + : upcase_id { L1 $ mkUnqual dataName (unLoc $1) } qconsym :: { Located RdrName } -- Qualified or unqualified : consym { $1 } @@ -2097,7 +2118,7 @@ close :: { () } -- Miscellaneous (mostly renamings) modid :: { Located ModuleName } - : CONID { L1 $ mkModuleNameFS (getCONID $1) } + : upcase_id { L1 $ mkModuleNameFS (unLoc $1) } | QCONID { L1 $ let (mod,c) = getQCONID $1 in mkModuleNameFS (mkFastString @@ -2108,6 +2129,12 @@ commas :: { Int } -- One or more commas : commas ',' { $1 + 1 } | ',' { 1 } +upcase_id :: { Located FastString } + : CONID { L1 $! getCONID $1 } + | 'N' { L1 (fsLit "N") } + | 'R' { L1 (fsLit "R") } + | 'P' { L1 (fsLit "P") } + ----------------------------------------------------------------------------- -- Documentation comments @@ -2119,7 +2146,7 @@ docprev :: { LHsDocString } docnamed :: { Located (String, HsDocString) } : DOCNAMED {% - let string = getDOCNAMED $1 + let string = getDOCNAMED $1 (name, rest) = break isSpace string in return (L1 (name, HsDocString (mkFastString rest))) } @@ -2204,8 +2231,8 @@ sL span a = span `seq` a `seq` L span a -- make a point SrcSpan at line 1, column 0. Strictly speaking we should -- try to find the span of the whole file (ToDo). fileSrcSpan :: P SrcSpan -fileSrcSpan = do - l <- getSrcLoc; +fileSrcSpan = do + l <- getSrcLoc; let loc = mkSrcLoc (srcLocFile l) 1 1; return (mkSrcSpan loc loc) @@ -2215,4 +2242,15 @@ hintMultiWayIf span = do mwiEnabled <- liftM ((Opt_MultiWayIf `xopt`) . dflags) getPState unless mwiEnabled $ parseErrorSDoc span $ text "Multi-way if-expressions need -XMultiWayIf turned on" + +-- Hint about explicit-forall, assuming UnicodeSyntax is on +hintExplicitForall :: SrcSpan -> P () +hintExplicitForall span = do + forall <- extension explicitForallEnabled + rulePrag <- extension inRulePrag + unless (forall || rulePrag) $ parseErrorSDoc span $ vcat + [ text "Illegal symbol '∀' in type" + , text "Perhaps you intended -XRankNTypes or similar flag" + , text "to enable explicit-forall syntax: ∀ <tvs>. <type>" + ] } diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index 0e78794515..2a4c957039 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -270,7 +270,10 @@ exp :: { IfaceExpr } -- gaw 2004 | '%case' '(' ty ')' aexp '%of' id_bndr '{' alts1 '}' { IfaceCase $5 (fst $7) $9 } - | '%cast' aexp aty { IfaceCast $2 $3 } +-- The following line is broken and is hard to fix. Not fixing now +-- because this whole parser is bitrotten anyway. +-- Richard Eisenberg, July 2013 +-- | '%cast' aexp aty { IfaceCast $2 $3 } -- No InlineMe any more -- | '%note' STRING exp -- { case $2 of @@ -375,7 +378,7 @@ ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName) ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName -toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig +toHsTvBndr (tv,k) = noLoc $ HsTyVarBndr (mkRdrUnqual (mkTyVarOccFS tv)) (Just bsig) Nothing where bsig = toHsKind k diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 3695daef58..ea4c65357d 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -10,7 +10,7 @@ module RdrHsSyn ( mkHsDo, mkHsSplice, mkTopSpliceDecl, mkClassDecl, mkTyData, mkFamInstData, - mkTySynonym, mkTyFamInstEqn, mkTyFamInstGroup, + mkTySynonym, mkTyFamInstEqn, mkTyFamInst, mkFamDecl, splitCon, mkInlinePragma, @@ -45,7 +45,6 @@ module RdrHsSyn ( checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkDoAndIfThenElse, checkRecordSyntax, - parseError, parseErrorSDoc, -- Help with processing exports @@ -178,39 +177,31 @@ mkTySynonym loc lhs rhs ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = placeHolderNames })) } -mkTyFamInstEqn :: SrcSpan +mkTyFamInstEqn :: LHsType RdrName -> LHsType RdrName - -> LHsType RdrName - -> P (LTyFamInstEqn RdrName) -mkTyFamInstEqn loc lhs rhs + -> P (TyFamInstEqn RdrName) +mkTyFamInstEqn lhs rhs = do { (tc, tparams) <- checkTyClHdr lhs - ; return (L loc (TyFamInstEqn { tfie_tycon = tc - , tfie_pats = mkHsWithBndrs tparams - , tfie_rhs = rhs })) } + ; return (TyFamInstEqn { tfie_tycon = tc + , tfie_pats = mkHsWithBndrs tparams + , tfie_rhs = rhs }) } mkTyFamInst :: SrcSpan -> LTyFamInstEqn RdrName -> P (LTyFamInstDecl RdrName) mkTyFamInst loc eqn - = return (L loc (TyFamInstDecl { tfid_eqns = [eqn] - , tfid_group = False - , tfid_fvs = placeHolderNames })) - -mkTyFamInstGroup :: [LTyFamInstEqn RdrName] - -> TyFamInstDecl RdrName -mkTyFamInstGroup eqns = TyFamInstDecl { tfid_eqns = eqns - , tfid_group = True - , tfid_fvs = placeHolderNames } + = return (L loc (TyFamInstDecl { tfid_eqn = eqn + , tfid_fvs = placeHolderNames })) mkFamDecl :: SrcSpan - -> FamilyFlavour + -> FamilyInfo RdrName -> LHsType RdrName -- LHS -> Maybe (LHsKind RdrName) -- Optional kind signature -> P (LFamilyDecl RdrName) -mkFamDecl loc flavour lhs ksig +mkFamDecl loc info lhs ksig = do { (tc, tparams) <- checkTyClHdr lhs ; tyvars <- checkTyVars lhs tparams - ; return (L loc (FamilyDecl flavour tc tyvars ksig)) } + ; return (L loc (FamilyDecl info tc tyvars ksig)) } mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName -- If the user wrote @@ -473,10 +464,14 @@ checkTyVars tycl_hdr tparms = do { tvs <- mapM chk tparms ; return (mkHsQTvs tvs) } where -- Check that the name space is correct! + chk (L l (HsRoleAnnot (L _ (HsKindSig (L _ (HsTyVar tv)) k)) r)) + | isRdrTyVar tv = return (L l (HsTyVarBndr tv (Just k) (Just r))) chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) - | isRdrTyVar tv = return (L l (KindedTyVar tv k)) + | isRdrTyVar tv = return (L l (HsTyVarBndr tv (Just k) Nothing)) + chk (L l (HsRoleAnnot (L _ (HsTyVar tv)) r)) + | isRdrTyVar tv = return (L l (HsTyVarBndr tv Nothing (Just r))) chk (L l (HsTyVar tv)) - | isRdrTyVar tv = return (L l (UserTyVar tv)) + | isRdrTyVar tv = return (L l (HsTyVarBndr tv Nothing Nothing)) chk t@(L l _) = parseErrorSDoc l $ vcat [ sep [ ptext (sLit "Unexpected type") <+> quotes (ppr t) @@ -1090,9 +1085,6 @@ mkTypeImpExp name = -- Misc utils \begin{code} -parseError :: SrcSpan -> String -> P a -parseError span s = parseErrorSDoc span (text s) - parseErrorSDoc :: SrcSpan -> SDoc -> P a parseErrorSDoc span s = failSpanMsgP span s \end{code} diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 19acf488e0..3e5384bc5f 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -233,13 +233,13 @@ basicKnownKeyNames -- Strings and lists unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, - + -- Overloaded lists isListClassName, fromListName, fromListNName, toListName, - + -- List operations concatName, filterName, mapName, zipName, foldrName, buildName, augmentName, appendName, @@ -265,11 +265,11 @@ basicKnownKeyNames plusIntegerName, timesIntegerName, smallIntegerName, wordToIntegerName, integerToWordName, integerToIntName, minusIntegerName, - negateIntegerName, eqIntegerName, neqIntegerName, + negateIntegerName, eqIntegerPrimName, neqIntegerPrimName, absIntegerName, signumIntegerName, - leIntegerName, gtIntegerName, ltIntegerName, geIntegerName, + leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName, compareIntegerName, quotRemIntegerName, divModIntegerName, - quotIntegerName, remIntegerName, + quotIntegerName, remIntegerName, divIntegerName, modIntegerName, floatFromIntegerName, doubleFromIntegerName, encodeFloatIntegerName, encodeDoubleIntegerName, decodeDoubleIntegerName, @@ -350,8 +350,7 @@ genericTyConNames = [ pRELUDE :: Module pRELUDE = mkBaseModule_ pRELUDE_NAME -gHC_PRIM, gHC_TYPES, gHC_GENERICS, - gHC_MAGIC, +gHC_PRIM, gHC_PRIMWRAPPERS, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING, gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID, @@ -364,6 +363,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_IP :: Module gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values +gHC_PRIMWRAPPERS = mkPrimModule (fsLit "GHC.PrimWrappers") gHC_TYPES = mkPrimModule (fsLit "GHC.Types") gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic") gHC_CSTRING = mkPrimModule (fsLit "GHC.CString") @@ -558,9 +558,8 @@ unpackCString_RDR = nameRdrName unpackCStringName unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name -newStablePtr_RDR, wordDataCon_RDR :: RdrName +newStablePtr_RDR :: RdrName newStablePtr_RDR = nameRdrName newStablePtrName -wordDataCon_RDR = dataQual_RDR gHC_TYPES (fsLit "W#") bindIO_RDR, returnIO_RDR :: RdrName bindIO_RDR = nameRdrName bindIOName @@ -617,11 +616,12 @@ punc_RDR = dataQual_RDR lEX (fsLit "Punc") ident_RDR = dataQual_RDR lEX (fsLit "Ident") symbol_RDR = dataQual_RDR lEX (fsLit "Symbol") -step_RDR, alt_RDR, reset_RDR, prec_RDR :: RdrName +step_RDR, alt_RDR, reset_RDR, prec_RDR, pfail_RDR :: RdrName step_RDR = varQual_RDR rEAD_PREC (fsLit "step") alt_RDR = varQual_RDR rEAD_PREC (fsLit "+++") reset_RDR = varQual_RDR rEAD_PREC (fsLit "reset") prec_RDR = varQual_RDR rEAD_PREC (fsLit "prec") +pfail_RDR = varQual_RDR rEAD_PREC (fsLit "pfail") showList_RDR, showList___RDR, showsPrec_RDR, showString_RDR, showSpace_RDR, showParen_RDR :: RdrName @@ -798,10 +798,6 @@ stringTyConName = tcQual gHC_BASE (fsLit "String") stringTyConKey inlineIdName :: Name inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey --- The 'undefined' function. Used by supercompilation. -undefinedName :: Name -undefinedName = varQual gHC_ERR (fsLit "undefined") undefinedKey - -- Base classes (Eq, Ord, Functor) fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey @@ -885,11 +881,11 @@ integerTyConName, mkIntegerName, plusIntegerName, timesIntegerName, smallIntegerName, wordToIntegerName, integerToWordName, integerToIntName, minusIntegerName, - negateIntegerName, eqIntegerName, neqIntegerName, + negateIntegerName, eqIntegerPrimName, neqIntegerPrimName, absIntegerName, signumIntegerName, - leIntegerName, gtIntegerName, ltIntegerName, geIntegerName, + leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName, compareIntegerName, quotRemIntegerName, divModIntegerName, - quotIntegerName, remIntegerName, + quotIntegerName, remIntegerName, divIntegerName, modIntegerName, floatFromIntegerName, doubleFromIntegerName, encodeFloatIntegerName, encodeDoubleIntegerName, decodeDoubleIntegerName, @@ -910,19 +906,21 @@ integerToWordName = varQual gHC_INTEGER_TYPE (fsLit "integerToWord") int integerToIntName = varQual gHC_INTEGER_TYPE (fsLit "integerToInt") integerToIntIdKey minusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "minusInteger") minusIntegerIdKey negateIntegerName = varQual gHC_INTEGER_TYPE (fsLit "negateInteger") negateIntegerIdKey -eqIntegerName = varQual gHC_INTEGER_TYPE (fsLit "eqInteger") eqIntegerIdKey -neqIntegerName = varQual gHC_INTEGER_TYPE (fsLit "neqInteger") neqIntegerIdKey +eqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "eqInteger#") eqIntegerPrimIdKey +neqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "neqInteger#") neqIntegerPrimIdKey absIntegerName = varQual gHC_INTEGER_TYPE (fsLit "absInteger") absIntegerIdKey signumIntegerName = varQual gHC_INTEGER_TYPE (fsLit "signumInteger") signumIntegerIdKey -leIntegerName = varQual gHC_INTEGER_TYPE (fsLit "leInteger") leIntegerIdKey -gtIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gtInteger") gtIntegerIdKey -ltIntegerName = varQual gHC_INTEGER_TYPE (fsLit "ltInteger") ltIntegerIdKey -geIntegerName = varQual gHC_INTEGER_TYPE (fsLit "geInteger") geIntegerIdKey +leIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "leInteger#") leIntegerPrimIdKey +gtIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "gtInteger#") gtIntegerPrimIdKey +ltIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "ltInteger#") ltIntegerPrimIdKey +geIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "geInteger#") geIntegerPrimIdKey compareIntegerName = varQual gHC_INTEGER_TYPE (fsLit "compareInteger") compareIntegerIdKey quotRemIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger") quotRemIntegerIdKey divModIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divModInteger") divModIntegerIdKey quotIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotInteger") quotIntegerIdKey remIntegerName = varQual gHC_INTEGER_TYPE (fsLit "remInteger") remIntegerIdKey +divIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divInteger") divIntegerIdKey +modIntegerName = varQual gHC_INTEGER_TYPE (fsLit "modInteger") modIntegerIdKey floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger") floatFromIntegerIdKey doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger") doubleFromIntegerIdKey encodeFloatIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger") encodeFloatIntegerIdKey @@ -1336,11 +1334,13 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey, liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey, typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, - funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey :: Unique + funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, + eqReprPrimTyConKey :: Unique statePrimTyConKey = mkPreludeTyConUnique 50 stableNamePrimTyConKey = mkPreludeTyConUnique 51 stableNameTyConKey = mkPreludeTyConUnique 52 eqPrimTyConKey = mkPreludeTyConUnique 53 +eqReprPrimTyConKey = mkPreludeTyConUnique 54 mutVarPrimTyConKey = mkPreludeTyConUnique 55 ioTyConKey = mkPreludeTyConUnique 56 wordPrimTyConKey = mkPreludeTyConUnique 58 @@ -1594,10 +1594,10 @@ mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey, word64ToIntegerIdKey, int64ToIntegerIdKey, plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey, negateIntegerIdKey, - eqIntegerIdKey, neqIntegerIdKey, absIntegerIdKey, signumIntegerIdKey, - leIntegerIdKey, gtIntegerIdKey, ltIntegerIdKey, geIntegerIdKey, + eqIntegerPrimIdKey, neqIntegerPrimIdKey, absIntegerIdKey, signumIntegerIdKey, + leIntegerPrimIdKey, gtIntegerPrimIdKey, ltIntegerPrimIdKey, geIntegerPrimIdKey, compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey, - quotIntegerIdKey, remIntegerIdKey, + quotIntegerIdKey, remIntegerIdKey, divIntegerIdKey, modIntegerIdKey, floatFromIntegerIdKey, doubleFromIntegerIdKey, encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey, decodeDoubleIntegerIdKey, @@ -1614,44 +1614,46 @@ plusIntegerIdKey = mkPreludeMiscIdUnique 66 timesIntegerIdKey = mkPreludeMiscIdUnique 67 minusIntegerIdKey = mkPreludeMiscIdUnique 68 negateIntegerIdKey = mkPreludeMiscIdUnique 69 -eqIntegerIdKey = mkPreludeMiscIdUnique 70 -neqIntegerIdKey = mkPreludeMiscIdUnique 71 +eqIntegerPrimIdKey = mkPreludeMiscIdUnique 70 +neqIntegerPrimIdKey = mkPreludeMiscIdUnique 71 absIntegerIdKey = mkPreludeMiscIdUnique 72 signumIntegerIdKey = mkPreludeMiscIdUnique 73 -leIntegerIdKey = mkPreludeMiscIdUnique 74 -gtIntegerIdKey = mkPreludeMiscIdUnique 75 -ltIntegerIdKey = mkPreludeMiscIdUnique 76 -geIntegerIdKey = mkPreludeMiscIdUnique 77 +leIntegerPrimIdKey = mkPreludeMiscIdUnique 74 +gtIntegerPrimIdKey = mkPreludeMiscIdUnique 75 +ltIntegerPrimIdKey = mkPreludeMiscIdUnique 76 +geIntegerPrimIdKey = mkPreludeMiscIdUnique 77 compareIntegerIdKey = mkPreludeMiscIdUnique 78 -quotRemIntegerIdKey = mkPreludeMiscIdUnique 79 -divModIntegerIdKey = mkPreludeMiscIdUnique 80 -quotIntegerIdKey = mkPreludeMiscIdUnique 81 -remIntegerIdKey = mkPreludeMiscIdUnique 82 -floatFromIntegerIdKey = mkPreludeMiscIdUnique 83 -doubleFromIntegerIdKey = mkPreludeMiscIdUnique 84 -encodeFloatIntegerIdKey = mkPreludeMiscIdUnique 85 -encodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 86 -gcdIntegerIdKey = mkPreludeMiscIdUnique 87 -lcmIntegerIdKey = mkPreludeMiscIdUnique 88 -andIntegerIdKey = mkPreludeMiscIdUnique 89 -orIntegerIdKey = mkPreludeMiscIdUnique 90 -xorIntegerIdKey = mkPreludeMiscIdUnique 91 -complementIntegerIdKey = mkPreludeMiscIdUnique 92 -shiftLIntegerIdKey = mkPreludeMiscIdUnique 93 -shiftRIntegerIdKey = mkPreludeMiscIdUnique 94 -wordToIntegerIdKey = mkPreludeMiscIdUnique 95 -word64ToIntegerIdKey = mkPreludeMiscIdUnique 96 -int64ToIntegerIdKey = mkPreludeMiscIdUnique 97 -decodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 98 +quotIntegerIdKey = mkPreludeMiscIdUnique 79 +remIntegerIdKey = mkPreludeMiscIdUnique 80 +divIntegerIdKey = mkPreludeMiscIdUnique 81 +modIntegerIdKey = mkPreludeMiscIdUnique 82 +divModIntegerIdKey = mkPreludeMiscIdUnique 83 +quotRemIntegerIdKey = mkPreludeMiscIdUnique 84 +floatFromIntegerIdKey = mkPreludeMiscIdUnique 85 +doubleFromIntegerIdKey = mkPreludeMiscIdUnique 86 +encodeFloatIntegerIdKey = mkPreludeMiscIdUnique 87 +encodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 88 +gcdIntegerIdKey = mkPreludeMiscIdUnique 89 +lcmIntegerIdKey = mkPreludeMiscIdUnique 90 +andIntegerIdKey = mkPreludeMiscIdUnique 91 +orIntegerIdKey = mkPreludeMiscIdUnique 92 +xorIntegerIdKey = mkPreludeMiscIdUnique 93 +complementIntegerIdKey = mkPreludeMiscIdUnique 94 +shiftLIntegerIdKey = mkPreludeMiscIdUnique 95 +shiftRIntegerIdKey = mkPreludeMiscIdUnique 96 +wordToIntegerIdKey = mkPreludeMiscIdUnique 97 +word64ToIntegerIdKey = mkPreludeMiscIdUnique 98 +int64ToIntegerIdKey = mkPreludeMiscIdUnique 99 +decodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 100 rootMainKey, runMainKey :: Unique -rootMainKey = mkPreludeMiscIdUnique 100 -runMainKey = mkPreludeMiscIdUnique 101 +rootMainKey = mkPreludeMiscIdUnique 101 +runMainKey = mkPreludeMiscIdUnique 102 thenIOIdKey, lazyIdKey, assertErrorIdKey :: Unique -thenIOIdKey = mkPreludeMiscIdUnique 102 -lazyIdKey = mkPreludeMiscIdUnique 103 -assertErrorIdKey = mkPreludeMiscIdUnique 104 +thenIOIdKey = mkPreludeMiscIdUnique 103 +lazyIdKey = mkPreludeMiscIdUnique 104 +assertErrorIdKey = mkPreludeMiscIdUnique 105 breakpointIdKey, breakpointCondIdKey, breakpointAutoIdKey, breakpointJumpIdKey, breakpointCondJumpIdKey, @@ -1690,6 +1692,8 @@ checkDotnetResNameIdKey = mkPreludeMiscIdUnique 154 undefinedKey :: Unique undefinedKey = mkPreludeMiscIdUnique 155 +magicSingIKey :: Unique +magicSingIKey = mkPreludeMiscIdUnique 156 \end{code} Certain class operations from Prelude classes. They get their own diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 079ab0cc98..64a9f9b912 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -20,17 +20,18 @@ module PrelRules ( primOpRules, builtinRules ) where #include "HsVersions.h" #include "../includes/MachDeps.h" -import {-# SOURCE #-} MkId ( mkPrimOpId ) +import {-# SOURCE #-} MkId ( mkPrimOpId, magicSingIId ) import CoreSyn import MkCore import Id +import Var (setVarType) import Literal import CoreSubst ( exprIsLiteral_maybe ) import PrimOp ( PrimOp(..), tagToEnumKey ) import TysWiredIn import TysPrim -import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) +import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon, unwrapNewTyCon_maybe ) import DataCon ( dataConTag, dataConTyCon, dataConWorkId ) import CoreUtils ( cheapEqExpr, exprIsHNF ) import CoreUnfold ( exprIsConApp_maybe ) @@ -46,6 +47,7 @@ import BasicTypes import DynFlags import Platform import Util +import Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..)) import Control.Monad import Data.Bits as Bits @@ -195,7 +197,8 @@ primOpRules nm FloatAddOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+)) primOpRules nm FloatSubOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-)) , rightIdentity zerof ] primOpRules nm FloatMulOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*)) - , identity onef ] + , identity onef + , strengthReduction twof FloatAddOp ] -- zeroElem zerof doesn't hold because of NaN primOpRules nm FloatDivOp = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/)) , rightIdentity onef ] @@ -208,7 +211,8 @@ primOpRules nm DoubleAddOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+)) primOpRules nm DoubleSubOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-)) , rightIdentity zerod ] primOpRules nm DoubleMulOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*)) - , identity oned ] + , identity oned + , strengthReduction twod DoubleAddOp ] -- zeroElem zerod doesn't hold because of NaN primOpRules nm DoubleDivOp = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/)) , rightIdentity oned ] @@ -216,6 +220,7 @@ primOpRules nm DoubleNegOp = mkPrimOpRule nm 1 [ unaryLit negOp , inversePrimOp DoubleNegOp ] -- Relational operators + primOpRules nm IntEqOp = mkRelOpRule nm (==) [ litEq True ] primOpRules nm IntNeOp = mkRelOpRule nm (/=) [ litEq False ] primOpRules nm CharEqOp = mkRelOpRule nm (==) [ litEq True ] @@ -231,19 +236,19 @@ primOpRules nm CharGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] primOpRules nm CharLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] primOpRules nm CharLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] -primOpRules nm FloatGtOp = mkRelOpRule nm (>) [] -primOpRules nm FloatGeOp = mkRelOpRule nm (>=) [] -primOpRules nm FloatLeOp = mkRelOpRule nm (<=) [] -primOpRules nm FloatLtOp = mkRelOpRule nm (<) [] -primOpRules nm FloatEqOp = mkRelOpRule nm (==) [ litEq True ] -primOpRules nm FloatNeOp = mkRelOpRule nm (/=) [ litEq False ] +primOpRules nm FloatGtOp = mkFloatingRelOpRule nm (>) [] +primOpRules nm FloatGeOp = mkFloatingRelOpRule nm (>=) [] +primOpRules nm FloatLeOp = mkFloatingRelOpRule nm (<=) [] +primOpRules nm FloatLtOp = mkFloatingRelOpRule nm (<) [] +primOpRules nm FloatEqOp = mkFloatingRelOpRule nm (==) [ litEq True ] +primOpRules nm FloatNeOp = mkFloatingRelOpRule nm (/=) [ litEq False ] -primOpRules nm DoubleGtOp = mkRelOpRule nm (>) [] -primOpRules nm DoubleGeOp = mkRelOpRule nm (>=) [] -primOpRules nm DoubleLeOp = mkRelOpRule nm (<=) [] -primOpRules nm DoubleLtOp = mkRelOpRule nm (<) [] -primOpRules nm DoubleEqOp = mkRelOpRule nm (==) [ litEq True ] -primOpRules nm DoubleNeOp = mkRelOpRule nm (/=) [ litEq False ] +primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>) [] +primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=) [] +primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=) [] +primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<) [] +primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==) [ litEq True ] +primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=) [ litEq False ] primOpRules nm WordGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] primOpRules nm WordGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] @@ -278,14 +283,27 @@ mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) mkRelOpRule nm cmp extra = mkPrimOpRule nm 2 $ rules ++ extra where - rules = [ binaryLit (\_ -> cmpOp cmp) - , equalArgs >> + rules = [ binaryCmpLit cmp + , do equalArgs -- x `cmp` x does not depend on x, so -- compute it for the arbitrary value 'True' -- and use that result - return (if cmp True True - then trueVal - else falseVal) ] + dflags <- getDynFlags + return (if cmp True True + then trueValInt dflags + else falseValInt dflags) ] + +-- Note [Rules for floating-point comparisons] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- We need different rules for floating-point values because for floats +-- it is not true that x = x. The special case when this does not occur +-- are NaNs. + +mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) + -> [RuleM CoreExpr] -> Maybe CoreRule +mkFloatingRelOpRule nm cmp extra -- See Note [Rules for floating-point comparisons] + = mkPrimOpRule nm 2 $ binaryCmpLit cmp : extra -- common constants zeroi, onei, zerow, onew :: DynFlags -> Literal @@ -294,18 +312,20 @@ onei dflags = mkMachInt dflags 1 zerow dflags = mkMachWord dflags 0 onew dflags = mkMachWord dflags 1 -zerof, onef, zerod, oned :: Literal +zerof, onef, twof, zerod, oned, twod :: Literal zerof = mkMachFloat 0.0 onef = mkMachFloat 1.0 +twof = mkMachFloat 2.0 zerod = mkMachDouble 0.0 oned = mkMachDouble 1.0 +twod = mkMachDouble 2.0 -cmpOp :: (forall a . Ord a => a -> a -> Bool) +cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool) -> Literal -> Literal -> Maybe CoreExpr -cmpOp cmp = go +cmpOp dflags cmp = go where - done True = Just trueVal - done False = Just falseVal + done True = Just $ trueValInt dflags + done False = Just $ falseValInt dflags -- These compares are at different types go (MachChar i1) (MachChar i2) = done (i1 `cmp` i2) @@ -402,19 +422,22 @@ litEq :: Bool -- True <=> equality, False <=> inequality -> RuleM CoreExpr litEq is_eq = msum [ do [Lit lit, expr] <- getArgs - do_lit_eq lit expr + dflags <- getDynFlags + do_lit_eq dflags lit expr , do [expr, Lit lit] <- getArgs - do_lit_eq lit expr ] + dflags <- getDynFlags + do_lit_eq dflags lit expr ] where - do_lit_eq lit expr = do + do_lit_eq dflags lit expr = do guard (not (litIsLifted lit)) - return (mkWildCase expr (literalType lit) boolTy + return (mkWildCase expr (literalType lit) intPrimTy [(DEFAULT, [], val_if_neq), (LitAlt lit, [], val_if_eq)]) - val_if_eq | is_eq = trueVal - | otherwise = falseVal - val_if_neq | is_eq = falseVal - | otherwise = trueVal + where + val_if_eq | is_eq = trueValInt dflags + | otherwise = falseValInt dflags + val_if_neq | is_eq = falseValInt dflags + | otherwise = trueValInt dflags -- | Check if there is comparison with minBound or maxBound, that is @@ -429,14 +452,14 @@ boundsCmp op = do data Comparison = Gt | Ge | Lt | Le mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr -mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just falseVal -mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just trueVal -mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just trueVal -mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just falseVal -mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just trueVal -mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just falseVal -mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just falseVal -mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just trueVal +mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags +mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt dflags +mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt dflags +mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags +mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt dflags +mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags +mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags +mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dflags mkRuleFn _ _ _ _ = Nothing isMinBound :: DynFlags -> Literal -> Bool @@ -512,10 +535,10 @@ mkBasicRule op_name n_args rm = BuiltinRule { ru_name = occNameFS (nameOccName op_name), ru_fn = op_name, ru_nargs = n_args, - ru_try = \dflags _ -> runRuleM rm dflags } + ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope } newtype RuleM r = RuleM - { runRuleM :: DynFlags -> IdUnfoldingFun -> [CoreExpr] -> Maybe r } + { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r } instance Monad RuleM where return x = RuleM $ \_ _ _ -> Just x @@ -557,8 +580,8 @@ removeOp32 = mzero getArgs :: RuleM [CoreExpr] getArgs = RuleM $ \_ _ args -> Just args -getIdUnfoldingFun :: RuleM IdUnfoldingFun -getIdUnfoldingFun = RuleM $ \_ iu _ -> Just iu +getInScopeEnv :: RuleM InScopeEnv +getInScopeEnv = RuleM $ \_ iu _ -> Just iu -- return the n-th argument of this rule, if it is a literal -- argument indices start from 0 @@ -579,6 +602,11 @@ binaryLit op = do [Lit l1, Lit l2] <- getArgs liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2) +binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr +binaryCmpLit op = do + dflags <- getDynFlags + binaryLit (\_ -> cmpOp dflags op) + leftIdentity :: Literal -> RuleM CoreExpr leftIdentity id_lit = leftIdentityDynFlags (const id_lit) @@ -656,9 +684,40 @@ guardDoubleDiv = do -- is representable in Float/Double but not in (normalised) -- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead? -trueVal, falseVal :: Expr CoreBndr -trueVal = Var trueDataConId -falseVal = Var falseDataConId +strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr +strengthReduction two_lit add_op = do -- Note [Strength reduction] + arg <- msum [ do [arg, Lit mult_lit] <- getArgs + guard (mult_lit == two_lit) + return arg + , do [Lit mult_lit, arg] <- getArgs + guard (mult_lit == two_lit) + return arg ] + return $ Var (mkPrimOpId add_op) `App` arg `App` arg + +-- Note [Strength reduction] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- This rule turns floating point multiplications of the form 2.0 * x and +-- x * 2.0 into x + x addition, because addition costs less than multiplication. +-- See #7116 + +-- Note [What's true and false] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- trueValInt and falseValInt represent true and false values returned by +-- comparison primops for Char, Int, Word, Integer, Double, Float and Addr. +-- True is represented as an unboxed 1# literal, while false is represented +-- as 0# literal. +-- We still need Bool data constructors (True and False) to use in a rule +-- for constant folding of equal Strings + +trueValInt, falseValInt :: DynFlags -> Expr CoreBndr +trueValInt dflags = Lit $ onei dflags -- see Note [What's true and false] +falseValInt dflags = Lit $ zeroi dflags + +trueValBool, falseValBool :: Expr CoreBndr +trueValBool = Var trueDataConId -- see Note [What's true and false] +falseValBool = Var falseDataConId ltVal, eqVal, gtVal :: Expr CoreBndr ltVal = Var ltDataConId @@ -719,7 +778,7 @@ tagToEnumRule = do let tag = fromInteger i correct_tag dc = (dataConTag dc - fIRST_TAG) == tag (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` []) - ASSERT (null rest) return () + ASSERT(null rest) return () return $ mkTyApps (Var (dataConWorkId dc)) tc_args -- See Note [tagToEnum#] @@ -745,8 +804,8 @@ dataToTagRule = a `mplus` b b = do dflags <- getDynFlags [_, val_arg] <- getArgs - id_unf <- getIdUnfoldingFun - (dc,_,_) <- liftMaybe $ exprIsConApp_maybe id_unf val_arg + in_scope <- getInScopeEnv + (dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return () return $ mkIntVal dflags (toInteger (dataConTag dc - fIRST_TAG)) \end{code} @@ -812,11 +871,14 @@ builtinRules :: [CoreRule] builtinRules = [BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName, - ru_nargs = 4, ru_try = \_ _ -> match_append_lit }, + ru_nargs = 4, ru_try = \_ _ _ -> match_append_lit }, BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, - ru_nargs = 2, ru_try = \_ _ -> match_eq_string }, + ru_nargs = 2, ru_try = \dflags _ _ -> match_eq_string dflags }, BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, - ru_nargs = 2, ru_try = \_ _ -> match_inline }] + ru_nargs = 2, ru_try = \_ _ _ -> match_inline }, + BuiltinRule { ru_name = fsLit "MagicSingI", ru_fn = idName magicSingIId, + ru_nargs = 3, ru_try = \_ _ _ -> match_magicSingI } + ] ++ builtinIntegerRules builtinIntegerRules :: [CoreRule] @@ -833,19 +895,15 @@ builtinIntegerRules = rule_binop "minusInteger" minusIntegerName (-), rule_binop "timesInteger" timesIntegerName (*), rule_unop "negateInteger" negateIntegerName negate, - rule_binop_Bool "eqInteger" eqIntegerName (==), - rule_binop_Bool "neqInteger" neqIntegerName (/=), + rule_binop_Prim "eqInteger#" eqIntegerPrimName (==), + rule_binop_Prim "neqInteger#" neqIntegerPrimName (/=), rule_unop "absInteger" absIntegerName abs, rule_unop "signumInteger" signumIntegerName signum, - rule_binop_Bool "leInteger" leIntegerName (<=), - rule_binop_Bool "gtInteger" gtIntegerName (>), - rule_binop_Bool "ltInteger" ltIntegerName (<), - rule_binop_Bool "geInteger" geIntegerName (>=), + rule_binop_Prim "leInteger#" leIntegerPrimName (<=), + rule_binop_Prim "gtInteger#" gtIntegerPrimName (>), + rule_binop_Prim "ltInteger#" ltIntegerPrimName (<), + rule_binop_Prim "geInteger#" geIntegerPrimName (>=), rule_binop_Ordering "compareInteger" compareIntegerName compare, - rule_divop_both "divModInteger" divModIntegerName divMod, - rule_divop_both "quotRemInteger" quotRemIntegerName quotRem, - rule_divop_one "quotInteger" quotIntegerName quot, - rule_divop_one "remInteger" remIntegerName rem, rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat, rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat), rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble, @@ -861,6 +919,13 @@ builtinIntegerRules = rule_unop "complementInteger" complementIntegerName complement, rule_Int_binop "shiftLInteger" shiftLIntegerName shiftL, rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR, + -- See Note [Integer division constant folding] in libraries/base/GHC/Real.lhs + rule_divop_one "quotInteger" quotIntegerName quot, + rule_divop_one "remInteger" remIntegerName rem, + rule_divop_one "divInteger" divIntegerName div, + rule_divop_one "modInteger" modIntegerName mod, + rule_divop_both "divModInteger" divModIntegerName divMod, + rule_divop_both "quotRemInteger" quotRemIntegerName quotRem, -- These rules below don't actually have to be built in, but if we -- put them in the Haskell source then we'd have to duplicate them -- between all Integer implementations @@ -902,9 +967,9 @@ builtinIntegerRules = rule_Int_binop str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_Int_binop op } - rule_binop_Bool str name op + rule_binop_Prim str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_binop_Bool op } + ru_try = match_Integer_binop_Prim op } rule_binop_Ordering str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_binop_Ordering op } @@ -929,8 +994,8 @@ builtinIntegerRules = -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) -- = unpackFoldrCString# "foobaz" c n -match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_append_lit _ [Type ty1, +match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_append_lit [Type ty1, Lit (MachStr s1), c1, Var unpk `App` Type ty2 @@ -946,18 +1011,18 @@ match_append_lit _ [Type ty1, `App` c1 `App` n) -match_append_lit _ _ = Nothing +match_append_lit _ = Nothing --------------------------------------------------- -- The rule is this: -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2 -match_eq_string :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_eq_string :: DynFlags -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) match_eq_string _ [Var unpk1 `App` Lit (MachStr s1), - Var unpk2 `App` Lit (MachStr s2)] + Var unpk2 `App` Lit (MachStr s2)] | unpk1 `hasKey` unpackCStringIdKey, unpk2 `hasKey` unpackCStringIdKey - = Just (if s1 == s2 then trueVal else falseVal) + = Just (if s1 == s2 then trueValBool else falseValBool) match_eq_string _ _ = Nothing @@ -975,41 +1040,47 @@ match_eq_string _ _ = Nothing -- programmer can't avoid -- -- Also, don't forget about 'inline's type argument! -match_inline :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_inline _ (Type _ : e : _) +match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_inline (Type _ : e : _) | (Var f, args1) <- collectArgs e, Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) -- Ignore the IdUnfoldingFun here! = Just (mkApps unf args1) -match_inline _ _ = Nothing +match_inline _ = Nothing + + +-- See Note [magicSingIId magic] in `basicTypes/MkId.lhs` +-- for a description of what is going on here. +match_magicSingI :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_magicSingI (Type t : e : Lam b _ : _) + | ((_ : _ : fu : _),_) <- splitFunTys t + , (sI_type,_) <- splitFunTy fu + , Just (sI_tc,xs) <- splitTyConApp_maybe sI_type + , Just (_,_,co) <- unwrapNewTyCon_maybe sI_tc + = Just $ let f = setVarType b fu + in Lam f $ Var f `App` Cast e (mkSymCo (mkUnbranchedAxInstCo Representational co xs)) + +match_magicSingI _ = Nothing ------------------------------------------------- -- Integer rules --- smallInteger (79::Int#) = 79::Integer --- wordToInteger (79::Word#) = 79::Integer +-- smallInteger (79::Int#) = 79::Integer +-- wordToInteger (79::Word#) = 79::Integer -- Similarly Int64, Word64 -match_IntToInteger :: DynFlags - -> Id - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) -match_IntToInteger _ id id_unf [xl] +match_IntToInteger :: RuleFun +match_IntToInteger _ id_unf fn [xl] | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl - = case idType id of + = case idType fn of FunTy _ integerTy -> Just (Lit (LitInteger x integerTy)) _ -> panic "match_IntToInteger: Id has the wrong type" match_IntToInteger _ _ _ _ = Nothing -match_WordToInteger :: DynFlags - -> Id - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) -match_WordToInteger _ id id_unf [xl] +match_WordToInteger :: RuleFun +match_WordToInteger _ id_unf id [xl] | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl = case idType id of FunTy _ integerTy -> @@ -1018,12 +1089,8 @@ match_WordToInteger _ id id_unf [xl] panic "match_WordToInteger: Id has the wrong type" match_WordToInteger _ _ _ _ = Nothing -match_Int64ToInteger :: DynFlags - -> Id - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) -match_Int64ToInteger _ id id_unf [xl] +match_Int64ToInteger :: RuleFun +match_Int64ToInteger _ id_unf id [xl] | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl = case idType id of FunTy _ integerTy -> @@ -1032,12 +1099,8 @@ match_Int64ToInteger _ id id_unf [xl] panic "match_Int64ToInteger: Id has the wrong type" match_Int64ToInteger _ _ _ _ = Nothing -match_Word64ToInteger :: DynFlags - -> Id - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) -match_Word64ToInteger _ id id_unf [xl] +match_Word64ToInteger :: RuleFun +match_Word64ToInteger _ id_unf id [xl] | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl = case idType id of FunTy _ integerTy -> @@ -1049,47 +1112,29 @@ match_Word64ToInteger _ _ _ _ = Nothing ------------------------------------------------- match_Integer_convert :: Num a => (DynFlags -> a -> Expr CoreBndr) - -> DynFlags - -> Id - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) -match_Integer_convert convert dflags _ id_unf [xl] + -> RuleFun +match_Integer_convert convert dflags id_unf _ [xl] | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl = Just (convert dflags (fromInteger x)) match_Integer_convert _ _ _ _ _ = Nothing -match_Integer_unop :: (Integer -> Integer) - -> DynFlags - -> Id - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) -match_Integer_unop unop _ _ id_unf [xl] +match_Integer_unop :: (Integer -> Integer) -> RuleFun +match_Integer_unop unop _ id_unf _ [xl] | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl = Just (Lit (LitInteger (unop x) i)) match_Integer_unop _ _ _ _ _ = Nothing -match_Integer_binop :: (Integer -> Integer -> Integer) - -> DynFlags - -> Id - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) -match_Integer_binop binop _ _ id_unf [xl,yl] +match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun +match_Integer_binop binop _ id_unf _ [xl,yl] | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl = Just (Lit (LitInteger (x `binop` y) i)) match_Integer_binop _ _ _ _ _ = Nothing -- This helper is used for the quotRem and divMod functions -match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer)) - -> DynFlags - -> Id - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) -match_Integer_divop_both divop _ _ id_unf [xl,yl] +match_Integer_divop_both + :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun +match_Integer_divop_both divop _ id_unf _ [xl,yl] | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl , y /= 0 @@ -1101,51 +1146,31 @@ match_Integer_divop_both divop _ _ id_unf [xl,yl] Lit (LitInteger s t)] match_Integer_divop_both _ _ _ _ _ = Nothing --- This helper is used for the quotRem and divMod functions -match_Integer_divop_one :: (Integer -> Integer -> Integer) - -> DynFlags - -> Id - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) -match_Integer_divop_one divop _ _ id_unf [xl,yl] +-- This helper is used for the quot and rem functions +match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun +match_Integer_divop_one divop _ id_unf _ [xl,yl] | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl , y /= 0 = Just (Lit (LitInteger (x `divop` y) i)) match_Integer_divop_one _ _ _ _ _ = Nothing -match_Integer_Int_binop :: (Integer -> Int -> Integer) - -> DynFlags - -> Id - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) -match_Integer_Int_binop binop _ _ id_unf [xl,yl] +match_Integer_Int_binop :: (Integer -> Int -> Integer) -> RuleFun +match_Integer_Int_binop binop _ id_unf _ [xl,yl] | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl = Just (Lit (LitInteger (x `binop` fromIntegral y) i)) match_Integer_Int_binop _ _ _ _ _ = Nothing -match_Integer_binop_Bool :: (Integer -> Integer -> Bool) - -> DynFlags - -> Id - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) -match_Integer_binop_Bool binop _ _ id_unf [xl, yl] +match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun +match_Integer_binop_Prim binop dflags id_unf _ [xl, yl] | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl - = Just (if x `binop` y then trueVal else falseVal) -match_Integer_binop_Bool _ _ _ _ _ = Nothing - -match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) - -> DynFlags - -> Id - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) -match_Integer_binop_Ordering binop _ _ id_unf [xl, yl] + = Just (if x `binop` y then trueValInt dflags else falseValInt dflags) +match_Integer_binop_Prim _ _ _ _ _ = Nothing + +match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun +match_Integer_binop_Ordering binop _ id_unf _ [xl, yl] | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl = Just $ case x `binop` y of @@ -1156,12 +1181,8 @@ match_Integer_binop_Ordering _ _ _ _ _ = Nothing match_Integer_Int_encodeFloat :: RealFloat a => (a -> Expr CoreBndr) - -> DynFlags - -> Id - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) -match_Integer_Int_encodeFloat mkLit _ _ id_unf [xl,yl] + -> RuleFun +match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl] | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl = Just (mkLit $ encodeFloat x (fromInteger y)) @@ -1179,24 +1200,16 @@ match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing -- NaN or +-Inf match_rationalTo :: RealFloat a => (a -> Expr CoreBndr) - -> DynFlags - -> Id - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) -match_rationalTo mkLit _ _ id_unf [xl, yl] + -> RuleFun +match_rationalTo mkLit _ id_unf _ [xl, yl] | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl , y /= 0 = Just (mkLit (fromRational (x % y))) match_rationalTo _ _ _ _ _ = Nothing -match_decodeDouble :: DynFlags - -> Id - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) -match_decodeDouble _ fn id_unf [xl] +match_decodeDouble :: RuleFun +match_decodeDouble _ id_unf fn [xl] | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl = case idType fn of FunTy _ (TyConApp _ [integerTy, intHashTy]) -> @@ -1211,23 +1224,13 @@ match_decodeDouble _ fn id_unf [xl] panic "match_decodeDouble: Id has the wrong type" match_decodeDouble _ _ _ _ = Nothing -match_XToIntegerToX :: Name - -> DynFlags - -> Id - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) +match_XToIntegerToX :: Name -> RuleFun match_XToIntegerToX n _ _ _ [App (Var x) y] | idName x == n = Just y match_XToIntegerToX _ _ _ _ _ = Nothing -match_smallIntegerTo :: PrimOp - -> DynFlags - -> Id - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) +match_smallIntegerTo :: PrimOp -> RuleFun match_smallIntegerTo primOp _ _ _ [App (Var x) y] | idName x == smallIntegerName = Just $ App (Var (mkPrimOpId primOp)) y diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs index 1aaca36274..8b1970c37f 100644 --- a/compiler/prelude/PrimOp.lhs +++ b/compiler/prelude/PrimOp.lhs @@ -118,9 +118,8 @@ data PrimOpInfo Type | Monadic OccName -- string :: T -> T Type - | Compare OccName -- string :: T -> T -> Bool + | Compare OccName -- string :: T -> T -> Int# Type - | GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T [TyVar] [Type] @@ -513,10 +512,10 @@ primOpSig op arity = length arg_tys (tyvars, arg_tys, res_ty) = case (primOpInfo op) of - Monadic _occ ty -> ([], [ty], ty ) - Dyadic _occ ty -> ([], [ty,ty], ty ) - Compare _occ ty -> ([], [ty,ty], boolTy) - GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty) + Monadic _occ ty -> ([], [ty], ty ) + Dyadic _occ ty -> ([], [ty,ty], ty ) + Compare _occ ty -> ([], [ty,ty], intPrimTy) + GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty ) \end{code} \begin{code} @@ -533,7 +532,7 @@ getPrimOpResultInfo op = case (primOpInfo op) of Dyadic _ ty -> ReturnsPrim (typePrimRep ty) Monadic _ ty -> ReturnsPrim (typePrimRep ty) - Compare _ _ -> ReturnsAlg boolTyCon + Compare _ _ -> ReturnsPrim (tyConPrimRep intPrimTyCon) GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep tc) | otherwise -> ReturnsAlg tc where @@ -560,7 +559,7 @@ Utils: dyadic_fun_ty, monadic_fun_ty, compare_fun_ty :: Type -> Type dyadic_fun_ty ty = mkFunTys [ty, ty] ty monadic_fun_ty ty = mkFunTy ty ty -compare_fun_ty ty = mkFunTys [ty, ty] boolTy +compare_fun_ty ty = mkFunTys [ty, ty] intPrimTy \end{code} Output stuff: diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index c59884ba33..f166065b22 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -71,6 +71,7 @@ module TysPrim( word64PrimTyCon, word64PrimTy, eqPrimTyCon, -- ty1 ~# ty2 + eqReprPrimTyCon, -- ty1 ~R# ty2 (at role Representational) -- * Any anyTy, anyTyCon, anyTypeOfKind, @@ -134,6 +135,7 @@ primTyCons , word64PrimTyCon , anyTyCon , eqPrimTyCon + , eqReprPrimTyCon , liftedTypeKindTyCon , unliftedTypeKindTyCon @@ -155,7 +157,7 @@ mkPrimTc fs unique tycon (ATyCon tycon) -- Relevant TyCon UserSyntax -- None are built-in syntax -charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, floatX4PrimTyConName, doubleX2PrimTyConName, int32X4PrimTyConName, int64X2PrimTyConName :: Name +charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, floatX4PrimTyConName, doubleX2PrimTyConName, int32X4PrimTyConName, int64X2PrimTyConName :: Name charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon @@ -168,6 +170,7 @@ floatPrimTyConName = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatP doublePrimTyConName = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon eqPrimTyConName = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon +eqReprPrimTyConName = mkPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon @@ -346,7 +349,7 @@ mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ) \begin{code} kindTyConType :: TyCon -> Type -kindTyConType kind = TyConApp kind [] +kindTyConType kind = TyConApp kind [] -- mkTyConApp isn't defined yet -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, superKind :: Kind @@ -375,16 +378,16 @@ mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds \begin{code} -- only used herein -pcPrimTyCon :: Name -> Int -> PrimRep -> TyCon -pcPrimTyCon name arity rep - = mkPrimTyCon name kind arity rep +pcPrimTyCon :: Name -> [Role] -> PrimRep -> TyCon +pcPrimTyCon name roles rep + = mkPrimTyCon name kind roles rep where - kind = mkArrowKinds (replicate arity liftedTypeKind) result_kind + kind = mkArrowKinds (map (const liftedTypeKind) roles) result_kind result_kind = unliftedTypeKind pcPrimTyCon0 :: Name -> PrimRep -> TyCon pcPrimTyCon0 name rep - = mkPrimTyCon name result_kind 0 rep + = mkPrimTyCon name result_kind [] rep where result_kind = unliftedTypeKind @@ -469,19 +472,34 @@ or where s is a type variable. The only purpose of the type parameter is to keep different state threads separate. It is represented by nothing at all. +The type parameter to State# is intended to keep separate threads separate. +Even though this parameter is not used in the definition of State#, it is +given role Nominal to enforce its intended use. + \begin{code} mkStatePrimTy :: Type -> Type -mkStatePrimTy ty = mkNakedTyConApp statePrimTyCon [ty] +mkStatePrimTy ty = TyConApp statePrimTyCon [ty] statePrimTyCon :: TyCon -- See Note [The State# TyCon] -statePrimTyCon = pcPrimTyCon statePrimTyConName 1 VoidRep +statePrimTyCon = pcPrimTyCon statePrimTyConName [Nominal] VoidRep eqPrimTyCon :: TyCon -- The representation type for equality predicates -- See Note [The ~# TyCon] -eqPrimTyCon = mkPrimTyCon eqPrimTyConName kind 3 VoidRep +eqPrimTyCon = mkPrimTyCon eqPrimTyConName kind [Nominal, Nominal, Nominal] VoidRep where kind = ForAllTy kv $ mkArrowKinds [k, k] unliftedTypeKind kv = kKiVar k = mkTyVarTy kv + +-- like eqPrimTyCon, but the type for *Representational* coercions +-- this should only ever appear as the type of a covar. Its role is +-- interpreted in coercionRole +eqReprPrimTyCon :: TyCon +eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName kind + -- the roles really should be irrelevant! + [Nominal, Representational, Representational] VoidRep + where kind = ForAllTy kv $ mkArrowKinds [k, k] unliftedTypeKind + kv = kKiVar + k = mkTyVarTy kv \end{code} RealWorld is deeply magical. It is *primitive*, but it is not @@ -490,7 +508,7 @@ RealWorld; it's only used in the type system, to parameterise State#. \begin{code} realWorldTyCon :: TyCon -realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName liftedTypeKind 0 PtrRep +realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName liftedTypeKind [] PtrRep realWorldTy :: Type realWorldTy = mkTyConTy realWorldTyCon realWorldStatePrimTy :: Type @@ -509,25 +527,25 @@ defined in \tr{TysWiredIn.lhs}, not here. \begin{code} arrayPrimTyCon, mutableArrayPrimTyCon, mutableByteArrayPrimTyCon, byteArrayPrimTyCon, arrayArrayPrimTyCon, mutableArrayArrayPrimTyCon :: TyCon -arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName 1 PtrRep -mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName 2 PtrRep -mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName 1 PtrRep -byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName PtrRep -arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName PtrRep -mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName 1 PtrRep +arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName [Representational] PtrRep +mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName [Nominal, Representational] PtrRep +mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName [Nominal] PtrRep +byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName PtrRep +arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName PtrRep +mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName [Nominal] PtrRep mkArrayPrimTy :: Type -> Type -mkArrayPrimTy elt = mkNakedTyConApp arrayPrimTyCon [elt] +mkArrayPrimTy elt = TyConApp arrayPrimTyCon [elt] byteArrayPrimTy :: Type byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon mkArrayArrayPrimTy :: Type mkArrayArrayPrimTy = mkTyConTy arrayArrayPrimTyCon mkMutableArrayPrimTy :: Type -> Type -> Type -mkMutableArrayPrimTy s elt = mkNakedTyConApp mutableArrayPrimTyCon [s, elt] +mkMutableArrayPrimTy s elt = TyConApp mutableArrayPrimTyCon [s, elt] mkMutableByteArrayPrimTy :: Type -> Type -mkMutableByteArrayPrimTy s = mkNakedTyConApp mutableByteArrayPrimTyCon [s] +mkMutableByteArrayPrimTy s = TyConApp mutableByteArrayPrimTyCon [s] mkMutableArrayArrayPrimTy :: Type -> Type -mkMutableArrayArrayPrimTy s = mkNakedTyConApp mutableArrayArrayPrimTyCon [s] +mkMutableArrayArrayPrimTy s = TyConApp mutableArrayArrayPrimTyCon [s] \end{code} %************************************************************************ @@ -538,10 +556,10 @@ mkMutableArrayArrayPrimTy s = mkNakedTyConApp mutableArrayArrayPrimTyCon [s] \begin{code} mutVarPrimTyCon :: TyCon -mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName 2 PtrRep +mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName [Nominal, Representational] PtrRep mkMutVarPrimTy :: Type -> Type -> Type -mkMutVarPrimTy s elt = mkNakedTyConApp mutVarPrimTyCon [s, elt] +mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [s, elt] \end{code} %************************************************************************ @@ -552,10 +570,10 @@ mkMutVarPrimTy s elt = mkNakedTyConApp mutVarPrimTyCon [s, elt] \begin{code} mVarPrimTyCon :: TyCon -mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName 2 PtrRep +mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName [Nominal, Representational] PtrRep mkMVarPrimTy :: Type -> Type -> Type -mkMVarPrimTy s elt = mkNakedTyConApp mVarPrimTyCon [s, elt] +mkMVarPrimTy s elt = TyConApp mVarPrimTyCon [s, elt] \end{code} %************************************************************************ @@ -566,10 +584,10 @@ mkMVarPrimTy s elt = mkNakedTyConApp mVarPrimTyCon [s, elt] \begin{code} tVarPrimTyCon :: TyCon -tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName 2 PtrRep +tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName [Nominal, Representational] PtrRep mkTVarPrimTy :: Type -> Type -> Type -mkTVarPrimTy s elt = mkNakedTyConApp tVarPrimTyCon [s, elt] +mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [s, elt] \end{code} %************************************************************************ @@ -580,10 +598,10 @@ mkTVarPrimTy s elt = mkNakedTyConApp tVarPrimTyCon [s, elt] \begin{code} stablePtrPrimTyCon :: TyCon -stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName 1 AddrRep +stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName [Representational] AddrRep mkStablePtrPrimTy :: Type -> Type -mkStablePtrPrimTy ty = mkNakedTyConApp stablePtrPrimTyCon [ty] +mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [ty] \end{code} %************************************************************************ @@ -594,10 +612,10 @@ mkStablePtrPrimTy ty = mkNakedTyConApp stablePtrPrimTyCon [ty] \begin{code} stableNamePrimTyCon :: TyCon -stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName 1 PtrRep +stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName [Representational] PtrRep mkStableNamePrimTy :: Type -> Type -mkStableNamePrimTy ty = mkNakedTyConApp stableNamePrimTyCon [ty] +mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty] \end{code} %************************************************************************ @@ -621,10 +639,10 @@ bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName PtrRep \begin{code} weakPrimTyCon :: TyCon -weakPrimTyCon = pcPrimTyCon weakPrimTyConName 1 PtrRep +weakPrimTyCon = pcPrimTyCon weakPrimTyConName [Representational] PtrRep mkWeakPrimTy :: Type -> Type -mkWeakPrimTy v = mkNakedTyConApp weakPrimTyCon [v] +mkWeakPrimTy v = TyConApp weakPrimTyCon [v] \end{code} %************************************************************************ @@ -727,10 +745,11 @@ anyTy :: Type anyTy = mkTyConTy anyTyCon anyTyCon :: TyCon -anyTyCon = mkLiftedPrimTyCon anyTyConName kind 1 PtrRep +anyTyCon = mkLiftedPrimTyCon anyTyConName kind [Nominal] PtrRep where kind = ForAllTy kKiVar (mkTyVarTy kKiVar) {- Can't do this yet without messing up kind proxies +-- RAE: I think you can now. anyTyCon :: TyCon anyTyCon = mkSynTyCon anyTyConName kind [kKiVar] syn_rhs @@ -742,7 +761,7 @@ anyTyCon = mkSynTyCon anyTyConName kind [kKiVar] -} anyTypeOfKind :: Kind -> Type -anyTypeOfKind kind = mkNakedTyConApp anyTyCon [kind] +anyTypeOfKind kind = TyConApp anyTyCon [kind] \end{code} %************************************************************************ diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index b8c0e34174..b563b25cc4 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -236,12 +236,15 @@ pcNonRecDataTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon -- Not an enumeration, not promotable pcNonRecDataTyCon = pcTyCon False NonRecursive False +-- This function assumes that the types it creates have all parameters at +-- Representational role! pcTyCon :: Bool -> RecFlag -> Bool -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon pcTyCon is_enum is_rec is_prom name cType tyvars cons = tycon where tycon = buildAlgTyCon name tyvars + (map (const Representational) tyvars) cType [] -- No stupid theta (DataTyCon cons is_enum) @@ -425,6 +428,7 @@ eqTyCon :: TyCon eqTyCon = mkAlgTyCon eqTyConName (ForAllTy kv $ mkArrowKinds [k, k] constraintKind) [kv, a, b] + [Nominal, Nominal, Nominal] Nothing [] -- No stupid theta (DataTyCon [eqBoxDataCon] False) diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 45472816c0..e275b23778 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -140,19 +140,19 @@ section "Char#" primtype Char# -primop CharGtOp "gtChar#" Compare Char# -> Char# -> Bool -primop CharGeOp "geChar#" Compare Char# -> Char# -> Bool +primop CharGtOp "gtCharI#" Compare Char# -> Char# -> Int# +primop CharGeOp "geCharI#" Compare Char# -> Char# -> Int# -primop CharEqOp "eqChar#" Compare - Char# -> Char# -> Bool +primop CharEqOp "eqCharI#" Compare + Char# -> Char# -> Int# with commutable = True -primop CharNeOp "neChar#" Compare - Char# -> Char# -> Bool +primop CharNeOp "neCharI#" Compare + Char# -> Char# -> Int# with commutable = True -primop CharLtOp "ltChar#" Compare Char# -> Char# -> Bool -primop CharLeOp "leChar#" Compare Char# -> Char# -> Bool +primop CharLtOp "ltCharI#" Compare Char# -> Char# -> Int# +primop CharLeOp "leCharI#" Compare Char# -> Char# -> Int# primop OrdOp "ord#" GenPrimOp Char# -> Int# with code_size = 0 @@ -239,26 +239,26 @@ primop IntSubCOp "subIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) second member is 0 iff no overflow occured.} with code_size = 2 -primop IntGtOp ">#" Compare Int# -> Int# -> Bool +primop IntGtOp ">$#" Compare Int# -> Int# -> Int# with fixity = infix 4 -primop IntGeOp ">=#" Compare Int# -> Int# -> Bool +primop IntGeOp ">=$#" Compare Int# -> Int# -> Int# with fixity = infix 4 -primop IntEqOp "==#" Compare - Int# -> Int# -> Bool +primop IntEqOp "==$#" Compare + Int# -> Int# -> Int# with commutable = True fixity = infix 4 -primop IntNeOp "/=#" Compare - Int# -> Int# -> Bool +primop IntNeOp "/=$#" Compare + Int# -> Int# -> Int# with commutable = True fixity = infix 4 -primop IntLtOp "<#" Compare Int# -> Int# -> Bool +primop IntLtOp "<$#" Compare Int# -> Int# -> Int# with fixity = infix 4 -primop IntLeOp "<=#" Compare Int# -> Int# -> Bool +primop IntLeOp "<=$#" Compare Int# -> Int# -> Int# with fixity = infix 4 primop ChrOp "chr#" GenPrimOp Int# -> Char# @@ -345,12 +345,12 @@ primop SrlOp "uncheckedShiftRL#" GenPrimOp Word# -> Int# -> Word# primop Word2IntOp "word2Int#" GenPrimOp Word# -> Int# with code_size = 0 -primop WordGtOp "gtWord#" Compare Word# -> Word# -> Bool -primop WordGeOp "geWord#" Compare Word# -> Word# -> Bool -primop WordEqOp "eqWord#" Compare Word# -> Word# -> Bool -primop WordNeOp "neWord#" Compare Word# -> Word# -> Bool -primop WordLtOp "ltWord#" Compare Word# -> Word# -> Bool -primop WordLeOp "leWord#" Compare Word# -> Word# -> Bool +primop WordGtOp "gtWordI#" Compare Word# -> Word# -> Int# +primop WordGeOp "geWordI#" Compare Word# -> Word# -> Int# +primop WordEqOp "eqWordI#" Compare Word# -> Word# -> Int# +primop WordNeOp "neWordI#" Compare Word# -> Word# -> Int# +primop WordLtOp "ltWordI#" Compare Word# -> Word# -> Int# +primop WordLeOp "leWordI#" Compare Word# -> Word# -> Int# primop PopCnt8Op "popCnt8#" Monadic Word# -> Word# {Count the number of set bits in the lower 8 bits of a word.} @@ -363,6 +363,15 @@ primop PopCnt64Op "popCnt64#" GenPrimOp WORD64 -> Word# primop PopCntOp "popCnt#" Monadic Word# -> Word# {Count the number of set bits in a word.} +primop BSwap16Op "byteSwap16#" Monadic Word# -> Word# + {Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. } +primop BSwap32Op "byteSwap32#" Monadic Word# -> Word# + {Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. } +primop BSwap64Op "byteSwap64#" Monadic WORD64 -> WORD64 + {Swap bytes in a 64 bits of a word.} +primop BSwapOp "byteSwap#" Monadic Word# -> Word# + {Swap bytes in a word.} + ------------------------------------------------------------------------ section "Narrowings" {Explicit narrowing of native-sized ints or words.} @@ -426,26 +435,26 @@ section "Double#" primtype Double# -primop DoubleGtOp ">##" Compare Double# -> Double# -> Bool +primop DoubleGtOp ">$##" Compare Double# -> Double# -> Int# with fixity = infix 4 -primop DoubleGeOp ">=##" Compare Double# -> Double# -> Bool +primop DoubleGeOp ">=$##" Compare Double# -> Double# -> Int# with fixity = infix 4 -primop DoubleEqOp "==##" Compare - Double# -> Double# -> Bool +primop DoubleEqOp "==$##" Compare + Double# -> Double# -> Int# with commutable = True fixity = infix 4 -primop DoubleNeOp "/=##" Compare - Double# -> Double# -> Bool +primop DoubleNeOp "/=$##" Compare + Double# -> Double# -> Int# with commutable = True fixity = infix 4 -primop DoubleLtOp "<##" Compare Double# -> Double# -> Bool +primop DoubleLtOp "<$##" Compare Double# -> Double# -> Int# with fixity = infix 4 -primop DoubleLeOp "<=##" Compare Double# -> Double# -> Bool +primop DoubleLeOp "<=$##" Compare Double# -> Double# -> Int# with fixity = infix 4 primop DoubleAddOp "+##" Dyadic @@ -559,19 +568,19 @@ section "Float#" primtype Float# -primop FloatGtOp "gtFloat#" Compare Float# -> Float# -> Bool -primop FloatGeOp "geFloat#" Compare Float# -> Float# -> Bool +primop FloatGtOp "gtFloatI#" Compare Float# -> Float# -> Int# +primop FloatGeOp "geFloatI#" Compare Float# -> Float# -> Int# -primop FloatEqOp "eqFloat#" Compare - Float# -> Float# -> Bool +primop FloatEqOp "eqFloatI#" Compare + Float# -> Float# -> Int# with commutable = True -primop FloatNeOp "neFloat#" Compare - Float# -> Float# -> Bool +primop FloatNeOp "neFloatI#" Compare + Float# -> Float# -> Int# with commutable = True -primop FloatLtOp "ltFloat#" Compare Float# -> Float# -> Bool -primop FloatLeOp "leFloat#" Compare Float# -> Float# -> Bool +primop FloatLtOp "ltFloatI#" Compare Float# -> Float# -> Int# +primop FloatLeOp "leFloatI#" Compare Float# -> Float# -> Int# primop FloatAddOp "plusFloat#" Dyadic Float# -> Float# -> Float# @@ -689,7 +698,7 @@ primop NewArrayOp "newArray#" GenPrimOp has_side_effects = True primop SameMutableArrayOp "sameMutableArray#" GenPrimOp - MutableArray# s a -> MutableArray# s a -> Bool + MutableArray# s a -> MutableArray# s a -> Int# primop ReadArrayOp "readArray#" GenPrimOp MutableArray# s a -> Int# -> State# s -> (# State# s, a #) @@ -828,7 +837,7 @@ primop ByteArrayContents_Char "byteArrayContents#" GenPrimOp {Intended for use with pinned arrays; otherwise very unsafe!} primop SameMutableByteArrayOp "sameMutableByteArray#" GenPrimOp - MutableByteArray# s -> MutableByteArray# s -> Bool + MutableByteArray# s -> MutableByteArray# s -> Int# primop UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp MutableByteArray# s -> State# s -> (# State# s, ByteArray# #) @@ -1124,7 +1133,7 @@ primop NewArrayArrayOp "newArrayArray#" GenPrimOp has_side_effects = True primop SameMutableArrayArrayOp "sameMutableArrayArray#" GenPrimOp - MutableArrayArray# s -> MutableArrayArray# s -> Bool + MutableArrayArray# s -> MutableArrayArray# s -> Int# primop UnsafeFreezeArrayArrayOp "unsafeFreezeArrayArray#" GenPrimOp MutableArrayArray# s -> State# s -> (# State# s, ArrayArray# #) @@ -1235,12 +1244,12 @@ primop Int2AddrOp "int2Addr#" GenPrimOp Int# -> Addr# with code_size = 0 #endif -primop AddrGtOp "gtAddr#" Compare Addr# -> Addr# -> Bool -primop AddrGeOp "geAddr#" Compare Addr# -> Addr# -> Bool -primop AddrEqOp "eqAddr#" Compare Addr# -> Addr# -> Bool -primop AddrNeOp "neAddr#" Compare Addr# -> Addr# -> Bool -primop AddrLtOp "ltAddr#" Compare Addr# -> Addr# -> Bool -primop AddrLeOp "leAddr#" Compare Addr# -> Addr# -> Bool +primop AddrGtOp "gtAddrI#" Compare Addr# -> Addr# -> Int# +primop AddrGeOp "geAddrI#" Compare Addr# -> Addr# -> Int# +primop AddrEqOp "eqAddrI#" Compare Addr# -> Addr# -> Int# +primop AddrNeOp "neAddrI#" Compare Addr# -> Addr# -> Int# +primop AddrLtOp "ltAddrI#" Compare Addr# -> Addr# -> Int# +primop AddrLeOp "leAddrI#" Compare Addr# -> Addr# -> Int# primop IndexOffAddrOp_Char "indexCharOffAddr#" GenPrimOp Addr# -> Int# -> Char# @@ -1501,7 +1510,7 @@ primop WriteMutVarOp "writeMutVar#" GenPrimOp can_fail = True primop SameMutVarOp "sameMutVar#" GenPrimOp - MutVar# s a -> MutVar# s a -> Bool + MutVar# s a -> MutVar# s a -> Int# -- not really the right type, but we don't know about pairs here. The -- correct type is @@ -1602,9 +1611,20 @@ primop AtomicallyOp "atomically#" GenPrimOp out_of_line = True has_side_effects = True +-- NB: retry#'s strictness information specifies it to return bottom. +-- This lets the compiler perform some extra simplifications, since retry# +-- will technically never return. +-- +-- This allows the simplifier to replace things like: +-- case retry# s1 +-- (# s2, a #) -> e +-- with: +-- retry# s1 +-- where 'e' would be unreachable anyway. See Trac #8091. primop RetryOp "retry#" GenPrimOp State# RealWorld -> (# State# RealWorld, a #) with + strictness = { \ _arity -> mkStrictSig (mkTopDmdType [topDmd] botRes) } out_of_line = True has_side_effects = True @@ -1665,7 +1685,7 @@ primop WriteTVarOp "writeTVar#" GenPrimOp has_side_effects = True primop SameTVarOp "sameTVar#" GenPrimOp - TVar# s a -> TVar# s a -> Bool + TVar# s a -> TVar# s a -> Int# ------------------------------------------------------------------------ @@ -1717,8 +1737,25 @@ primop TryPutMVarOp "tryPutMVar#" GenPrimOp out_of_line = True has_side_effects = True +primop ReadMVarOp "readMVar#" GenPrimOp + MVar# s a -> State# s -> (# State# s, a #) + {If {\tt MVar\#} is empty, block until it becomes full. + Then read its contents without modifying the MVar, without possibility + of intervention from other threads.} + with + out_of_line = True + has_side_effects = True + +primop TryReadMVarOp "tryReadMVar#" GenPrimOp + MVar# s a -> State# s -> (# State# s, Int#, a #) + {If {\tt MVar\#} is empty, immediately return with integer 0 and value undefined. + Otherwise, return with integer 1 and contents of {\tt MVar\#}.} + with + out_of_line = True + has_side_effects = True + primop SameMVarOp "sameMVar#" GenPrimOp - MVar# s a -> MVar# s a -> Bool + MVar# s a -> MVar# s a -> Int# primop IsEmptyMVarOp "isEmptyMVar#" GenPrimOp MVar# s a -> State# s -> (# State# s, Int# #) @@ -1871,8 +1908,15 @@ primop MkWeakNoFinalizerOp "mkWeakNoFinalizer#" GenPrimOp has_side_effects = True out_of_line = True -primop MkWeakForeignEnvOp "mkWeakForeignEnv#" GenPrimOp - o -> b -> Addr# -> Addr# -> Int# -> Addr# -> State# RealWorld -> (# State# RealWorld, Weak# b #) +primop AddCFinalizerToWeakOp "addCFinalizerToWeak#" GenPrimOp + Addr# -> Addr# -> Int# -> Addr# -> Weak# b + -> State# RealWorld -> (# State# RealWorld, Int# #) + { {\tt addCFinalizerToWeak# fptr ptr flag eptr w} attaches a C + function pointer {\tt fptr} to a weak pointer {\tt w} as a finalizer. If + {\tt flag} is zero, {\tt fptr} will be called with one argument, + {\tt ptr}. Otherwise, it will be called with two arguments, + {\tt eptr} and {\tt ptr}. {\tt addCFinalizerToWeak#} returns + 1 on success, or 0 if {\tt w} is already dead. } with has_side_effects = True out_of_line = True diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs index 8d9c269305..7e6959baaa 100644 --- a/compiler/profiling/CostCentre.lhs +++ b/compiler/profiling/CostCentre.lhs @@ -29,6 +29,7 @@ module CostCentre ( cmpCostCentre -- used for removing dups in a list ) where +import Binary import Var import Name import Module @@ -294,4 +295,42 @@ costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf}) costCentreSrcSpan :: CostCentre -> SrcSpan costCentreSrcSpan = cc_loc + +instance Binary IsCafCC where + put_ bh CafCC = do + putByte bh 0 + put_ bh NotCafCC = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do return CafCC + _ -> do return NotCafCC + +instance Binary CostCentre where + put_ bh (NormalCC aa ab ac _ad ae) = do + putByte bh 0 + put_ bh aa + put_ bh ab + put_ bh ac + put_ bh ae + put_ bh (AllCafsCC ae _af) = do + putByte bh 1 + put_ bh ae + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + ab <- get bh + ac <- get bh + ae <- get bh + return (NormalCC aa ab ac noSrcSpan ae) + _ -> do ae <- get bh + return (AllCafsCC ae noSrcSpan) + + -- We ignore the SrcSpans in CostCentres when we serialise them, + -- and set the SrcSpans to noSrcSpan when deserialising. This is + -- ok, because we only need the SrcSpan when declaring the + -- CostCentre in the original module, it is not used by importing + -- modules. \end{code} diff --git a/compiler/profiling/SCCfinal.lhs b/compiler/profiling/SCCfinal.lhs index 77e2cb78c0..5417ad491e 100644 --- a/compiler/profiling/SCCfinal.lhs +++ b/compiler/profiling/SCCfinal.lhs @@ -91,7 +91,7 @@ stgMassageForProfiling dflags mod_name _us stg_binds do_top_rhs _ (StgRhsClosure _ _ _ _ _ [] (StgSCC _cc False{-not tick-} _push (StgConApp con args))) - | not (isDllConApp dflags con args) + | not (isDllConApp dflags mod_name con args) -- Trivial _scc_ around nothing but static data -- Eliminate _scc_ ... and turn into StgRhsCon diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 90061b10a2..d73b537af0 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -25,7 +25,7 @@ module RnEnv ( newLocalBndrRn, newLocalBndrsRn, bindLocalName, bindLocalNames, bindLocalNamesFV, - MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv, + MiniFixityEnv, addLocalFixities, bindLocatedLocalsFV, bindLocatedLocalsRn, extendTyVarEnvFVRn, @@ -36,7 +36,10 @@ module RnEnv ( warnUnusedMatches, warnUnusedTopBinds, warnUnusedLocalBinds, dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg, - HsDocContext(..), docOfHsDocContext + HsDocContext(..), docOfHsDocContext, + + -- FsEnv + FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv ) where #include "HsVersions.h" @@ -57,8 +60,9 @@ import Module import UniqFM import DataCon ( dataConFieldLabels, dataConTyCon ) import TyCon ( isTupleTyCon, tyConArity ) -import PrelNames ( mkUnboundName, rOOT_MAIN, forall_tv_RDR ) +import PrelNames ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR ) import ErrUtils ( MsgDoc ) +import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence ) import SrcLoc import Outputable import Util @@ -72,12 +76,6 @@ import qualified Data.Set as Set import Constants ( mAX_TUPLE_SIZE ) \end{code} -\begin{code} --- XXX -thenM :: Monad a => a b -> (b -> a c) -> a c -thenM = (>>=) -\end{code} - %********************************************************* %* * Source-code binders @@ -530,8 +528,8 @@ we'll miss the fact that the qualified import is redundant. \begin{code} getLookupOccRn :: RnM (Name -> Maybe Name) getLookupOccRn - = getLocalRdrEnv `thenM` \ local_env -> - return (lookupLocalRdrOcc local_env . nameOccName) + = do local_env <- getLocalRdrEnv + return (lookupLocalRdrOcc local_env . nameOccName) lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) lookupLocatedOccRn = wrapLocM lookupOccRn @@ -814,15 +812,15 @@ lookupQualifiedName rdr_name | Just (mod,occ) <- isQual_maybe rdr_name -- Note: we want to behave as we would for a source file import here, -- and respect hiddenness of modules/packages, hence loadSrcInterface. - = loadSrcInterface doc mod False Nothing `thenM` \ iface -> + = do iface <- loadSrcInterface doc mod False Nothing - case [ name - | avail <- mi_exports iface, - name <- availNames avail, - nameOccName name == occ ] of - (n:ns) -> ASSERT (null ns) return (Just n) - _ -> do { traceRn (text "lookupQualified" <+> ppr rdr_name) - ; return Nothing } + case [ name + | avail <- mi_exports iface, + name <- availNames avail, + nameOccName name == occ ] of + (n:ns) -> ASSERT(null ns) return (Just n) + _ -> do { traceRn (text "lookupQualified" <+> ppr rdr_name) + ; return Nothing } | otherwise = pprPanic "RnEnv.lookupQualifiedName" (ppr rdr_name) @@ -1040,10 +1038,12 @@ type FastStringEnv a = UniqFM a -- Keyed by FastString emptyFsEnv :: FastStringEnv a lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a +mkFsEnv :: [(FastString,a)] -> FastStringEnv a emptyFsEnv = emptyUFM lookupFsEnv = lookupUFM extendFsEnv = addToUFM +mkFsEnv = listToUFM -------------------------------- type MiniFixityEnv = FastStringEnv (Located Fixity) @@ -1090,14 +1090,25 @@ lookupFixity is a bit strange. \begin{code} lookupFixityRn :: Name -> RnM Fixity lookupFixityRn name - = getModule `thenM` \ this_mod -> - if nameIsLocalOrFrom this_mod name - then do -- It's defined in this module - local_fix_env <- getFixityEnv - traceRn (text "lookupFixityRn: looking up name in local environment:" <+> - vcat [ppr name, ppr local_fix_env]) - return $ lookupFixity local_fix_env name - else -- It's imported + | isUnboundName name + = return (Fixity minPrecedence InfixL) + -- Minimise errors from ubound names; eg + -- a>0 `foo` b>0 + -- where 'foo' is not in scope, should not give an error (Trac #7937) + + | otherwise + = do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod name + then lookup_local + else lookup_imported } + where + lookup_local -- It's defined in this module + = do { local_fix_env <- getFixityEnv + ; traceRn (text "lookupFixityRn: looking up name in local environment:" <+> + vcat [ppr name, ppr local_fix_env]) + ; return (lookupFixity local_fix_env name) } + + lookup_imported -- For imported names, we have to get their fixities by doing a -- loadInterfaceForName, and consulting the Ifaces that comes back -- from that, because the interface file for the Name might not @@ -1114,12 +1125,11 @@ lookupFixityRn name -- -- loadInterfaceForName will find B.hi even if B is a hidden module, -- and that's what we want. - loadInterfaceForName doc name `thenM` \ iface -> do { - traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+> - vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)]); - return (mi_fix_fn iface (nameOccName name)) - } - where + = do { iface <- loadInterfaceForName doc name + ; traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+> + vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)]) + ; return (mi_fix_fn iface (nameOccName name)) } + doc = ptext (sLit "Checking fixity for") <+> ppr name --------------- @@ -1262,8 +1272,8 @@ bindLocatedLocalsFV :: [Located RdrName] -> ([Name] -> RnM (a,FreeVars)) -> RnM (a, FreeVars) bindLocatedLocalsFV rdr_names enclosed_scope = bindLocatedLocalsRn rdr_names $ \ names -> - enclosed_scope names `thenM` \ (thing, fvs) -> - return (thing, delFVs names fvs) + do (thing, fvs) <- enclosed_scope names + return (thing, delFVs names fvs) ------------------------------------- diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 29674ca34c..0ef169085b 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -10,45 +10,38 @@ general, all of these functions return a renamed thing, and a set of free variables. \begin{code} -{-# 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 RnExpr ( - rnLExpr, rnExpr, rnStmts + rnLExpr, rnExpr, rnStmts ) where #include "HsVersions.h" #ifdef GHCI import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr ) -#endif /* GHCI */ +#endif /* GHCI */ import RnSource ( rnSrcDecls, findSplice ) import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, - rnMatchGroup, rnGRHS, makeMiniFixityEnv) + rnMatchGroup, rnGRHS, makeMiniFixityEnv) import HsSyn import TcRnMonad -import TcEnv ( thRnBrack ) +import TcEnv ( thRnBrack ) import RnEnv import RnTypes import RnPat import DynFlags -import BasicTypes ( FixityDirection(..) ) +import BasicTypes ( FixityDirection(..) ) import PrelNames import Module import Name import NameSet import RdrName -import LoadIface ( loadInterfaceForName ) +import LoadIface ( loadInterfaceForName ) import UniqSet import Data.List import Util -import ListSetOps ( removeDups ) +import ListSetOps ( removeDups ) import Outputable import SrcLoc import FastString @@ -67,9 +60,9 @@ thenM_ = (>>) \end{code} %************************************************************************ -%* * +%* * \subsubsection{Expressions} -%* * +%* * %************************************************************************ \begin{code} @@ -78,18 +71,18 @@ rnExprs ls = rnExprs' ls emptyUniqSet where rnExprs' [] acc = return ([], acc) rnExprs' (expr:exprs) acc - = rnLExpr expr `thenM` \ (expr', fvExpr) -> + = rnLExpr expr `thenM` \ (expr', fvExpr) -> - -- Now we do a "seq" on the free vars because typically it's small - -- or empty, especially in very long lists of constants + -- Now we do a "seq" on the free vars because typically it's small + -- or empty, especially in very long lists of constants let - acc' = acc `plusFV` fvExpr + acc' = acc `plusFV` fvExpr in acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) -> return (expr':exprs', fvExprs) \end{code} -Variables. We look up the variable and return the resulting name. +Variables. We look up the variable and return the resulting name. \begin{code} rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars) @@ -101,12 +94,12 @@ finishHsVar :: Name -> RnM (HsExpr Name, FreeVars) -- Separated from rnExpr because it's also used -- when renaming infix expressions -- See Note [Adding the implicit parameter to 'assert'] -finishHsVar name +finishHsVar name = do { ignore_asserts <- goptM Opt_IgnoreAsserts ; if ignore_asserts || not (name `hasKey` assertIdKey) - then return (HsVar name, unitFV name) - else do { e <- mkAssertErrorExpr - ; return (e, unitFV name) } } + then return (HsVar name, unitFV name) + else do { e <- mkAssertErrorExpr + ; return (e, unitFV name) } } rnExpr (HsVar v) = do { mb_name <- lookupOccRn_maybe v @@ -115,11 +108,11 @@ rnExpr (HsVar v) ; if opt_TypeHoles && startsWithUnderscore (rdrNameOcc v) then return (HsUnboundVar v, emptyFVs) else do { n <- reportUnboundName v; finishHsVar n } } ; - Just name + Just name | name == nilDataConName -- Treat [] as an ExplicitList, so that -- OverloadedLists works correctly -> rnExpr (ExplicitList placeHolderType Nothing []) - | otherwise + | otherwise -> finishHsVar name } } rnExpr (HsIPVar v) @@ -130,48 +123,48 @@ rnExpr (HsLit lit@(HsString s)) opt_OverloadedStrings <- xoptM Opt_OverloadedStrings ; if opt_OverloadedStrings then rnExpr (HsOverLit (mkHsIsString s placeHolderType)) - else -- Same as below - rnLit lit `thenM_` + else -- Same as below + rnLit lit `thenM_` return (HsLit lit, emptyFVs) } -rnExpr (HsLit lit) - = rnLit lit `thenM_` +rnExpr (HsLit lit) + = rnLit lit `thenM_` return (HsLit lit, emptyFVs) -rnExpr (HsOverLit lit) - = rnOverLit lit `thenM` \ (lit', fvs) -> +rnExpr (HsOverLit lit) + = rnOverLit lit `thenM` \ (lit', fvs) -> return (HsOverLit lit', fvs) rnExpr (HsApp fun arg) - = rnLExpr fun `thenM` \ (fun',fvFun) -> - rnLExpr arg `thenM` \ (arg',fvArg) -> + = rnLExpr fun `thenM` \ (fun',fvFun) -> + rnLExpr arg `thenM` \ (arg',fvArg) -> return (HsApp fun' arg', fvFun `plusFV` fvArg) rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2) = do { (e1', fv_e1) <- rnLExpr e1 - ; (e2', fv_e2) <- rnLExpr e2 - ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr) - ; (op', fv_op) <- finishHsVar op_name - -- NB: op' is usually just a variable, but might be - -- an applicatoin (assert "Foo.hs:47") - -- Deal with fixity - -- When renaming code synthesised from "deriving" declarations - -- we used to avoid fixity stuff, but we can't easily tell any - -- more, so I've removed the test. Adding HsPars in TcGenDeriv - -- should prevent bad things happening. - ; fixity <- lookupFixityRn op_name - ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2' - ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) } + ; (e2', fv_e2) <- rnLExpr e2 + ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr) + ; (op', fv_op) <- finishHsVar op_name + -- NB: op' is usually just a variable, but might be + -- an applicatoin (assert "Foo.hs:47") + -- Deal with fixity + -- When renaming code synthesised from "deriving" declarations + -- we used to avoid fixity stuff, but we can't easily tell any + -- more, so I've removed the test. Adding HsPars in TcGenDeriv + -- should prevent bad things happening. + ; fixity <- lookupFixityRn op_name + ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2' + ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) } rnExpr (OpApp _ other_op _ _) = failWith (vcat [ hang (ptext (sLit "Infix application with a non-variable operator:")) 2 (ppr other_op) , ptext (sLit "(Probably resulting from a Template Haskell splice)") ]) rnExpr (NegApp e _) - = rnLExpr e `thenM` \ (e', fv_e) -> - lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) -> - mkNegAppRn e' neg_name `thenM` \ final_e -> + = rnLExpr e `thenM` \ (e', fv_e) -> + lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) -> + mkNegAppRn e' neg_name `thenM` \ final_e -> return (final_e, fv_e `plusFV` fv_neg) ------------------------------------------ @@ -189,36 +182,36 @@ rnExpr e@(HsBracket br_body) return (HsBracket body', fvs_e) rnExpr (HsSpliceE splice) - = rnSplice splice `thenM` \ (splice', fvs) -> + = rnSplice splice `thenM` \ (splice', fvs) -> return (HsSpliceE splice', fvs) #ifndef GHCI rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e) #else rnExpr (HsQuasiQuoteE qq) - = runQuasiQuoteExpr qq `thenM` \ (L _ expr') -> + = runQuasiQuoteExpr qq `thenM` \ (L _ expr') -> rnExpr expr' -#endif /* GHCI */ +#endif /* GHCI */ --------------------------------------------- --- Sections +-- Sections -- See Note [Parsing sections] in Parser.y.pp rnExpr (HsPar (L loc (section@(SectionL {})))) - = do { (section', fvs) <- rnSection section - ; return (HsPar (L loc section'), fvs) } + = do { (section', fvs) <- rnSection section + ; return (HsPar (L loc section'), fvs) } rnExpr (HsPar (L loc (section@(SectionR {})))) - = do { (section', fvs) <- rnSection section - ; return (HsPar (L loc section'), fvs) } + = do { (section', fvs) <- rnSection section + ; return (HsPar (L loc section'), fvs) } rnExpr (HsPar e) - = do { (e', fvs_e) <- rnLExpr e - ; return (HsPar e', fvs_e) } + = do { (e', fvs_e) <- rnLExpr e + ; return (HsPar e', fvs_e) } rnExpr expr@(SectionL {}) - = do { addErr (sectionErr expr); rnSection expr } + = do { addErr (sectionErr expr); rnSection expr } rnExpr expr@(SectionR {}) - = do { addErr (sectionErr expr); rnSection expr } + = do { addErr (sectionErr expr); rnSection expr } --------------------------------------------- rnExpr (HsCoreAnn ann expr) @@ -226,10 +219,10 @@ rnExpr (HsCoreAnn ann expr) return (HsCoreAnn ann expr', fvs_expr) rnExpr (HsSCC lbl expr) - = rnLExpr expr `thenM` \ (expr', fvs_expr) -> + = rnLExpr expr `thenM` \ (expr', fvs_expr) -> return (HsSCC lbl expr', fvs_expr) rnExpr (HsTickPragma info expr) - = rnLExpr expr `thenM` \ (expr', fvs_expr) -> + = rnLExpr expr `thenM` \ (expr', fvs_expr) -> return (HsTickPragma info expr', fvs_expr) rnExpr (HsLam matches) @@ -237,7 +230,7 @@ rnExpr (HsLam matches) return (HsLam matches', fvMatch) rnExpr (HsLamCase arg matches) - = rnMatchGroup CaseAlt rnLExpr matches `thenM` \ (matches', fvs_ms) -> + = rnMatchGroup CaseAlt rnLExpr matches `thenM` \ (matches', fvs_ms) -> return (HsLamCase arg matches', fvs_ms) rnExpr (HsCase expr matches) @@ -246,26 +239,26 @@ rnExpr (HsCase expr matches) return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) rnExpr (HsLet binds expr) - = rnLocalBindsAndThen binds $ \ binds' -> - rnLExpr expr `thenM` \ (expr',fvExpr) -> + = rnLocalBindsAndThen binds $ \ binds' -> + rnLExpr expr `thenM` \ (expr',fvExpr) -> return (HsLet binds' expr', fvExpr) rnExpr (HsDo do_or_lc stmts _) - = do { ((stmts', _), fvs) <- rnStmts do_or_lc rnLExpr stmts (\ _ -> return ((), emptyFVs)) - ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) } + = do { ((stmts', _), fvs) <- rnStmts do_or_lc rnLExpr stmts (\ _ -> return ((), emptyFVs)) + ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) } rnExpr (ExplicitList _ _ exps) = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists ; (exps', fvs) <- rnExprs exps - ; if opt_OverloadedLists + ; if opt_OverloadedLists then do { - ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName - ; return (ExplicitList placeHolderType (Just from_list_n_name) exps', fvs `plusFV` fvs') } + ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName + ; return (ExplicitList placeHolderType (Just from_list_n_name) exps', fvs `plusFV` fvs') } else return (ExplicitList placeHolderType Nothing exps', fvs) } rnExpr (ExplicitPArr _ exps) - = rnExprs exps `thenM` \ (exps', fvs) -> + = rnExprs exps `thenM` \ (exps', fvs) -> return (ExplicitPArr placeHolderType exps', fvs) rnExpr (ExplicitTuple tup_args boxity) @@ -278,22 +271,22 @@ rnExpr (ExplicitTuple tup_args boxity) rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs) rnExpr (RecordCon con_id _ rbinds) - = do { conname <- lookupLocatedOccRn con_id - ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds - ; return (RecordCon conname noPostTcExpr rbinds', - fvRbinds `addOneFV` unLoc conname) } + = do { conname <- lookupLocatedOccRn con_id + ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds + ; return (RecordCon conname noPostTcExpr rbinds', + fvRbinds `addOneFV` unLoc conname) } rnExpr (RecordUpd expr rbinds _ _ _) - = do { (expr', fvExpr) <- rnLExpr expr - ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds - ; return (RecordUpd expr' rbinds' [] [] [], - fvExpr `plusFV` fvRbinds) } + = do { (expr', fvExpr) <- rnLExpr expr + ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds + ; return (RecordUpd expr' rbinds' [] [] [], + fvExpr `plusFV` fvRbinds) } rnExpr (ExprWithTySig expr pty) - = do { (pty', fvTy) <- rnLHsType ExprWithTySigCtx pty - ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $ - rnLExpr expr - ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) } + = do { (pty', fvTy) <- rnLHsType ExprWithTySigCtx pty + ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $ + rnLExpr expr + ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) } rnExpr (HsIf _ p b1 b2) = do { (p', fvP) <- rnLExpr p @@ -307,21 +300,21 @@ rnExpr (HsMultiIf ty alts) ; return (HsMultiIf ty alts', fvs) } rnExpr (HsType a) - = rnLHsType HsTypeCtx a `thenM` \ (t, fvT) -> + = rnLHsType HsTypeCtx a `thenM` \ (t, fvT) -> return (HsType t, fvT) rnExpr (ArithSeq _ _ seq) = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists ; (new_seq, fvs) <- rnArithSeq seq - ; if opt_OverloadedLists + ; if opt_OverloadedLists then do { - ; (from_list_name, fvs') <- lookupSyntaxName fromListName - ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') } + ; (from_list_name, fvs') <- lookupSyntaxName fromListName + ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') } else return (ArithSeq noPostTcExpr Nothing new_seq, fvs) } rnExpr (PArrSeq _ seq) - = rnArithSeq seq `thenM` \ (new_seq, fvs) -> + = rnArithSeq seq `thenM` \ (new_seq, fvs) -> return (PArrSeq noPostTcExpr new_seq, fvs) \end{code} @@ -341,16 +334,16 @@ rnExpr e@(ELazyPat {}) = patSynErr e \end{code} %************************************************************************ -%* * - Arrow notation -%* * +%* * + Arrow notation +%* * %************************************************************************ \begin{code} rnExpr (HsProc pat body) = newArrowScope $ rnPat ProcExpr pat $ \ pat' -> - rnCmdTop body `thenM` \ (body',fvBody) -> + rnCmdTop body `thenM` \ (body',fvBody) -> return (HsProc pat' body', fvBody) -- Ideally, these would be done in parsing, but to keep parsing simple, we do it here. @@ -358,7 +351,7 @@ rnExpr e@(HsArrApp {}) = arrowFail e rnExpr e@(HsArrForm {}) = arrowFail e rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) - -- HsWrap + -- HsWrap hsHoleExpr :: HsExpr Name hsHoleExpr = HsUnboundVar (mkRdrUnqual (mkVarOcc "_")) @@ -375,24 +368,24 @@ arrowFail e -- See Note [Parsing sections] in Parser.y.pp rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) rnSection section@(SectionR op expr) - = do { (op', fvs_op) <- rnLExpr op - ; (expr', fvs_expr) <- rnLExpr expr - ; checkSectionPrec InfixR section op' expr' - ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) } + = do { (op', fvs_op) <- rnLExpr op + ; (expr', fvs_expr) <- rnLExpr expr + ; checkSectionPrec InfixR section op' expr' + ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) } rnSection section@(SectionL expr op) - = do { (expr', fvs_expr) <- rnLExpr expr - ; (op', fvs_op) <- rnLExpr op - ; checkSectionPrec InfixL section op' expr' - ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) } + = do { (expr', fvs_expr) <- rnLExpr expr + ; (op', fvs_op) <- rnLExpr op + ; checkSectionPrec InfixL section op' expr' + ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) } rnSection other = pprPanic "rnSection" (ppr other) \end{code} %************************************************************************ -%* * - Records -%* * +%* * + Records +%* * %************************************************************************ \begin{code} @@ -401,40 +394,40 @@ rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd }) = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds ; (flds', fvss) <- mapAndUnzipM rn_field flds - ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }, + ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }, fvs `plusFV` plusFVs fvss) } - where + where rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) ; return (fld { hsRecFieldArg = arg' }, fvs) } \end{code} %************************************************************************ -%* * - Arrow commands -%* * +%* * + Arrow commands +%* * %************************************************************************ \begin{code} rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars) rnCmdArgs [] = return ([], emptyFVs) rnCmdArgs (arg:args) - = rnCmdTop arg `thenM` \ (arg',fvArg) -> - rnCmdArgs args `thenM` \ (args',fvArgs) -> + = rnCmdTop arg `thenM` \ (arg',fvArg) -> + rnCmdArgs args `thenM` \ (args',fvArgs) -> return (arg':args', fvArg `plusFV` fvArgs) rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars) rnCmdTop = wrapLocFstM rnCmdTop' where - rnCmdTop' (HsCmdTop cmd _ _ _) + rnCmdTop' (HsCmdTop cmd _ _ _) = do { (cmd', fvCmd) <- rnLCmd cmd ; let cmd_names = [arrAName, composeAName, firstAName] ++ - nameSetToList (methodNamesCmd (unLoc cmd')) - -- Generate the rebindable syntax for the monad + nameSetToList (methodNamesCmd (unLoc cmd')) + -- Generate the rebindable syntax for the monad ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names - ; return (HsCmdTop cmd' placeHolderType placeHolderType (cmd_names `zip` cmd_names'), - fvCmd `plusFV` cmd_fvs) } + ; return (HsCmdTop cmd' placeHolderType placeHolderType (cmd_names `zip` cmd_names'), + fvCmd `plusFV` cmd_fvs) } rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars) rnLCmd = wrapLocFstM rnCmd @@ -451,10 +444,10 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl) HsHigherOrderApp -> tc HsFirstOrderApp -> escapeArrowScope tc -- See Note [Escaping the arrow scope] in TcRnTypes - -- Before renaming 'arrow', use the environment of the enclosing - -- proc for the (-<) case. - -- Local bindings, inside the enclosing proc, are not in scope - -- inside 'arrow'. In the higher-order case (-<<), they are. + -- Before renaming 'arrow', use the environment of the enclosing + -- proc for the (-<) case. + -- Local bindings, inside the enclosing proc, are not in scope + -- inside 'arrow'. In the higher-order case (-<<), they are. -- infix form rnCmd (HsCmdArrForm op (Just _) [arg1, arg2]) @@ -467,7 +460,7 @@ rnCmd (HsCmdArrForm op (Just _) [arg1, arg2]) -- Deal with fixity lookupFixityRn op_name `thenM` \ fixity -> - mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e -> + mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e -> return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) @@ -514,8 +507,8 @@ rnCmd (HsCmdDo stmts _) rnCmd cmd@(HsCmdCast {}) = pprPanic "rnCmd" (ppr cmd) --------------------------------------------------- -type CmdNeeds = FreeVars -- Only inhabitants are - -- appAName, choiceAName, loopAName +type CmdNeeds = FreeVars -- Only inhabitants are + -- appAName, choiceAName, loopAName -- find what methods the Cmd needs (loop, choice, apply) methodNamesLCmd :: LHsCmd Name -> CmdNeeds @@ -536,7 +529,7 @@ methodNamesCmd (HsCmdIf _ _ c1 c2) = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName methodNamesCmd (HsCmdLet _ c) = methodNamesLCmd c -methodNamesCmd (HsCmdDo stmts _) = methodNamesStmts stmts +methodNamesCmd (HsCmdDo stmts _) = methodNamesStmts stmts methodNamesCmd (HsCmdApp c _) = methodNamesLCmd c methodNamesCmd (HsCmdLam match) = methodNamesMatch match @@ -544,7 +537,7 @@ methodNamesCmd (HsCmdCase _ matches) = methodNamesMatch matches `addOneFV` choiceAName --methodNamesCmd _ = emptyFVs - -- Other forms can't occur in commands, but it's not convenient + -- Other forms can't occur in commands, but it's not convenient -- to error here so we just do what's convenient. -- The type checker will complain later @@ -552,7 +545,7 @@ methodNamesCmd (HsCmdCase _ matches) methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars methodNamesMatch (MG { mg_alts = ms }) = plusFVs (map do_one ms) - where + where do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss ------------------------------------------------- @@ -581,107 +574,107 @@ methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOn methodNamesStmt (LetStmt {}) = emptyFVs methodNamesStmt (ParStmt {}) = emptyFVs methodNamesStmt (TransStmt {}) = emptyFVs - -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error + -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error -- here so we just do what's convenient \end{code} %************************************************************************ -%* * - Arithmetic sequences -%* * +%* * + Arithmetic sequences +%* * %************************************************************************ \begin{code} rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars) rnArithSeq (From expr) - = rnLExpr expr `thenM` \ (expr', fvExpr) -> + = rnLExpr expr `thenM` \ (expr', fvExpr) -> return (From expr', fvExpr) rnArithSeq (FromThen expr1 expr2) - = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> - rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> + = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) rnArithSeq (FromTo expr1 expr2) - = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> - rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> + = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) rnArithSeq (FromThenTo expr1 expr2 expr3) - = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> - rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> - rnLExpr expr3 `thenM` \ (expr3', fvExpr3) -> + = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> + rnLExpr expr3 `thenM` \ (expr3', fvExpr3) -> return (FromThenTo expr1' expr2' expr3', - plusFVs [fvExpr1, fvExpr2, fvExpr3]) + plusFVs [fvExpr1, fvExpr2, fvExpr3]) \end{code} %************************************************************************ -%* * - Template Haskell brackets -%* * +%* * + Template Haskell brackets +%* * %************************************************************************ \begin{code} rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars) -rnBracket (VarBr flg n) +rnBracket (VarBr flg n) = do { name <- lookupOccRn n ; this_mod <- getModule ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking assumes do { _ <- loadInterfaceForName msg name -- the home interface is loaded, and - ; return () } -- this is the only way that is going - -- to happen + ; return () } -- this is the only way that is going + -- to happen ; return (VarBr flg name, unitFV name) } where msg = ptext (sLit "Need interface for Template Haskell quoted Name") rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e - ; return (ExpBr e', fvs) } + ; return (ExpBr e', fvs) } rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs) rnBracket (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t - ; return (TypBr t', fvs) } + ; return (TypBr t', fvs) } -rnBracket (DecBrL decls) +rnBracket (DecBrL decls) = do { (group, mb_splice) <- findSplice decls ; case mb_splice of Nothing -> return () - Just (SpliceDecl (L loc _) _, _) + Just (SpliceDecl (L loc _) _, _) -> setSrcSpan loc $ addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets")) - -- Why not? See Section 7.3 of the TH paper. + -- Why not? See Section 7.3 of the TH paper. ; gbl_env <- getGblEnv ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs } - -- The emptyDUs is so that we just collect uses for this + -- The emptyDUs is so that we just collect uses for this -- group alone in the call to rnSrcDecls below - ; (tcg_env, group') <- setGblEnv new_gbl_env $ - setStage thRnBrack $ - rnSrcDecls [] group + ; (tcg_env, group') <- setGblEnv new_gbl_env $ + setStage thRnBrack $ + rnSrcDecls [] group -- The empty list is for extra dependencies coming from .hs-boot files -- See Note [Extra dependencies from .hs-boot files] in RnSource - -- Discard the tcg_env; it contains only extra info about fixity - ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ + -- Discard the tcg_env; it contains only extra info about fixity + ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env)))) - ; return (DecBrG group', duUses (tcg_dus tcg_env)) } + ; return (DecBrG group', duUses (tcg_dus tcg_env)) } rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG" \end{code} %************************************************************************ -%* * +%* * \subsubsection{@Stmt@s: in @do@ expressions} -%* * +%* * %************************************************************************ \begin{code} -rnStmts :: Outputable (body RdrName) => HsStmtContext Name +rnStmts :: Outputable (body RdrName) => HsStmtContext Name -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) -> [LStmt RdrName (Located (body RdrName))] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) + -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) -- Variables bound by the Stmts, and mentioned in thing_inside, -- do not appear in the result FreeVars @@ -692,11 +685,11 @@ rnStmts ctxt _ [] thing_inside rnStmts MDoExpr rnBody stmts thing_inside -- Deal with mdo = -- Behave like do { rec { ...all but last... }; last } - do { ((stmts1, (stmts2, thing)), fvs) - <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ -> - do { last_stmt' <- checkLastStmt MDoExpr last_stmt - ; rnStmt MDoExpr rnBody last_stmt' thing_inside } - ; return (((stmts1 ++ stmts2), thing), fvs) } + do { ((stmts1, (stmts2, thing)), fvs) + <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ -> + do { last_stmt' <- checkLastStmt MDoExpr last_stmt + ; rnStmt MDoExpr rnBody last_stmt' thing_inside } + ; return (((stmts1 ++ stmts2), thing), fvs) } where Just (all_but_last, last_stmt) = snocView stmts @@ -707,16 +700,16 @@ rnStmts ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside ; rnStmt ctxt rnBody lstmt' thing_inside } | otherwise - = do { ((stmts1, (stmts2, thing)), fvs) + = do { ((stmts1, (stmts2, thing)), fvs) <- setSrcSpan loc $ do { checkStmt ctxt lstmt ; rnStmt ctxt rnBody lstmt $ \ bndrs1 -> rnStmts ctxt rnBody lstmts $ \ bndrs2 -> thing_inside (bndrs1 ++ bndrs2) } - ; return (((stmts1 ++ stmts2), thing), fvs) } + ; return (((stmts1 ++ stmts2), thing), fvs) } ---------------------- -rnStmt :: Outputable (body RdrName) => HsStmtContext Name +rnStmt :: Outputable (body RdrName) => HsStmtContext Name -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) -> LStmt RdrName (Located (body RdrName)) -> ([Name] -> RnM (thing, FreeVars)) @@ -725,91 +718,72 @@ rnStmt :: Outputable (body RdrName) => HsStmtContext Name -- do not appear in the result FreeVars rnStmt ctxt rnBody (L loc (LastStmt body _)) thing_inside - = do { (body', fv_expr) <- rnBody body - ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName - ; (thing, fvs3) <- thing_inside [] - ; return (([L loc (LastStmt body' ret_op)], thing), - fv_expr `plusFV` fvs1 `plusFV` fvs3) } + = do { (body', fv_expr) <- rnBody body + ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName + ; (thing, fvs3) <- thing_inside [] + ; return (([L loc (LastStmt body' ret_op)], thing), + fv_expr `plusFV` fvs1 `plusFV` fvs3) } rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside - = do { (body', fv_expr) <- rnBody body - ; (then_op, fvs1) <- lookupStmtName ctxt thenMName - ; (guard_op, fvs2) <- if isListCompExpr ctxt + = do { (body', fv_expr) <- rnBody body + ; (then_op, fvs1) <- lookupStmtName ctxt thenMName + ; (guard_op, fvs2) <- if isListCompExpr ctxt then lookupStmtName ctxt guardMName - else return (noSyntaxExpr, emptyFVs) - -- Only list/parr/monad comprehensions use 'guard' - -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ] - -- Here "gd" is a guard - ; (thing, fvs3) <- thing_inside [] - ; return (([L loc (BodyStmt body' then_op guard_op placeHolderType)], thing), - fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } + else return (noSyntaxExpr, emptyFVs) + -- Only list/parr/monad comprehensions use 'guard' + -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ] + -- Here "gd" is a guard + ; (thing, fvs3) <- thing_inside [] + ; return (([L loc (BodyStmt body' then_op guard_op placeHolderType)], thing), + fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside - = do { (body', fv_expr) <- rnBody body - -- The binders do not scope over the expression - ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName - ; (fail_op, fvs2) <- lookupStmtName ctxt failMName - ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do - { (thing, fvs3) <- thing_inside (collectPatBinders pat') - ; return (([L loc (BindStmt pat' body' bind_op fail_op)], thing), - fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} + = do { (body', fv_expr) <- rnBody body + -- The binders do not scope over the expression + ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName + ; (fail_op, fvs2) <- lookupStmtName ctxt failMName + ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do + { (thing, fvs3) <- thing_inside (collectPatBinders pat') + ; return (([L loc (BindStmt pat' body' bind_op fail_op)], thing), + fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} -- fv_expr shouldn't really be filtered by the rnPatsAndThen - -- but it does not matter because the names are unique + -- but it does not matter because the names are unique -rnStmt _ _ (L loc (LetStmt binds)) thing_inside - = do { rnLocalBindsAndThen binds $ \binds' -> do - { (thing, fvs) <- thing_inside (collectLocalBinders binds') +rnStmt _ _ (L loc (LetStmt binds)) thing_inside + = do { rnLocalBindsAndThen binds $ \binds' -> do + { (thing, fvs) <- thing_inside (collectLocalBinders binds') ; return (([L loc (LetStmt binds')], thing), fvs) } } rnStmt ctxt rnBody (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside - = do { - -- Step1: Bring all the binders of the mdo into scope - -- (Remember that this also removes the binders from the - -- finally-returned free-vars.) - -- And rename each individual stmt, making a - -- singleton segment. At this stage the FwdRefs field - -- isn't finished: it's empty for all except a BindStmt - -- for which it's the fwd refs within the bind itself - -- (This set may not be empty, because we're in a recursive - -- context.) + = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName + ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName + ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName + ; let empty_rec_stmt = emptyRecStmt { recS_ret_fn = return_op + , recS_mfix_fn = mfix_op + , recS_bind_fn = bind_op } + + -- Step1: Bring all the binders of the mdo into scope + -- (Remember that this also removes the binders from the + -- finally-returned free-vars.) + -- And rename each individual stmt, making a + -- singleton segment. At this stage the FwdRefs field + -- isn't finished: it's empty for all except a BindStmt + -- for which it's the fwd refs within the bind itself + -- (This set may not be empty, because we're in a recursive + -- context.) ; rnRecStmtsAndThen rnBody rec_stmts $ \ segs -> do - - { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds)) + { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds)) emptyNameSet segs ; (thing, fvs_later) <- thing_inside bndrs - ; (return_op, fvs1) <- lookupStmtName ctxt returnMName - ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName - ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName - ; let - -- Step 2: Fill in the fwd refs. - -- The segments are all singletons, but their fwd-ref - -- field mentions all the things used by the segment - -- that are bound after their use - segs_w_fwd_refs = addFwdRefs segs - - -- Step 3: Group together the segments to make bigger segments - -- Invariant: in the result, no segment uses a variable - -- bound in a later segment - grouped_segs = glomSegments ctxt segs_w_fwd_refs - - -- Step 4: Turn the segments into Stmts - -- Use RecStmt when and only when there are fwd refs - -- Also gather up the uses from the end towards the - -- start, so we can tell the RecStmt which things are - -- used 'after' the RecStmt - empty_rec_stmt = emptyRecStmt { recS_ret_fn = return_op - , recS_mfix_fn = mfix_op - , recS_bind_fn = bind_op } - (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later - - ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } + ; let (rec_stmts', fvs) = segmentRecStmts ctxt empty_rec_stmt segs fvs_later + ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } rnStmt ctxt _ (L loc (ParStmt segs _ _)) thing_inside - = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName + = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName ; (return_op, fvs3) <- lookupStmtName ctxt returnMName - ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside - ; return ( ([L loc (ParStmt segs' mzip_op bind_op)], thing) + ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside + ; return ( ([L loc (ParStmt segs' mzip_op bind_op)], thing) , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form @@ -819,7 +793,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for -- Rename the stmts and the 'by' expression -- Keep track of the variables mentioned in the 'by' expression - ; ((stmts', (by', used_bndrs, thing)), fvs2) + ; ((stmts', (by', used_bndrs, thing)), fvs2) <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs -> do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by ; (thing, fvs_thing) <- thing_inside bndrs @@ -836,10 +810,10 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for ThenForm -> return (noSyntaxExpr, emptyFVs) _ -> lookupStmtName ctxt fmapName - ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 + ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4 `plusFV` fvs5 bndr_map = used_bndrs `zip` used_bndrs - -- See Note [TransStmt binder map] in HsExpr + -- See Note [TransStmt binder map] in HsExpr ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map) ; return (([L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map @@ -847,7 +821,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for , trS_ret = return_op, trS_bind = bind_op , trS_fmap = fmap_op })], thing), all_fvs) } -rnParallelStmts :: forall thing. HsStmtContext Name +rnParallelStmts :: forall thing. HsStmtContext Name -> SyntaxExpr Name -> [ParStmtBlock RdrName RdrName] -> ([Name] -> RnM (thing, FreeVars)) @@ -860,20 +834,20 @@ rnParallelStmts ctxt return_op segs thing_inside rn_segs :: LocalRdrEnv -> [Name] -> [ParStmtBlock RdrName RdrName] -> RnM (([ParStmtBlock Name Name], thing), FreeVars) - rn_segs _ bndrs_so_far [] + rn_segs _ bndrs_so_far [] = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far ; mapM_ dupErr dups ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs') ; return (([], thing), fvs) } - rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs) + rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs) = do { ((stmts', (used_bndrs, segs', thing)), fvs) <- rnStmts ctxt rnLExpr stmts $ \ bndrs -> setLocalRdrEnv env $ do { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs - ; let used_bndrs = filter (`elemNameSet` fvs) bndrs + ; let used_bndrs = filter (`elemNameSet` fvs) bndrs ; return ((used_bndrs, segs', thing), fvs) } - + ; let seg' = ParStmtBlock stmts' used_bndrs return_op ; return ((seg':segs', thing), fvs) } @@ -884,7 +858,7 @@ rnParallelStmts ctxt return_op segs thing_inside lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars) -- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable -- Neither is ArrowExpr, which has its own desugarer in DsArrows -lookupStmtName ctxt n +lookupStmtName ctxt n = case ctxt of ListComp -> not_rebindable PArrComp -> not_rebindable @@ -896,8 +870,8 @@ lookupStmtName ctxt n MonadComp -> rebindable GhciStmtCtxt -> rebindable -- I suppose? - ParStmtCtxt c -> lookupStmtName c n -- Look inside to - TransStmtCtxt c -> lookupStmtName c n -- the parent context + ParStmtCtxt c -> lookupStmtName c n -- Look inside to + TransStmtCtxt c -> lookupStmtName c n -- the parent context where rebindable = lookupSyntaxName n not_rebindable = return (HsVar n, emptyFVs) @@ -905,36 +879,36 @@ lookupStmtName ctxt n Note [Renaming parallel Stmts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Renaming parallel statements is painful. Given, say +Renaming parallel statements is painful. Given, say [ a+c | a <- as, bs <- bss | c <- bs, a <- ds ] Note that (a) In order to report "Defined by not used" about 'bs', we must rename each group of Stmts with a thing_inside whose FreeVars include at least {a,c} - + (b) We want to report that 'a' is illegally bound in both branches - (c) The 'bs' in the second group must obviously not be captured by + (c) The 'bs' in the second group must obviously not be captured by the binding in the first group -To satisfy (a) we nest the segements. +To satisfy (a) we nest the segements. To satisfy (b) we check for duplicates just before thing_inside. To satisfy (c) we reset the LocalRdrEnv each time. %************************************************************************ -%* * +%* * \subsubsection{mdo expressions} -%* * +%* * %************************************************************************ \begin{code} type FwdRefs = NameSet type Segment stmts = (Defs, - Uses, -- May include defs - FwdRefs, -- A subset of uses that are - -- (a) used before they are bound in this segment, or - -- (b) used here, and bound in subsequent segments - stmts) -- Either Stmt or [Stmt] + Uses, -- May include defs + FwdRefs, -- A subset of uses that are + -- (a) used before they are bound in this segment, or + -- (b) used here, and bound in subsequent segments + stmts) -- Either Stmt or [Stmt] -- wrapper that does both the left- and right-hand sides @@ -946,35 +920,35 @@ rnRecStmtsAndThen :: Outputable (body RdrName) => -> ([Segment (LStmt Name (Located (body Name)))] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) rnRecStmtsAndThen rnBody s cont - = do { -- (A) Make the mini fixity env for all of the stmts - fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) + = do { -- (A) Make the mini fixity env for all of the stmts + fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) - -- (B) Do the LHSes - ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s + -- (B) Do the LHSes + ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s - -- ...bring them and their fixities into scope - ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv) - -- Fake uses of variables introduced implicitly (warning suppression, see #4404) - implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv) - ; bindLocalNamesFV bound_names $ + -- ...bring them and their fixities into scope + ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv) + -- Fake uses of variables introduced implicitly (warning suppression, see #4404) + implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv) + ; bindLocalNamesFV bound_names $ addLocalFixities fix_env bound_names $ do - -- (C) do the right-hand-sides and thing-inside - { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv - ; (res, fvs) <- cont segs - ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses) - ; return (res, fvs) }} + -- (C) do the right-hand-sides and thing-inside + { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv + ; (res, fvs) <- cont segs + ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses) + ; return (res, fvs) }} -- get all the fixity decls in any Let stmt collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName] -collectRecStmtsFixities l = - foldr (\ s -> \acc -> case s of - (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) -> - foldr (\ sig -> \ acc -> case sig of +collectRecStmtsFixities l = + foldr (\ s -> \acc -> case s of + (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) -> + foldr (\ sig -> \ acc -> case sig of (L loc (FixSig s)) -> (L loc s) : acc _ -> acc) acc sigs _ -> acc) [] l - + -- left-hand sides rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv @@ -984,23 +958,23 @@ rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv -- so we don't bother to compute it accurately in the other cases -> RnM [(LStmtLR Name RdrName body, FreeVars)] -rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c)) +rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c)) = return [(L loc (BodyStmt body a b c), emptyFVs)] -rn_rec_stmt_lhs _ (L loc (LastStmt body a)) +rn_rec_stmt_lhs _ (L loc (LastStmt body a)) = return [(L loc (LastStmt body a), emptyFVs)] -rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b)) - = do +rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b)) + = do -- should the ctxt be MDo instead? - (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat + (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat return [(L loc (BindStmt pat' body a b), fv_pat)] rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _))) = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds) -rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) +rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds return [(L loc (LetStmt (HsValBinds binds')), -- Warning: this is bogus; see function invariant @@ -1008,20 +982,20 @@ rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) )] -- XXX Do we need to do something with the return and mfix names? -rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec +rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec = rn_rec_stmts_lhs fix_env stmts -rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo +rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt" (ppr stmt) - -rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo + +rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt" (ppr stmt) rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds)) = panic "rn_rec_stmt LetStmt EmptyLocalBinds" rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv - -> [LStmt RdrName body] + -> [LStmt RdrName body] -> RnM [(LStmtLR Name RdrName body, FreeVars)] rn_rec_stmts_lhs fix_env stmts = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts @@ -1039,41 +1013,41 @@ rn_rec_stmt :: (Outputable (body RdrName)) => (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) -> [Name] -> LStmtLR Name RdrName (Located (body RdrName)) -> FreeVars -> RnM [Segment (LStmt Name (Located (body Name)))] - -- Rename a Stmt that is inside a RecStmt (or mdo) - -- Assumes all binders are already in scope - -- Turns each stmt into a singleton Stmt + -- Rename a Stmt that is inside a RecStmt (or mdo) + -- Assumes all binders are already in scope + -- Turns each stmt into a singleton Stmt rn_rec_stmt rnBody _ (L loc (LastStmt body _)) _ - = do { (body', fv_expr) <- rnBody body - ; (ret_op, fvs1) <- lookupSyntaxName returnMName - ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, + = do { (body', fv_expr) <- rnBody body + ; (ret_op, fvs1) <- lookupSyntaxName returnMName + ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, L loc (LastStmt body' ret_op))] } rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _)) _ = rnBody body `thenM` \ (body', fvs) -> - lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) -> + lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) -> return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, - L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] + L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _)) fv_pat - = rnBody body `thenM` \ (body', fv_expr) -> - lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) -> - lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) -> + = rnBody body `thenM` \ (body', fv_expr) -> + lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) -> + lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) -> let - bndrs = mkNameSet (collectPatBinders pat') - fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 + bndrs = mkNameSet (collectPatBinders pat') + fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 in return [(bndrs, fvs, bndrs `intersectNameSet` fvs, - L loc (BindStmt pat' body' bind_op fail_op))] + L loc (BindStmt pat' body' bind_op fail_op))] rn_rec_stmt _ _ (L _ (LetStmt binds@(HsIPBinds _))) _ = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds) -rn_rec_stmt _ all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do - (binds', du_binds) <- +rn_rec_stmt _ all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do + (binds', du_binds) <- -- fixities and unused are handled above in rnRecStmtsAndThen rnLocalValBindsRHS (mkNameSet all_bndrs) binds' - return [(duDefs du_binds, allUses du_binds, - emptyNameSet, L loc (LetStmt (HsValBinds binds')))] + return [(duDefs du_binds, allUses du_binds, + emptyNameSet, L loc (LetStmt (HsValBinds binds')))] -- no RecStmt case because they get flattened above when doing the LHSes rn_rec_stmt _ _ stmt@(L _ (RecStmt {})) _ @@ -1090,99 +1064,139 @@ rn_rec_stmt _ _ (L _ (LetStmt EmptyLocalBinds)) _ rn_rec_stmts :: Outputable (body RdrName) => (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> [Name] - -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)] + -> [Name] + -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)] -> RnM [Segment (LStmt Name (Located (body Name)))] -rn_rec_stmts rnBody bndrs stmts = +rn_rec_stmts rnBody bndrs stmts = mapM (uncurry (rn_rec_stmt rnBody bndrs)) stmts `thenM` \ segs_s -> return (concat segs_s) --------------------------------------------- +segmentRecStmts :: HsStmtContext Name + -> Stmt Name body + -> [Segment (LStmt Name body)] -> FreeVars + -> ([LStmt Name body], FreeVars) + +segmentRecStmts ctxt empty_rec_stmt segs fvs_later + | MDoExpr <- ctxt + = segsToStmts empty_rec_stmt grouped_segs fvs_later + -- Step 4: Turn the segments into Stmts + -- Use RecStmt when and only when there are fwd refs + -- Also gather up the uses from the end towards the + -- start, so we can tell the RecStmt which things are + -- used 'after' the RecStmt + + | otherwise + = ([ L (getLoc (head ss)) $ + empty_rec_stmt { recS_stmts = ss + , recS_later_ids = nameSetToList (defs `intersectNameSet` fvs_later) + , recS_rec_ids = nameSetToList (defs `intersectNameSet` uses) }] + , uses `plusFV` fvs_later) + + where + (defs_s, uses_s, _, ss) = unzip4 segs + defs = plusFVs defs_s + uses = plusFVs uses_s + + -- Step 2: Fill in the fwd refs. + -- The segments are all singletons, but their fwd-ref + -- field mentions all the things used by the segment + -- that are bound after their use + segs_w_fwd_refs = addFwdRefs segs + + -- Step 3: Group together the segments to make bigger segments + -- Invariant: in the result, no segment uses a variable + -- bound in a later segment + grouped_segs = glomSegments ctxt segs_w_fwd_refs + +---------------------------- addFwdRefs :: [Segment a] -> [Segment a] -- So far the segments only have forward refs *within* the Stmt --- (which happens for bind: x <- ...x...) +-- (which happens for bind: x <- ...x...) -- This function adds the cross-seg fwd ref info -addFwdRefs pairs - = fst (foldr mk_seg ([], emptyNameSet) pairs) +addFwdRefs segs + = fst (foldr mk_seg ([], emptyNameSet) segs) where mk_seg (defs, uses, fwds, stmts) (segs, later_defs) - = (new_seg : segs, all_defs) - where - new_seg = (defs, uses, new_fwds, stmts) - all_defs = later_defs `unionNameSets` defs - new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs) - -- Add the downstream fwd refs here + = (new_seg : segs, all_defs) + where + new_seg = (defs, uses, new_fwds, stmts) + all_defs = later_defs `unionNameSets` defs + new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs) + -- Add the downstream fwd refs here +\end{code} ----------------------------------------------------- --- Glomming the singleton segments of an mdo into --- minimal recursive groups. --- --- At first I thought this was just strongly connected components, but --- there's an important constraint: the order of the stmts must not change. --- --- Consider --- mdo { x <- ...y... --- p <- z --- y <- ...x... --- q <- x --- z <- y --- r <- x } --- --- Here, the first stmt mention 'y', which is bound in the third. --- But that means that the innocent second stmt (p <- z) gets caught --- up in the recursion. And that in turn means that the binding for --- 'z' has to be included... and so on. --- --- Start at the tail { r <- x } --- Now add the next one { z <- y ; r <- x } --- Now add one more { q <- x ; z <- y ; r <- x } --- Now one more... but this time we have to group a bunch into rec --- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x } --- Now one more, which we can add on without a rec --- { p <- z ; --- rec { y <- ...x... ; q <- x ; z <- y } ; --- r <- x } --- Finally we add the last one; since it mentions y we have to --- glom it togeher with the first two groups --- { rec { x <- ...y...; p <- z ; y <- ...x... ; --- q <- x ; z <- y } ; --- r <- x } --- --- NB. June 7 2012: We only glom segments that appear in --- an explicit mdo; and leave those found in "do rec"'s intact. --- See http://hackage.haskell.org/trac/ghc/ticket/4148 for --- the discussion leading to this design choice. +Note [Segmenting mdo] +~~~~~~~~~~~~~~~~~~~~~ +NB. June 7 2012: We only glom segments that appear in an explicit mdo; +and leave those found in "do rec"'s intact. See +http://hackage.haskell.org/trac/ghc/ticket/4148 for the discussion +leading to this design choice. Hence the test in segmentRecStmts. + +Note [Glomming segments] +~~~~~~~~~~~~~~~~~~~~~~~~ +Glomming the singleton segments of an mdo into minimal recursive groups. + +At first I thought this was just strongly connected components, but +there's an important constraint: the order of the stmts must not change. + +Consider + mdo { x <- ...y... + p <- z + y <- ...x... + q <- x + z <- y + r <- x } + +Here, the first stmt mention 'y', which is bound in the third. +But that means that the innocent second stmt (p <- z) gets caught +up in the recursion. And that in turn means that the binding for +'z' has to be included... and so on. + +Start at the tail { r <- x } +Now add the next one { z <- y ; r <- x } +Now add one more { q <- x ; z <- y ; r <- x } +Now one more... but this time we have to group a bunch into rec + { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x } +Now one more, which we can add on without a rec + { p <- z ; + rec { y <- ...x... ; q <- x ; z <- y } ; + r <- x } +Finally we add the last one; since it mentions y we have to +glom it together with the first two groups + { rec { x <- ...y...; p <- z ; y <- ...x... ; + q <- x ; z <- y } ; + r <- x } +\begin{code} glomSegments :: HsStmtContext Name -> [Segment (LStmt Name body)] -> [Segment [LStmt Name body]] +-- See Note [Glomming segments] glomSegments _ [] = [] glomSegments ctxt ((defs,uses,fwds,stmt) : segs) - -- Actually stmts will always be a singleton + -- Actually stmts will always be a singleton = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others where - segs' = glomSegments ctxt segs + segs' = glomSegments ctxt segs (extras, others) = grab uses segs' (ds, us, fs, ss) = unzip4 extras - + seg_defs = plusFVs ds `plusFV` defs seg_uses = plusFVs us `plusFV` uses seg_fwds = plusFVs fs `plusFV` fwds seg_stmts = stmt : concat ss - grab :: NameSet -- The client - -> [Segment a] - -> ([Segment a], -- Needed by the 'client' - [Segment a]) -- Not needed by the client - -- The result is simply a split of the input - grab uses dus - = (reverse yeses, reverse noes) - where - (noes, yeses) = span not_needed (reverse dus) - not_needed (defs,_,_,_) = case ctxt of - MDoExpr -> not (intersectsNameSet defs uses) - _ -> False -- unless we're in mdo, we *need* everything - + grab :: NameSet -- The client + -> [Segment a] + -> ([Segment a], -- Needed by the 'client' + [Segment a]) -- Not needed by the client + -- The result is simply a split of the input + grab uses dus + = (reverse yeses, reverse noes) + where + (noes, yeses) = span not_needed (reverse dus) + not_needed (defs,_,_,_) = not (intersectsNameSet defs uses) ---------------------------------------------------- segsToStmts :: Stmt Name body -- A RecStmt with the SyntaxOps filled in @@ -1196,20 +1210,20 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later (new_stmt : later_stmts, later_uses `plusFV` uses) where (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later - new_stmt | non_rec = head ss - | otherwise = L (getLoc (head ss)) rec_stmt + new_stmt | non_rec = head ss + | otherwise = L (getLoc (head ss)) rec_stmt rec_stmt = empty_rec_stmt { recS_stmts = ss , recS_later_ids = nameSetToList used_later , recS_rec_ids = nameSetToList fwds } non_rec = isSingleton ss && isEmptyNameSet fwds used_later = defs `intersectNameSet` later_uses - -- The ones needed after the RecStmt + -- The ones needed after the RecStmt \end{code} %************************************************************************ -%* * +%* * \subsubsection{Assertion utils} -%* * +%* * %************************************************************************ \begin{code} @@ -1230,22 +1244,22 @@ Note [Adding the implicit parameter to 'assert'] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2). By doing this in the renamer we allow the typechecker to just see the -expanded application and do the right thing. But it's not really +expanded application and do the right thing. But it's not really the Right Thing because there's no way to "undo" if you want to see the original source code. We'll have fix this in due course, when -we care more about being able to reconstruct the exact original +we care more about being able to reconstruct the exact original program. %************************************************************************ -%* * +%* * \subsubsection{Errors} -%* * +%* * %************************************************************************ \begin{code} checkEmptyStmts :: HsStmtContext Name -> RnM () -- We've seen an empty sequence of Stmts... is that ok? -checkEmptyStmts ctxt +checkEmptyStmts ctxt = unless (okEmpty ctxt) (addErr (emptyErr ctxt)) okEmpty :: HsStmtContext a -> Bool @@ -1257,35 +1271,35 @@ emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel com emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'") emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt ----------------------- +---------------------- checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name -> LStmt RdrName (Located (body RdrName)) -> RnM (LStmt RdrName (Located (body RdrName))) checkLastStmt ctxt lstmt@(L loc stmt) - = case ctxt of + = case ctxt of ListComp -> check_comp MonadComp -> check_comp PArrComp -> check_comp - ArrowExpr -> check_do - DoExpr -> check_do + ArrowExpr -> check_do + DoExpr -> check_do MDoExpr -> check_do _ -> check_other where - check_do -- Expect BodyStmt, and change it to LastStmt - = case stmt of + check_do -- Expect BodyStmt, and change it to LastStmt + = case stmt of BodyStmt e _ _ _ -> return (L loc (mkLastStmt e)) LastStmt {} -> return lstmt -- "Deriving" clauses may generate a - -- LastStmt directly (unlike the parser) - _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } + -- LastStmt directly (unlike the parser) + _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt <+> ptext (sLit "must be an expression")) - check_comp -- Expect LastStmt; this should be enforced by the parser! - = case stmt of + check_comp -- Expect LastStmt; this should be enforced by the parser! + = case stmt of LastStmt {} -> return lstmt _ -> pprPanic "checkLastStmt" (ppr lstmt) - check_other -- Behave just as if this wasn't the last stmt + check_other -- Behave just as if this wasn't the last stmt = do { checkStmt ctxt lstmt; return lstmt } -- Checking when a particular Stmt is ok @@ -1294,7 +1308,7 @@ checkStmt :: HsStmtContext Name -> RnM () checkStmt ctxt (L _ stmt) = do { dflags <- getDynFlags - ; case okStmt dflags ctxt stmt of + ; case okStmt dflags ctxt stmt of Nothing -> return () Just extra -> addErr (msg $$ extra) } where @@ -1321,17 +1335,17 @@ okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt -- Return Nothing if OK, (Just extra) if not ok -- The "extra" is an SDoc that is appended to an generic error message -okStmt dflags ctxt stmt +okStmt dflags ctxt stmt = case ctxt of - PatGuard {} -> okPatGuardStmt stmt - ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt - DoExpr -> okDoStmt dflags ctxt stmt - MDoExpr -> okDoStmt dflags ctxt stmt - ArrowExpr -> okDoStmt dflags ctxt stmt + PatGuard {} -> okPatGuardStmt stmt + ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt + DoExpr -> okDoStmt dflags ctxt stmt + MDoExpr -> okDoStmt dflags ctxt stmt + ArrowExpr -> okDoStmt dflags ctxt stmt GhciStmtCtxt -> okDoStmt dflags ctxt stmt - ListComp -> okCompStmt dflags ctxt stmt - MonadComp -> okCompStmt dflags ctxt stmt - PArrComp -> okPArrStmt dflags ctxt stmt + ListComp -> okCompStmt dflags ctxt stmt + MonadComp -> okCompStmt dflags ctxt stmt + PArrComp -> okPArrStmt dflags ctxt stmt TransStmtCtxt ctxt -> okStmt dflags ctxt stmt ------------- @@ -1354,7 +1368,7 @@ okDoStmt dflags ctxt stmt = case stmt of RecStmt {} | Opt_RecursiveDo `xopt` dflags -> isOK - | ArrowExpr <- ctxt -> isOK -- Arrows allows 'rec' + | ArrowExpr <- ctxt -> isOK -- Arrows allows 'rec' | otherwise -> Just (ptext (sLit "Use -XRecursiveDo")) BindStmt {} -> isOK LetStmt {} -> isOK @@ -1367,10 +1381,10 @@ okCompStmt dflags _ stmt BindStmt {} -> isOK LetStmt {} -> isOK BodyStmt {} -> isOK - ParStmt {} + ParStmt {} | Opt_ParallelListComp `xopt` dflags -> isOK | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) - TransStmt {} + TransStmt {} | Opt_TransformListComp `xopt` dflags -> isOK | otherwise -> Just (ptext (sLit "Use -XTransformListComp")) RecStmt {} -> notOK @@ -1382,7 +1396,7 @@ okPArrStmt dflags _ stmt BindStmt {} -> isOK LetStmt {} -> isOK BodyStmt {} -> isOK - ParStmt {} + ParStmt {} | Opt_ParallelListComp `xopt` dflags -> isOK | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) TransStmt {} -> notOK @@ -1392,8 +1406,8 @@ okPArrStmt dflags _ stmt --------- checkTupleSection :: [HsTupArg RdrName] -> RnM () checkTupleSection args - = do { tuple_section <- xoptM Opt_TupleSections - ; checkErr (all tupArgPresent args || tuple_section) msg } + = do { tuple_section <- xoptM Opt_TupleSections + ; checkErr (all tupArgPresent args || tuple_section) msg } where msg = ptext (sLit "Illegal tuple section: use -XTupleSections") @@ -1405,11 +1419,11 @@ sectionErr expr patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"), - nest 4 (ppr e)]) - ; return (EWildPat, emptyFVs) } + nest 4 (ppr e)]) + ; return (EWildPat, emptyFVs) } badIpBinds :: Outputable a => SDoc -> a -> SDoc badIpBinds what binds = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what) - 2 (ppr binds) + 2 (ppr binds) \end{code} diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 2055f8a989..203e1e271c 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -476,7 +476,7 @@ getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName -> RnM ((TcGblEnv, TcLclEnv), NameSet) -- Get all the top-level binders bound the group *except* -- for value bindings, which are treated separately --- Specificaly we return AvailInfo for +-- Specifically we return AvailInfo for -- type decls (incl constructors and record selectors) -- class decls (including class ops) -- associated types @@ -596,8 +596,7 @@ filterImports iface decl_spec Nothing filterImports iface decl_spec (Just (want_hiding, import_items)) = do -- check for errors, convert RdrNames to Names - opt_typeFamilies <- xoptM Opt_TypeFamilies - items1 <- mapM (lookup_lie opt_typeFamilies) import_items + items1 <- mapM lookup_lie import_items let items2 :: [(LIE Name, AvailInfo)] items2 = concat items1 @@ -646,12 +645,18 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) (name, AvailTC name subs, Just parent) combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y) - lookup_lie :: Bool -> LIE RdrName -> TcRn [(LIE Name, AvailInfo)] - lookup_lie opt_typeFamilies (L loc ieRdr) - = do - (stuff, warns) <- setSrcSpan loc . - liftM (fromMaybe ([],[])) $ - run_lookup (lookup_ie opt_typeFamilies ieRdr) + lookup_name :: RdrName -> IELookupM (Name, AvailInfo, Maybe Name) + lookup_name rdr | isQual rdr = failLookupWith (QualImportError rdr) + | Just succ <- mb_success = return succ + | otherwise = failLookupWith BadImport + where + mb_success = lookupOccEnv occ_env (rdrNameOcc rdr) + + lookup_lie :: LIE RdrName -> TcRn [(LIE Name, AvailInfo)] + lookup_lie (L loc ieRdr) + = do (stuff, warns) <- setSrcSpan loc $ + liftM (fromMaybe ([],[])) $ + run_lookup (lookup_ie ieRdr) mapM_ emit_warning warns return [ (L loc ie, avail) | (ie,avail) <- stuff ] where @@ -672,9 +677,6 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) BadImport -> badImportItemErr iface decl_spec ieRdr all_avails IllegalImport -> illegalImportItemErr QualImportError rdr -> qualImportItemErr rdr - TypeItemError children -> typeItemErr - (head . filter isTyConName $ children) - (text "in import list") -- For each import item, we convert its RdrNames to Names, -- and at the same time construct an AvailInfo corresponding @@ -686,15 +688,8 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) -- data constructors of an associated family, we need separate -- AvailInfos for the data constructors and the family (as they have -- different parents). See the discussion at occ_env. - lookup_ie :: Bool -> IE RdrName -> IELookupM ([(IE Name, AvailInfo)], [IELookupWarning]) - lookup_ie opt_typeFamilies ie = handle_bad_import $ do - let lookup_name rdr - | isQual rdr - = failLookupWith (QualImportError rdr) - | Just nm <- lookupOccEnv occ_env (rdrNameOcc rdr) - = return nm - | otherwise - = failLookupWith BadImport + lookup_ie :: IE RdrName -> IELookupM ([(IE Name, AvailInfo)], [IELookupWarning]) + lookup_ie ie = handle_bad_import $ do case ie of IEVar n -> do (name, avail, _) <- lookup_name n @@ -702,13 +697,9 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) IEThingAll tc -> do (name, avail@(AvailTC name2 subs), mb_parent) <- lookup_name tc - let warns - | null (drop 1 subs) - = [DodgyImport tc] - | not (is_qual decl_spec) - = [MissingImportList] - | otherwise - = [] + let warns | null (drop 1 subs) = [DodgyImport tc] + | not (is_qual decl_spec) = [MissingImportList] + | otherwise = [] case mb_parent of -- non-associated ty/cls Nothing -> return ([(IEThingAll name, avail)], warns) @@ -734,15 +725,14 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) IEThingWith tc ns -> do (name, AvailTC _ subnames, mb_parent) <- lookup_name tc - let - env = mkOccEnv [(nameOccName s, s) | s <- subnames] - mb_children = map (lookupOccEnv env . rdrNameOcc) ns + + -- Look up the children in the sub-names of the parent + let mb_children = lookupChildren subnames ns + children <- if any isNothing mb_children then failLookupWith BadImport else return (catMaybes mb_children) - -- check for proper import of type families - when (not opt_typeFamilies && any isTyConName children) $ - failLookupWith (TypeItemError children) + case mb_parent of -- non-associated ty/cls Nothing -> return ([(IEThingWith name children, @@ -779,7 +769,6 @@ data IELookupError = QualImportError RdrName | BadImport | IllegalImport - | TypeItemError [Name] failLookupWith :: IELookupError -> IELookupM a failLookupWith err = Failed err @@ -864,6 +853,19 @@ mkChildEnv gres = foldr add emptyNameEnv gres findChildren :: NameEnv [Name] -> Name -> [Name] findChildren env n = lookupNameEnv env n `orElse` [] +lookupChildren :: [Name] -> [RdrName] -> [Maybe Name] +-- (lookupChildren all_kids rdr_items) maps each rdr_item to its +-- corresponding Name all_kids, if the former exists +-- The matching is done by FastString, not OccName, so that +-- Cls( meth, AssocTy ) +-- will correctly find AssocTy among the all_kids of Cls, even though +-- the RdrName for AssocTy may have a (bogus) DataName namespace +-- (Really the rdr_items should be FastStrings in the first place.) +lookupChildren all_kids rdr_items + = map (lookupFsEnv kid_env . occNameFS . rdrNameOcc) rdr_items + where + kid_env = mkFsEnv [(occNameFS (nameOccName n), n) | n <- all_kids] + -- | Combines 'AvailInfo's from the same family -- 'avails' may have several items with the same availName -- E.g import Ix( Ix(..), index ) @@ -966,7 +968,7 @@ rnExports explicit_mod exports ; let real_exports | explicit_mod = exports | ghcLink dflags == LinkInMemory = Nothing - | otherwise = Just ([noLoc (IEVar main_RDR_Unqual)]) + | otherwise = Just [noLoc (IEVar main_RDR_Unqual)] -- ToDo: the 'noLoc' here is unhelpful if 'main' -- turns out to be out of scope @@ -1103,20 +1105,12 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod if isUnboundName name then return (IEThingWith name [], AvailTC name [name]) else do - let env = mkOccEnv [ (nameOccName s, s) - | s <- findChildren kids_env name ] - mb_names = map (lookupOccEnv env . rdrNameOcc) sub_rdrs + let mb_names = lookupChildren (findChildren kids_env name) sub_rdrs if any isNothing mb_names then do addErr (exportItemErr ie) return (IEThingWith name [], AvailTC name [name]) else do let names = catMaybes mb_names addUsedKids rdr names - optTyFam <- xoptM Opt_TypeFamilies - when (not optTyFam && any isTyConName names) $ - addErr (typeItemErr ( head - . filter isTyConName - $ names ) - (text "in export list")) return (IEThingWith name names, AvailTC name (name:names)) lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier @@ -1318,12 +1312,9 @@ warnUnusedImportDecls gbl_env ; whenGOptM Opt_D_dump_minimal_imports $ printMinimalImports usage } where - explicit_import (L _ decl) = unLoc (ideclName decl) /= pRELUDE_NAME + explicit_import (L _ decl) = not (ideclImplicit decl) -- Filter out the implicit Prelude import -- which we do not want to bleat about - -- This also filters out an *explicit* Prelude import - -- but solving that problem involves more plumbing, and - -- it just doesn't seem worth it \end{code} @@ -1621,11 +1612,6 @@ exportItemErr export_item = sep [ ptext (sLit "The export item") <+> quotes (ppr export_item), ptext (sLit "attempts to export constructors or class methods that are not visible here") ] -typeItemErr :: Name -> SDoc -> SDoc -typeItemErr name wherestr - = sep [ ptext (sLit "Using 'type' tag on") <+> quotes (ppr name) <+> wherestr, - ptext (sLit "Use -XTypeFamilies to enable this extension") ] - exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName -> MsgDoc exportClashErr global_env name1 name2 ie1 ie2 diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index a039f36b25..205dde1969 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -330,8 +330,17 @@ rnPatAndThen mk (VarPat rdr) = do { loc <- liftCps getSrcSpanM -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) rnPatAndThen mk (SigPatIn pat sig) - = do { pat' <- rnLPatAndThen mk pat - ; sig' <- rnHsSigCps sig + -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is + -- important to rename its type signature _before_ renaming the rest of the + -- pattern, so that type variables are first bound by the _outermost_ pattern + -- type signature they occur in. This keeps the type checker happy when + -- pattern type signatures happen to be nested (#7827) + -- + -- f ((Just (x :: a) :: Maybe a) + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^ `a' is first bound here + -- ~~~~~~~~~~~~~~~^ the same `a' then used here + = do { sig' <- rnHsSigCps sig + ; pat' <- rnLPatAndThen mk pat ; return (SigPatIn pat' sig') } rnPatAndThen mk (LitPat lit) diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index cc410388df..e1236cac10 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -542,10 +542,9 @@ rnFamInstDecl doc mb_cls tycon pats payload rnPayload rnTyFamInstDecl :: Maybe (Name, [Name]) -> TyFamInstDecl RdrName -> RnM (TyFamInstDecl Name, FreeVars) -rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqns = eqns, tfid_group = group }) - = do { (eqns', fvs) <- rnList (rnTyFamInstEqn mb_cls) eqns - ; return (TyFamInstDecl { tfid_eqns = eqns' - , tfid_group = group +rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn }) + = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn + ; return (TyFamInstDecl { tfid_eqn = L loc eqn' , tfid_fvs = fvs }, fvs) } rnTyFamInstEqn :: Maybe (Name, [Name]) @@ -1044,16 +1043,27 @@ rnFamDecl :: Maybe Name -> FamilyDecl RdrName -> RnM (FamilyDecl Name, FreeVars) rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars - , fdFlavour = flav, fdKindSig = kind }) - = bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' -> - do { tycon' <- lookupLocatedTopBndrRn tycon - ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind + , fdInfo = info, fdKindSig = kind }) + = do { ((tycon', tyvars', kind'), fv1) <- + bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' -> + do { tycon' <- lookupLocatedTopBndrRn tycon + ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind + ; return ((tycon', tyvars', kind'), fv_kind) } + ; (info', fv2) <- rn_info info ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars' - , fdFlavour = flav, fdKindSig = kind' } - , fv_kind ) } + , fdInfo = info', fdKindSig = kind' } + , fv1 `plusFV` fv2) } where fmly_doc = TyFamilyCtx tycon kvs = extractRdrKindSigVars kind + + rn_info (ClosedTypeFamily eqns) + = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns + -- no class context, + ; return (ClosedTypeFamily eqns', fvs) } + rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs) + rn_info DataFamily = return (DataFamily, emptyFVs) + \end{code} Note [Stupid theta] diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 95bdcb413f..a1c4bac25c 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -4,26 +4,19 @@ \section[RnSource]{Main pass of renamer} \begin{code} -{-# 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 RnTypes ( - -- Type related stuff - rnHsType, rnLHsType, rnLHsTypes, rnContext, +module RnTypes ( + -- Type related stuff + rnHsType, rnLHsType, rnLHsTypes, rnContext, rnHsKind, rnLHsKind, rnLHsMaybeKind, - rnHsSigType, rnLHsInstType, rnConDeclFields, + rnHsSigType, rnLHsInstType, rnConDeclFields, newTyVarNameRn, - -- Precence related stuff - mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, - checkPrecMatch, checkSectionPrec, warnUnusedForAlls, + -- Precence related stuff + mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, + checkPrecMatch, checkSectionPrec, warnUnusedForAlls, - -- Splice related stuff - rnSplice, checkTH, + -- Splice related stuff + rnSplice, checkTH, -- Binding related stuff bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig, @@ -34,7 +27,7 @@ module RnTypes ( import {-# SOURCE #-} RnExpr( rnLExpr ) #ifdef GHCI import {-# SOURCE #-} TcSplice( runQuasiQuoteType ) -#endif /* GHCI */ +#endif /* GHCI */ import DynFlags import HsSyn @@ -49,13 +42,13 @@ import SrcLoc import NameSet import Util -import BasicTypes ( compareFixity, funTyFixity, negateFixity, - Fixity(..), FixityDirection(..) ) +import BasicTypes ( compareFixity, funTyFixity, negateFixity, + Fixity(..), FixityDirection(..) ) import Outputable import FastString import Maybes import Data.List ( nub ) -import Control.Monad ( unless, when ) +import Control.Monad ( unless, when ) #include "HsVersions.h" \end{code} @@ -64,20 +57,20 @@ These type renamers are in a separate module, rather than in (say) RnSource, to break several loop. %********************************************************* -%* * +%* * \subsection{Renaming types} -%* * +%* * %********************************************************* \begin{code} rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) - -- rnHsSigType is used for source-language type signatures, - -- which use *implicit* universal quantification. + -- rnHsSigType is used for source-language type signatures, + -- which use *implicit* universal quantification. rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -- Rename the type in an instance or standalone deriving decl -rnLHsInstType doc_str ty +rnLHsInstType doc_str ty = do { (ty', fvs) <- rnLHsType (GenericCtx doc_str) ty ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty)) ; return (ty', fvs) } @@ -88,7 +81,7 @@ rnLHsInstType doc_str ty | otherwise = False badInstTy :: LHsType RdrName -> SDoc -badInstTy ty = ptext (sLit "Malformed instance:") <+> ppr ty +badInstTy ty = ptext (sLit "Malformed instance:") <+> ppr ty \end{code} rnHsType is here because we call it from loadInstDecl, and I didn't @@ -98,7 +91,7 @@ want a gratuitous knot. rnLHsTyKi :: Bool -- True <=> renaming a type, False <=> a kind -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) rnLHsTyKi isType doc (L loc ty) - = setSrcSpan loc $ + = setSrcSpan loc $ do { (ty', fvs) <- rnHsTyKi isType doc ty ; return (L loc ty', fvs) } @@ -110,9 +103,9 @@ rnLHsKind = rnLHsTyKi False rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName) -> RnM (Maybe (LHsKind Name), FreeVars) -rnLHsMaybeKind _ Nothing +rnLHsMaybeKind _ Nothing = return (Nothing, emptyFVs) -rnLHsMaybeKind doc (Just kind) +rnLHsMaybeKind doc (Just kind) = do { (kind', fvs) <- rnLHsKind doc kind ; return (Just kind', fvs) } @@ -123,15 +116,15 @@ rnHsKind = rnHsTyKi False rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) -rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty) - = ASSERT ( isType ) do - -- Implicit quantifiction in source code (no kinds on tyvars) - -- Given the signature C => T we universally quantify - -- over FV(T) \ {in-scope-tyvars} +rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty) + = ASSERT( isType ) do + -- Implicit quantifiction in source code (no kinds on tyvars) + -- Given the signature C => T we universally quantify + -- over FV(T) \ {in-scope-tyvars} rdr_env <- getLocalRdrEnv loc <- getSrcSpanM let - (forall_kvs, forall_tvs) = filterInScope rdr_env $ + (forall_kvs, forall_tvs) = filterInScope rdr_env $ extractHsTysRdrTyVars (ty:ctxt) -- In for-all types we don't bring in scope -- kind variables mentioned in kind signatures @@ -139,17 +132,17 @@ rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty) -- f :: Int -> T (a::k) -- Not allowed -- The filterInScope is to ensure that we don't quantify over - -- type variables that are in scope; when GlasgowExts is off, - -- there usually won't be any, except for class signatures: - -- class C a where { op :: a -> a } - tyvar_bndrs = userHsTyVarBndrs loc forall_tvs + -- type variables that are in scope; when GlasgowExts is off, + -- there usually won't be any, except for class signatures: + -- class C a where { op :: a -> a } + tyvar_bndrs = userHsTyVarBndrs loc forall_tvs rnForAll doc Implicit forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars lctxt@(L _ ctxt) tau) - = ASSERT ( isType ) do { -- Explicit quantification. - -- Check that the forall'd tyvars are actually - -- mentioned in the type, and produce a warning if not + = ASSERT( isType ) do { -- Explicit quantification. + -- Check that the forall'd tyvars are actually + -- mentioned in the type, and produce a warning if not let (kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt) in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty) ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned @@ -164,17 +157,17 @@ rnHsTyKi isType _ (HsTyVar rdr_name) -- a sensible error message, but we don't want to complain about the dot too -- Hence the jiggery pokery with ty1 rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2) - = ASSERT ( isType ) setSrcSpan loc $ - do { ops_ok <- xoptM Opt_TypeOperators - ; op' <- if ops_ok - then rnTyVar isType op - else do { addErr (opTyErr op ty) - ; return (mkUnboundName op) } -- Avoid double complaint - ; let l_op' = L loc op' - ; fix <- lookupTyFixityRn l_op' - ; (ty1', fvs1) <- rnLHsType doc ty1 - ; (ty2', fvs2) <- rnLHsType doc ty2 - ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) + = ASSERT( isType ) setSrcSpan loc $ + do { ops_ok <- xoptM Opt_TypeOperators + ; op' <- if ops_ok + then rnTyVar isType op + else do { addErr (opTyErr op ty) + ; return (mkUnboundName op) } -- Avoid double complaint + ; let l_op' = L loc op' + ; fix <- lookupTyFixityRn l_op' + ; (ty1', fvs1) <- rnLHsType doc ty1 + ; (ty2', fvs2) <- rnLHsType doc ty2 + ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) op' fix ty1' ty2' ; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') } @@ -183,23 +176,24 @@ rnHsTyKi isType doc (HsParTy ty) ; return (HsParTy ty', fvs) } rnHsTyKi isType doc (HsBangTy b ty) - = ASSERT ( isType ) + = ASSERT( isType ) do { (ty', fvs) <- rnLHsType doc ty ; return (HsBangTy b ty', fvs) } -rnHsTyKi isType doc (HsRecTy flds) - = ASSERT ( isType ) - do { (flds', fvs) <- rnConDeclFields doc flds +rnHsTyKi _ doc ty@(HsRecTy flds) + = do { addErr (hang (ptext (sLit "Record syntax is illegal here:")) + 2 (ppr ty)) + ; (flds', fvs) <- rnConDeclFields doc flds ; return (HsRecTy flds', fvs) } rnHsTyKi isType doc (HsFunTy ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1 - -- Might find a for-all as the arg of a function type + -- Might find a for-all as the arg of a function type ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2 - -- Or as the result. This happens when reading Prelude.hi - -- when we find return :: forall m. Monad m -> forall a. a -> m a + -- Or as the result. This happens when reading Prelude.hi + -- when we find return :: forall m. Monad m -> forall a. a -> m a - -- Check for fixity rearrangements + -- Check for fixity rearrangements ; res_ty <- if isType then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' else return (HsFunTy ty1' ty2') @@ -212,15 +206,18 @@ rnHsTyKi isType doc listTy@(HsListTy ty) ; return (HsListTy ty', fvs) } rnHsTyKi isType doc (HsKindSig ty k) - = ASSERT ( isType ) + = ASSERT( isType ) do { kind_sigs_ok <- xoptM Opt_KindSignatures ; unless kind_sigs_ok (badSigErr False doc ty) ; (ty', fvs1) <- rnLHsType doc ty ; (k', fvs2) <- rnLHsKind doc k ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) } -rnHsTyKi isType doc (HsPArrTy ty) - = ASSERT ( isType ) +rnHsTyKi _ doc (HsRoleAnnot ty _) + = illegalRoleAnnotDoc doc ty >> failM + +rnHsTyKi isType doc (HsPArrTy ty) + = ASSERT( isType ) do { (ty', fvs) <- rnLHsType doc ty ; return (HsPArrTy ty', fvs) } @@ -249,19 +246,19 @@ rnHsTyKi isType doc (HsIParamTy n ty) do { (ty', fvs) <- rnLHsType doc ty ; return (HsIParamTy n ty', fvs) } -rnHsTyKi isType doc (HsEqTy ty1 ty2) +rnHsTyKi isType doc (HsEqTy ty1 ty2) = ASSERT( isType ) do { (ty1', fvs1) <- rnLHsType doc ty1 ; (ty2', fvs2) <- rnLHsType doc ty2 ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) } rnHsTyKi isType _ (HsSpliceTy sp _ k) - = ASSERT ( isType ) - do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs + = ASSERT( isType ) + do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs ; return (HsSpliceTy sp' fvs k, fvs) } -rnHsTyKi isType doc (HsDocTy ty haddock_doc) - = ASSERT ( isType ) +rnHsTyKi isType doc (HsDocTy ty haddock_doc) + = ASSERT( isType ) do { (ty', fvs) <- rnLHsType doc ty ; haddock_doc' <- rnLHsDoc haddock_doc ; return (HsDocTy ty' haddock_doc', fvs) } @@ -269,19 +266,19 @@ rnHsTyKi isType doc (HsDocTy ty haddock_doc) #ifndef GHCI rnHsTyKi _ _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty) #else -rnHsTyKi isType doc (HsQuasiQuoteTy qq) - = ASSERT ( isType ) +rnHsTyKi isType doc (HsQuasiQuoteTy qq) + = ASSERT( isType ) do { ty <- runQuasiQuoteType qq ; rnHsType doc (unLoc ty) } #endif -rnHsTyKi isType _ (HsCoreTy ty) - = ASSERT ( isType ) +rnHsTyKi isType _ (HsCoreTy ty) + = ASSERT( isType ) return (HsCoreTy ty, emptyFVs) - -- The emptyFVs probably isn't quite right + -- The emptyFVs probably isn't quite right -- but I don't think it matters -rnHsTyKi _ _ (HsWrapTy {}) +rnHsTyKi _ _ (HsWrapTy {}) = panic "rnHsTyKi" rnHsTyKi isType doc ty@(HsExplicitListTy k tys) @@ -291,7 +288,7 @@ rnHsTyKi isType doc ty@(HsExplicitListTy k tys) ; (tys', fvs) <- rnLHsTypes doc tys ; return (HsExplicitListTy k tys', fvs) } -rnHsTyKi isType doc ty@(HsExplicitTupleTy kis tys) +rnHsTyKi isType doc ty@(HsExplicitTupleTy kis tys) = ASSERT( isType ) do { data_kinds <- xoptM Opt_DataKinds ; unless data_kinds (addErr (dataKindsErr isType ty)) @@ -313,60 +310,60 @@ rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys \begin{code} -rnForAll :: HsDocContext -> HsExplicitFlag +rnForAll :: HsDocContext -> HsExplicitFlag -> [RdrName] -- Kind variables -> LHsTyVarBndrs RdrName -- Type variables - -> LHsContext RdrName -> LHsType RdrName + -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name, FreeVars) rnForAll doc exp kvs forall_tyvars ctxt ty | null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt) = rnHsType doc (unLoc ty) - -- One reason for this case is that a type like Int# - -- starts off as (HsForAllTy Nothing [] Int), in case - -- there is some quantification. Now that we have quantified - -- and discovered there are no type variables, it's nicer to turn - -- it into plain Int. If it were Int# instead of Int, we'd actually - -- get an error, because the body of a genuine for-all is - -- of kind *. + -- One reason for this case is that a type like Int# + -- starts off as (HsForAllTy Nothing [] Int), in case + -- there is some quantification. Now that we have quantified + -- and discovered there are no type variables, it's nicer to turn + -- it into plain Int. If it were Int# instead of Int, we'd actually + -- get an error, because the body of a genuine for-all is + -- of kind *. | otherwise = bindHsTyVars doc Nothing kvs forall_tyvars $ \ new_tyvars -> do { (new_ctxt, fvs1) <- rnContext doc ctxt ; (new_ty, fvs2) <- rnLHsType doc ty ; return (HsForAllTy exp new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) } - -- Retain the same implicit/explicit flag as before - -- so that we can later print it correctly + -- Retain the same implicit/explicit flag as before + -- so that we can later print it correctly --------------- bindSigTyVarsFV :: [Name] - -> RnM (a, FreeVars) - -> RnM (a, FreeVars) + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) -- Used just before renaming the defn of a function -- with a separate type signature, to bring its tyvars into scope -- With no -XScopedTypeVariables, this is a no-op bindSigTyVarsFV tvs thing_inside - = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables - ; if not scoped_tyvars then - thing_inside - else - bindLocalNamesFV tvs thing_inside } + = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables + ; if not scoped_tyvars then + thing_inside + else + bindLocalNamesFV tvs thing_inside } --------------- -bindHsTyVars :: HsDocContext +bindHsTyVars :: HsDocContext -> Maybe a -- Just _ => an associated type decl -> [RdrName] -- Kind variables from scope -> LHsTyVarBndrs RdrName -- Type variables -> (LHsTyVarBndrs Name -> RnM (b, FreeVars)) -> RnM (b, FreeVars) --- (a) Bring kind variables into scope --- both (i) passed in (kv_bndrs) +-- (a) Bring kind variables into scope +-- both (i) passed in (kv_bndrs) -- and (ii) mentioned in the kinds of tv_bndrs -- (b) Bring type variables into scope bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside = do { rdr_env <- getLocalRdrEnv ; let tvs = hsQTvBndrs tv_bndrs - kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs + kvs_from_tv_bndrs = [ kv | L _ (HsTyVarBndr _ (Just kind) _) <- tvs , let (_, kvs) = extractHsTyRdrTyVars kind , kv <- kvs ] all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) $ @@ -377,26 +374,30 @@ bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside -- We disallow this: too confusing! ; poly_kind <- xoptM Opt_PolyKinds - ; unless (poly_kind || null all_kvs) + ; unless (poly_kind || null all_kvs) (addErr (badKindBndrs doc all_kvs)) - ; unless (null overlap_kvs) + ; unless (null overlap_kvs) (addErr (overlappingKindVars doc overlap_kvs)) ; loc <- getSrcSpanM ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs - ; bindLocalNamesFV kv_names $ + ; bindLocalNamesFV kv_names $ do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs - rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars) - rn_tv_bndr (L loc (UserTyVar rdr)) - = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr - ; return (L loc (UserTyVar nm), emptyFVs) } - rn_tv_bndr (L loc (KindedTyVar rdr kind)) - = do { sig_ok <- xoptM Opt_KindSignatures - ; unless sig_ok (badSigErr False doc kind) - ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr - ; (kind', fvs) <- rnLHsKind doc kind - ; return (L loc (KindedTyVar nm kind'), fvs) } + rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars) + rn_tv_bndr (L loc (HsTyVarBndr name mkind mrole)) + = do { ksig_ok <- xoptM Opt_KindSignatures + ; unless ksig_ok $ + whenIsJust mkind $ \k -> badSigErr False doc k + ; rsig_ok <- xoptM Opt_RoleAnnotations + ; unless rsig_ok $ + whenIsJust mrole $ \_ -> badRoleAnnotOpt loc doc + ; nm <- newTyVarNameRn mb_assoc rdr_env loc name + ; (mkind', fvs) <- case mkind of + Just k -> do { (kind', fvs) <- rnLHsKind doc k + ; return (Just kind', fvs) } + Nothing -> return (Nothing, emptyFVs) + ; return (L loc (HsTyVarBndr nm mkind' mrole), fvs) } -- Check for duplicate or shadowed tyvar bindrs ; checkDupRdrNames tv_names_w_loc @@ -413,8 +414,8 @@ newTyVarNameRn :: Maybe a -> LocalRdrEnv -> SrcSpan -> RdrName -> RnM Name newTyVarNameRn mb_assoc rdr_env loc rdr | Just _ <- mb_assoc -- Use the same Name as the parent class decl , Just n <- lookupLocalRdrEnv rdr_env rdr - = return n - | otherwise + = return n + | otherwise = newLocalBndrRn (L loc rdr) -------------------------------- @@ -431,16 +432,16 @@ rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside , not (tv `elemLocalRdrEnv` name_env) ] ; kv_names <- newLocalBndrsRn [L loc kv | kv <- kv_bndrs , not (kv `elemLocalRdrEnv` name_env) ] - ; bindLocalNamesFV kv_names $ - bindLocalNamesFV tv_names $ + ; bindLocalNamesFV kv_names $ + bindLocalNamesFV tv_names $ do { (ty', fvs1) <- rnLHsType doc ty ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty', hswb_kvs = kv_names, hswb_tvs = tv_names }) ; return (res, fvs1 `plusFV` fvs2) } } overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc overlappingKindVars doc kvs - = vcat [ ptext (sLit "Kind variable") <> plural kvs <+> - ptext (sLit "also used as type variable") <> plural kvs + = vcat [ ptext (sLit "Kind variable") <> plural kvs <+> + ptext (sLit "also used as type variable") <> plural kvs <> colon <+> pprQuotedList kvs , docOfHsDocContext doc ] @@ -454,7 +455,7 @@ badKindBndrs doc kvs badSigErr :: Bool -> HsDocContext -> LHsType RdrName -> TcM () badSigErr is_type doc (L loc ty) = setSrcSpan loc $ addErr $ - vcat [ hang (ptext (sLit "Illegal") <+> what + vcat [ hang (ptext (sLit "Illegal") <+> what <+> ptext (sLit "signature:") <+> quotes (ppr ty)) 2 (ptext (sLit "Perhaps you intended to use") <+> flag) , docOfHsDocContext doc ] @@ -471,16 +472,29 @@ dataKindsErr is_type thing where what | is_type = ptext (sLit "type") | otherwise = ptext (sLit "kind") + +badRoleAnnotOpt :: SrcSpan -> HsDocContext -> TcM () +badRoleAnnotOpt loc doc + = setSrcSpan loc $ addErr $ + vcat [ ptext (sLit "Illegal role annotation") + , ptext (sLit "Perhaps you intended to use -XRoleAnnotations") + , docOfHsDocContext doc ] + +illegalRoleAnnotDoc :: HsDocContext -> LHsType RdrName -> TcM () +illegalRoleAnnotDoc doc (L loc ty) + = setSrcSpan loc $ addErr $ + vcat [ ptext (sLit "Illegal role annotation on") <+> (ppr ty) + , docOfHsDocContext doc ] \end{code} -Note [Renaming associated types] +Note [Renaming associated types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Check that the RHS of the decl mentions only type variables bound on the LHS. For example, this is not ok class C a b where type F a x :: * instance C (p,q) r where - type F (p,q) x = (x, r) -- BAD: mentions 'r' + type F (p,q) x = (x, r) -- BAD: mentions 'r' c.f. Trac #5515 What makes it tricky is that the *kind* variable from the class *are* @@ -488,8 +502,8 @@ in scope (Trac #5862): class Category (x :: k -> k -> *) where type Ob x :: k -> Constraint id :: Ob x a => x a a - (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c -Here 'k' is in scope in the kind signature even though it's not + (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c +Here 'k' is in scope in the kind signature even though it's not explicitly mentioned on the LHS of the type Ob declaration. We could force you to mention k explicitly, thus @@ -499,13 +513,13 @@ but it seems tiresome to do so. %********************************************************* -%* * +%* * \subsection{Contexts and predicates} -%* * +%* * %********************************************************* \begin{code} -rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] +rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] -> RnM ([ConDeclField Name], FreeVars) rnConDeclFields doc fields = mapFvRn (rnField doc) fields @@ -517,16 +531,16 @@ rnField doc (ConDeclField name ty haddock_doc) ; return (ConDeclField new_name new_ty new_haddock_doc, fvs) } rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) -rnContext doc (L loc cxt) +rnContext doc (L loc cxt) = do { (cxt', fvs) <- rnLHsTypes doc cxt ; return (L loc cxt', fvs) } \end{code} %************************************************************************ -%* * - Fixities and precedence parsing -%* * +%* * + Fixities and precedence parsing +%* * %************************************************************************ @mkOpAppRn@ deals with operator fixities. The argument expressions @@ -539,9 +553,9 @@ operator application. Why? Because the parser parses all operator appications left-associatively, EXCEPT negation, which we need to handle specially. Infix types are read in a *right-associative* way, so that - a `op` b `op` c + a `op` b `op` c is always read in as - a `op` (b `op` c) + a `op` (b `op` c) mkHsOpTyRn rearranges where necessary. The two arguments have already been renamed and rearranged. It's made rather tiresome @@ -551,46 +565,46 @@ by the presence of ->, which is a separate syntactic construct. --------------- -- Building (ty1 `op1` (ty21 `op2` ty22)) mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name) - -> Name -> Fixity -> LHsType Name -> LHsType Name - -> RnM (HsType Name) + -> Name -> Fixity -> LHsType Name -> LHsType Name + -> RnM (HsType Name) mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22)) = do { fix2 <- lookupTyFixityRn op2 - ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 - (\t1 t2 -> HsOpTy t1 (w2, op2) t2) - (unLoc op2) fix2 ty21 ty22 loc2 } + ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 + (\t1 t2 -> HsOpTy t1 (w2, op2) t2) + (unLoc op2) fix2 ty21 ty22 loc2 } mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22)) - = mk_hs_op_ty mk1 pp_op1 fix1 ty1 - HsFunTy funTyConName funTyFixity ty21 ty22 loc2 + = mk_hs_op_ty mk1 pp_op1 fix1 ty1 + HsFunTy funTyConName funTyFixity ty21 ty22 loc2 -mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment +mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment = return (mk1 ty1 ty2) --------------- mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name) - -> Name -> Fixity -> LHsType Name - -> (LHsType Name -> LHsType Name -> HsType Name) - -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan - -> RnM (HsType Name) -mk_hs_op_ty mk1 op1 fix1 ty1 - mk2 op2 fix2 ty21 ty22 loc2 + -> Name -> Fixity -> LHsType Name + -> (LHsType Name -> LHsType Name -> HsType Name) + -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan + -> RnM (HsType Name) +mk_hs_op_ty mk1 op1 fix1 ty1 + mk2 op2 fix2 ty21 ty22 loc2 | nofix_error = do { precParseErr (op1,fix1) (op2,fix2) - ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) } + ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) } | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) - | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) - new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21 - ; return (mk2 (noLoc new_ty) ty22) } + | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) + new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21 + ; return (mk2 (noLoc new_ty) ty22) } where (nofix_error, associate_right) = compareFixity fix1 fix2 --------------------------- -mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged - -> LHsExpr Name -> Fixity -- Operator and fixity - -> LHsExpr Name -- Right operand (not an OpApp, but might - -- be a NegApp) - -> RnM (HsExpr Name) +mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged + -> LHsExpr Name -> Fixity -- Operator and fixity + -> LHsExpr Name -- Right operand (not an OpApp, but might + -- be a NegApp) + -> RnM (HsExpr Name) -- (e11 `op1` e12) `op2` e2 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 @@ -606,13 +620,13 @@ mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 (nofix_error, associate_right) = compareFixity fix1 fix2 --------------------------- --- (- neg_arg) `op` e2 +-- (- neg_arg) `op` e2 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2 | nofix_error = do precParseErr (negateName,negateFixity) (get_op op2,fix2) return (OpApp e1 op2 fix2 e2) - | associate_right + | associate_right = do new_e <- mkOpAppRn neg_arg op2 fix2 e2 return (NegApp (L loc' new_e) neg_name) where @@ -620,19 +634,19 @@ mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2 (nofix_error, associate_right) = compareFixity negateFixity fix2 --------------------------- --- e1 `op` - neg_arg -mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right - | not associate_right -- We *want* right association +-- e1 `op` - neg_arg +mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right + | not associate_right -- We *want* right association = do precParseErr (get_op op1, fix1) (negateName, negateFixity) return (OpApp e1 op1 fix1 e2) where (_, associate_right) = compareFixity fix1 negateFixity --------------------------- --- Default case -mkOpAppRn e1 op fix e2 -- Default case, no rearrangment +-- Default case +mkOpAppRn e1 op fix e2 -- Default case, no rearrangment = ASSERT2( right_op_ok fix (unLoc e2), - ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 + ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 ) return (OpApp e1 op fix e2) @@ -641,7 +655,7 @@ get_op :: LHsExpr Name -> Name get_op (L _ (HsVar n)) = n get_op other = pprPanic "get_op" (ppr other) --- Parser left-associates everything, but +-- Parser left-associates everything, but -- derived instances may have correctly-associated things to -- in the right operarand. So we just check that the right operand is OK right_op_ok :: Fixity -> HsExpr Name -> Bool @@ -661,17 +675,17 @@ mkNegAppRn neg_arg neg_name not_op_app :: HsExpr id -> Bool not_op_app (OpApp _ _ _ _) = False -not_op_app _ = True +not_op_app _ = True --------------------------- -mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged - -> LHsExpr Name -> Fixity -- Operator and fixity - -> LHsCmdTop Name -- Right operand (not an infix) - -> RnM (HsCmd Name) +mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged + -> LHsExpr Name -> Fixity -- Operator and fixity + -> LHsCmdTop Name -- Right operand (not an infix) + -> RnM (HsCmd Name) -- (e11 `op1` e12) `op2` e2 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _)) - op2 fix2 a2 + op2 fix2 a2 | nofix_error = do precParseErr (get_op op1,fix1) (get_op op2,fix2) return (HsCmdArrForm op2 (Just fix2) [a1, a2]) @@ -679,40 +693,40 @@ mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ | associate_right = do new_c <- mkOpFormRn a12 op2 fix2 a2 return (HsCmdArrForm op1 (Just fix1) - [a11, L loc (HsCmdTop (L loc new_c) placeHolderType placeHolderType [])]) - -- TODO: locs are wrong + [a11, L loc (HsCmdTop (L loc new_c) placeHolderType placeHolderType [])]) + -- TODO: locs are wrong where (nofix_error, associate_right) = compareFixity fix1 fix2 --- Default case -mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment +-- Default case +mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment = return (HsCmdArrForm op (Just fix) [arg1, arg2]) -------------------------------------- mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name - -> RnM (Pat Name) + -> RnM (Pat Name) mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 - = do { fix1 <- lookupFixityRn (unLoc op1) - ; let (nofix_error, associate_right) = compareFixity fix1 fix2 + = do { fix1 <- lookupFixityRn (unLoc op1) + ; let (nofix_error, associate_right) = compareFixity fix1 fix2 - ; if nofix_error then do - { precParseErr (unLoc op1,fix1) (unLoc op2,fix2) - ; return (ConPatIn op2 (InfixCon p1 p2)) } + ; if nofix_error then do + { precParseErr (unLoc op1,fix1) (unLoc op2,fix2) + ; return (ConPatIn op2 (InfixCon p1 p2)) } - else if associate_right then do - { new_p <- mkConOpPatRn op2 fix2 p12 p2 - ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right? - else return (ConPatIn op2 (InfixCon p1 p2)) } + else if associate_right then do + { new_p <- mkConOpPatRn op2 fix2 p12 p2 + ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right? + else return (ConPatIn op2 (InfixCon p1 p2)) } -mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment +mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment = ASSERT( not_op_pat (unLoc p2) ) return (ConPatIn op (InfixCon p1 p2)) not_op_pat :: Pat Name -> Bool not_op_pat (ConPatIn _ (InfixCon _ _)) = False -not_op_pat _ = True +not_op_pat _ = True -------------------------------------- checkPrecMatch :: Name -> MatchGroup Name body -> RnM () @@ -720,36 +734,36 @@ checkPrecMatch :: Name -> MatchGroup Name body -> RnM () -- eg a `op` b `C` c = ... -- See comments with rnExpr (OpApp ...) about "deriving" -checkPrecMatch op (MG { mg_alts = ms }) - = mapM_ check ms +checkPrecMatch op (MG { mg_alts = ms }) + = mapM_ check ms where check (L _ (Match (L l1 p1 : L l2 p2 :_) _ _)) = setSrcSpan (combineSrcSpans l1 l2) $ do checkPrec op p1 False checkPrec op p2 True - check _ = return () - -- This can happen. Consider - -- a `op` True = ... - -- op = ... - -- The infix flag comes from the first binding of the group - -- but the second eqn has no args (an error, but not discovered - -- until the type checker). So we don't want to crash on the - -- second eqn. + check _ = return () + -- This can happen. Consider + -- a `op` True = ... + -- op = ... + -- The infix flag comes from the first binding of the group + -- but the second eqn has no args (an error, but not discovered + -- until the type checker). So we don't want to crash on the + -- second eqn. checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do op_fix@(Fixity op_prec op_dir) <- lookupFixityRn op op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1) let - inf_ok = op1_prec > op_prec || - (op1_prec == op_prec && - (op1_dir == InfixR && op_dir == InfixR && right || - op1_dir == InfixL && op_dir == InfixL && not right)) - - info = (op, op_fix) - info1 = (unLoc op1, op1_fix) - (infol, infor) = if right then (info, info1) else (info1, info) + inf_ok = op1_prec > op_prec || + (op1_prec == op_prec && + (op1_dir == InfixR && op_dir == InfixR && right || + op1_dir == InfixL && op_dir == InfixL && not right)) + + info = (op, op_fix) + info1 = (unLoc op1, op1_fix) + (infol, infor) = if right then (info, info1) else (info1, info) unless inf_ok (precParseErr infol infor) checkPrec _ _ _ @@ -760,56 +774,56 @@ checkPrec _ _ _ -- (a) its precedence must be higher than that of op -- (b) its precedency & associativity must be the same as that of op checkSectionPrec :: FixityDirection -> HsExpr RdrName - -> LHsExpr Name -> LHsExpr Name -> RnM () + -> LHsExpr Name -> LHsExpr Name -> RnM () checkSectionPrec direction section op arg = case unLoc arg of - OpApp _ op fix _ -> go_for_it (get_op op) fix - NegApp _ _ -> go_for_it negateName negateFixity - _ -> return () + OpApp _ op fix _ -> go_for_it (get_op op) fix + NegApp _ _ -> go_for_it negateName negateFixity + _ -> return () where op_name = get_op op go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do op_fix@(Fixity op_prec _) <- lookupFixityRn op_name - unless (op_prec < arg_prec - || (op_prec == arg_prec && direction == assoc)) - (sectionPrecErr (op_name, op_fix) - (arg_op, arg_fix) section) + unless (op_prec < arg_prec + || (op_prec == arg_prec && direction == assoc)) + (sectionPrecErr (op_name, op_fix) + (arg_op, arg_fix) section) \end{code} Precedence-related error messages \begin{code} precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM () -precParseErr op1@(n1,_) op2@(n2,_) +precParseErr op1@(n1,_) op2@(n2,_) | isUnboundName n1 || isUnboundName n2 - = return () -- Avoid error cascade + = return () -- Avoid error cascade | otherwise = addErr $ hang (ptext (sLit "Precedence parsing error")) - 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"), - ppr_opfix op2, - ptext (sLit "in the same infix expression")]) + 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"), + ppr_opfix op2, + ptext (sLit "in the same infix expression")]) sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM () sectionPrecErr op@(n1,_) arg_op@(n2,_) section | isUnboundName n1 || isUnboundName n2 - = return () -- Avoid error cascade + = return () -- Avoid error cascade | otherwise = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"), - nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"), - nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]), - nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))] + nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"), + nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]), + nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))] ppr_opfix :: (Name, Fixity) -> SDoc ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) where pp_op | op == negateName = ptext (sLit "prefix `-'") - | otherwise = quotes (ppr op) + | otherwise = quotes (ppr op) \end{code} %********************************************************* -%* * +%* * \subsection{Errors} -%* * +%* * %********************************************************* \begin{code} @@ -821,7 +835,7 @@ warnUnusedForAlls in_doc bound mentioned_rdrs bound_names = hsLTyVarLocNames bound bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names - add_warn (L loc tv) + add_warn (L loc tv) = addWarnAt loc $ vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv) , in_doc ] @@ -829,30 +843,30 @@ warnUnusedForAlls in_doc bound mentioned_rdrs opTyErr :: RdrName -> HsType RdrName -> SDoc opTyErr op ty@(HsOpTy ty1 _ _) = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty)) - 2 extra + 2 extra where extra | op == dot_tv_RDR && forall_head ty1 - = perhapsForallMsg - | otherwise - = ptext (sLit "Use -XTypeOperators to allow operators in types") + = perhapsForallMsg + | otherwise + = ptext (sLit "Use -XTypeOperators to allow operators in types") forall_head (L _ (HsTyVar tv)) = tv == forall_tv_RDR forall_head (L _ (HsAppTy ty _)) = forall_head ty - forall_head _other = False + forall_head _other = False opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty) \end{code} %********************************************************* -%* * - Splices -%* * +%* * + Splices +%* * %********************************************************* Note [Splices] ~~~~~~~~~~~~~~ Consider - f = ... - h = ...$(thing "f")... + f = ... + h = ...$(thing "f")... The splice can expand into literally anything, so when we do dependency analysis we must assume that it might mention 'f'. So we simply treat @@ -870,30 +884,30 @@ type checker. Not very satisfactory really. \begin{code} rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) rnSplice (HsSplice n expr) - = do { checkTH expr "splice" - ; loc <- getSrcSpanM - ; n' <- newLocalBndrRn (L loc n) - ; (expr', fvs) <- rnLExpr expr + = do { checkTH expr "splice" + ; loc <- getSrcSpanM + ; n' <- newLocalBndrRn (L loc n) + ; (expr', fvs) <- rnLExpr expr - -- Ugh! See Note [Splices] above - ; lcl_rdr <- getLocalRdrEnv - ; gbl_rdr <- getGlobalRdrEnv - ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, - isLocalGRE gre] - lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) + -- Ugh! See Note [Splices] above + ; lcl_rdr <- getLocalRdrEnv + ; gbl_rdr <- getGlobalRdrEnv + ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, + isLocalGRE gre] + lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) - ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) } + ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) } checkTH :: Outputable a => a -> String -> RnM () -#ifdef GHCI -checkTH _ _ = return () -- OK +#ifdef GHCI +checkTH _ _ = return () -- OK #else -checkTH e what -- Raise an error in a stage-1 compiler - = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+> - ptext (sLit "requires GHC with interpreter support"), +checkTH e what -- Raise an error in a stage-1 compiler + = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+> + ptext (sLit "requires GHC with interpreter support"), ptext (sLit "Perhaps you are using a stage-1 compiler?"), - nest 2 (ppr e)]) -#endif + nest 2 (ppr e)]) +#endif \end{code} %************************************************************************ @@ -924,7 +938,7 @@ recently, kind variables. For example: * type instance F (T (a :: Maybe k)) = ...a...k... Here we want to constrain the kind of 'a', and bind 'k'. -In general we want to walk over a type, and find +In general we want to walk over a type, and find * Its free type variables * The free kind variables of any kind signatures in the type @@ -935,7 +949,7 @@ See also Note [HsBSig binder lists] in HsTypes type FreeKiTyVars = ([RdrName], [RdrName]) filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars -filterInScope rdr_env (kvs, tvs) +filterInScope rdr_env (kvs, tvs) = (filterOut in_scope kvs, filterOut in_scope tvs) where in_scope tv = tv `elemLocalRdrEnv` rdr_env @@ -945,13 +959,13 @@ extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars -- or the free (sort, kind) variables of a HsKind -- It's used when making the for-alls explicit. -- See Note [Kind and type-variable binders] -extractHsTyRdrTyVars ty +extractHsTyRdrTyVars ty = case extract_lty ty ([],[]) of (kvs, tvs) -> (nub kvs, nub tvs) extractHsTysRdrTyVars :: [LHsType RdrName] -> FreeKiTyVars -- See Note [Kind and type-variable binders] -extractHsTysRdrTyVars ty +extractHsTysRdrTyVars ty = case extract_ltys ty ([],[]) of (kvs, tvs) -> (nub kvs, nub tvs) @@ -1017,26 +1031,25 @@ extract_lty (L _ ty) acc HsTyLit _ -> acc HsWrapTy _ _ -> panic "extract_lty" HsKindSig ty ki -> extract_lty ty (extract_lkind ki acc) + HsRoleAnnot ty _ -> extract_lty ty acc HsForAllTy _ tvs cx ty -> extract_hs_tv_bndrs tvs acc $ extract_lctxt cx $ extract_lty ty ([],[]) extract_hs_tv_bndrs :: LHsTyVarBndrs RdrName -> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars -extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs }) - acc@(acc_kvs, acc_tvs) -- Note accumulator comes first +extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs }) + (acc_kvs, acc_tvs) -- Note accumulator comes first (body_kvs, body_tvs) | null tvs = (body_kvs ++ acc_kvs, body_tvs ++ acc_tvs) | otherwise - = (outer_kvs ++ body_kvs, - outer_tvs ++ filterOut (`elem` local_tvs) body_tvs) + = (acc_kvs ++ filterOut (`elem` local_kvs) body_kvs, + acc_tvs ++ filterOut (`elem` local_tvs) body_tvs) where local_tvs = map hsLTyVarName tvs - -- Currently we don't have a syntax to explicitly bind - -- kind variables, so these are all type variables - - (outer_kvs, outer_tvs) = foldr extract_lkind acc [k | L _ (KindedTyVar _ k) <- tvs] + (_, local_kvs) = foldr extract_lty ([], []) [k | L _ (HsTyVarBndr _ (Just k) _) <- tvs] + -- These kind variables are bound here if not bound further out extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars extract_tv tv acc diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index 8bd15864c7..1d9ef45f7f 100644 --- a/compiler/simplCore/CSE.lhs +++ b/compiler/simplCore/CSE.lhs @@ -4,67 +4,42 @@ \section{Common subexpression} \begin{code} -{-# 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 CSE ( - cseProgram - ) where +module CSE (cseProgram) where #include "HsVersions.h" --- Note [Keep old CSEnv rep] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- Temporarily retain code for the old representation for CSEnv --- Keeping it only so that we can switch back if a bug shows up --- or we want to do some performance comparisions --- --- NB: when you remove this, also delete hashExpr from CoreUtils -#ifdef OLD_CSENV_REP -import CoreUtils ( exprIsBig, hashExpr, eqExpr ) -import StaticFlags ( opt_PprStyle_Debug ) -import Util ( lengthExceeds ) -import UniqFM -import FastString -#else -import TrieMap -#endif - import CoreSubst -import Var ( Var ) -import Id ( Id, idType, idInlineActivation, zapIdOccInfo ) -import CoreUtils ( mkAltExpr +import Var ( Var ) +import Id ( Id, idType, idInlineActivation, zapIdOccInfo ) +import CoreUtils ( mkAltExpr , exprIsTrivial) -import Type ( tyConAppArgs ) +import Type ( tyConAppArgs ) import CoreSyn import Outputable -import BasicTypes ( isAlwaysActive ) +import BasicTypes ( isAlwaysActive ) +import TrieMap import Data.List \end{code} - Simple common sub-expression - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Simple common sub-expression + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we see - x1 = C a b - x2 = C x1 b + x1 = C a b + x2 = C x1 b we build up a reverse mapping: C a b -> x1 - C x1 b -> x2 + C x1 b -> x2 and apply that to the rest of the program. When we then see - y1 = C a b - y2 = C y1 b + y1 = C a b + y2 = C y1 b we replace the C a b with x1. But then we *dont* want to add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1 so that a subsequent binding - y2 = C y1 b -will get transformed to C x1 b, and then to x2. + y2 = C y1 b +will get transformed to C x1 b, and then to x2. So we carry an extra var->var substitution which we apply *before* looking up in the reverse mapping. @@ -74,9 +49,9 @@ Note [Shadowing] ~~~~~~~~~~~~~~~~ We have to be careful about shadowing. For example, consider - f = \x -> let y = x+x in - h = \x -> x+x - in ... + f = \x -> let y = x+x in + h = \x -> x+x + in ... Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no shadowing, but it doesn't any more (it proved too hard), so we clone as we go. @@ -86,9 +61,9 @@ Note [Case binders 1] ~~~~~~~~~~~~~~~~~~~~~~ Consider - f = \x -> case x of wild { - (a:as) -> case a of wild1 { - (p,q) -> ...(wild1:as)... + f = \x -> case x of wild { + (a:as) -> case a of wild1 { + (p,q) -> ...(wild1:as)... Here, (wild1:as) is morally the same as (a:as) and hence equal to wild. But that's not quite obvious. In general we want to keep it as (wild1:as), @@ -101,44 +76,44 @@ to try to replaces uses of 'a' with uses of 'wild1' Note [Case binders 2] ~~~~~~~~~~~~~~~~~~~~~~ Consider - case (h x) of y -> ...(h x)... + case (h x) of y -> ...(h x)... We'd like to replace (h x) in the alternative, by y. But because of the preceding [Note: case binders 1], we only want to add the mapping - scrutinee -> case binder + scrutinee -> case binder to the reverse CSE mapping if the scrutinee is a non-trivial expression. (If the scrutinee is a simple variable we want to add the mapping - case binder -> scrutinee + case binder -> scrutinee to the substitution Note [CSE for INLINE and NOINLINE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We are careful to do no CSE inside functions that the user has marked as -INLINE or NOINLINE. In terms of Core, that means +INLINE or NOINLINE. In terms of Core, that means - a) we do not do CSE inside an InlineRule + a) we do not do CSE inside an InlineRule - b) we do not do CSE on the RHS of a binding b=e - unless b's InlinePragma is AlwaysActive + b) we do not do CSE on the RHS of a binding b=e + unless b's InlinePragma is AlwaysActive Here's why (examples from Roman Leshchinskiy). Consider - yes :: Int - {-# NOINLINE yes #-} - yes = undefined + yes :: Int + {-# NOINLINE yes #-} + yes = undefined - no :: Int - {-# NOINLINE no #-} - no = undefined + no :: Int + {-# NOINLINE no #-} + no = undefined - foo :: Int -> Int -> Int - {-# NOINLINE foo #-} - foo m n = n + foo :: Int -> Int -> Int + {-# NOINLINE foo #-} + foo m n = n - {-# RULES "foo/no" foo no = id #-} + {-# RULES "foo/no" foo no = id #-} - bar :: Int -> Int - bar = foo yes + bar :: Int -> Int + bar = foo yes We do not expect the rule to fire. But if we do CSE, then we get yes=no, and the rule does fire. Worse, whether we get yes=no or @@ -147,26 +122,26 @@ no=yes depends on the order of the definitions. In general, CSE should probably never touch things with INLINE pragmas as this could lead to surprising results. Consider - {-# INLINE foo #-} - foo = <rhs> + {-# INLINE foo #-} + foo = <rhs> - {-# NOINLINE bar #-} - bar = <rhs> -- Same rhs as foo + {-# NOINLINE bar #-} + bar = <rhs> -- Same rhs as foo If CSE produces - foo = bar + foo = bar then foo will never be inlined (when it should be); but if it produces - bar = foo + bar = foo bar will be inlined (when it should not be). Even if we remove INLINE foo, we'd still like foo to be inlined if rhs is small. This won't happen with foo = bar. Not CSE-ing inside INLINE also solves an annoying bug in CSE. Consider a worker/wrapper, in which the worker has turned into a single variable: - $wf = h - f = \x -> ...$wf... + $wf = h + f = \x -> ...$wf... Now CSE may transform to - f = \x -> ...h... + f = \x -> ...h... But the WorkerInfo for f still says $wf, which is now dead! This won't happen now that we don't look inside INLINEs (which wrappers are). @@ -178,9 +153,9 @@ Then we can CSE the inner (f x) to y. In fact 'case' is like a strict let-binding, and we can use cseRhs for dealing with the scrutinee. %************************************************************************ -%* * +%* * \section{Common subexpression} -%* * +%* * %************************************************************************ \begin{code} @@ -190,12 +165,12 @@ cseProgram binds = cseBinds emptyCSEnv binds cseBinds :: CSEnv -> [CoreBind] -> [CoreBind] cseBinds _ [] = [] cseBinds env (b:bs) = (b':bs') - where - (env1, b') = cseBind env b - bs' = cseBinds env1 bs + where + (env1, b') = cseBind env b + bs' = cseBinds env1 bs cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind) -cseBind env (NonRec b e) +cseBind env (NonRec b e) = (env2, NonRec b' e') where (env1, b') = addBinder env b @@ -211,16 +186,16 @@ cseBind env (Rec pairs) cseRhs :: CSEnv -> (OutBndr, InExpr) -> (CSEnv, OutExpr) cseRhs env (id',rhs) = case lookupCSEnv env rhs' of - Just other_expr -> (env, other_expr) - Nothing -> (addCSEnvItem env rhs' (Var id'), rhs') + Just other_expr -> (env, other_expr) + Nothing -> (addCSEnvItem env rhs' (Var id'), rhs') where rhs' | isAlwaysActive (idInlineActivation id') = cseExpr env rhs - | otherwise = rhs - -- See Note [CSE for INLINE and NOINLINE] + | otherwise = rhs + -- See Note [CSE for INLINE and NOINLINE] tryForCSE :: CSEnv -> InExpr -> OutExpr tryForCSE env expr - | exprIsTrivial expr' = expr' -- No point + | exprIsTrivial expr' = expr' -- No point | Just smaller <- lookupCSEnv env expr' = smaller | otherwise = expr' where @@ -230,24 +205,24 @@ cseExpr :: CSEnv -> InExpr -> OutExpr cseExpr env (Type t) = Type (substTy (csEnvSubst env) t) cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c) cseExpr _ (Lit lit) = Lit lit -cseExpr env (Var v) = lookupSubst env v -cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) +cseExpr env (Var v) = lookupSubst env v +cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) cseExpr env (Tick t e) = Tick t (cseExpr env e) cseExpr env (Cast e co) = Cast (cseExpr env e) (substCo (csEnvSubst env) co) -cseExpr env (Lam b e) = let (env', b') = addBinder env b - in Lam b' (cseExpr env' e) -cseExpr env (Let bind e) = let (env', bind') = cseBind env bind - in Let bind' (cseExpr env' e) +cseExpr env (Lam b e) = let (env', b') = addBinder env b + in Lam b' (cseExpr env' e) +cseExpr env (Let bind e) = let (env', bind') = cseBind env bind + in Let bind' (cseExpr env' e) cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty alts' - where - alts' = cseAlts env2 scrut' bndr bndr'' alts - (env1, bndr') = addBinder env bndr - bndr'' = zapIdOccInfo bndr' - -- The swizzling from Note [Case binders 2] may - -- cause a dead case binder to be alive, so we - -- play safe here and bring them all to life - (env2, scrut') = cseRhs env1 (bndr'', scrut) - -- Note [CSE for case expressions] + where + alts' = cseAlts env2 scrut' bndr bndr'' alts + (env1, bndr') = addBinder env bndr + bndr'' = zapIdOccInfo bndr' + -- The swizzling from Note [Case binders 2] may + -- cause a dead case binder to be alive, so we + -- play safe here and bring them all to life + (env2, scrut') = cseRhs env1 (bndr'', scrut) + -- Note [CSE for case expressions] cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt] @@ -255,103 +230,50 @@ cseAlts env scrut' bndr bndr' alts = map cse_alt alts where (con_target, alt_env) - = case scrut' of - Var v' -> (v', extendCSSubst env bndr v') -- See Note [Case binders 1] - -- map: bndr -> v' + = case scrut' of + Var v' -> (v', extendCSSubst env bndr v') -- See Note [Case binders 1] + -- map: bndr -> v' - _ -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See Note [Case binders 2] - -- map: scrut' -> bndr' + _ -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See Note [Case binders 2] + -- map: scrut' -> bndr' arg_tys = tyConAppArgs (idType bndr) cse_alt (DataAlt con, args, rhs) - | not (null args) - -- Don't try CSE if there are no args; it just increases the number - -- of live vars. E.g. - -- case x of { True -> ....True.... } - -- Don't replace True by x! - -- Hence the 'null args', which also deal with literals and DEFAULT - = (DataAlt con, args', tryForCSE new_env rhs) - where - (env', args') = addBinders alt_env args - new_env = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys) - (Var con_target) + | not (null args) + -- Don't try CSE if there are no args; it just increases the number + -- of live vars. E.g. + -- case x of { True -> ....True.... } + -- Don't replace True by x! + -- Hence the 'null args', which also deal with literals and DEFAULT + = (DataAlt con, args', tryForCSE new_env rhs) + where + (env', args') = addBinders alt_env args + new_env = extendCSEnv env' (mkAltExpr (DataAlt con) args' arg_tys) + (Var con_target) cse_alt (con, args, rhs) - = (con, args', tryForCSE env' rhs) - where - (env', args') = addBinders alt_env args + = (con, args', tryForCSE env' rhs) + where + (env', args') = addBinders alt_env args \end{code} %************************************************************************ -%* * +%* * \section{The CSE envt} -%* * +%* * %************************************************************************ \begin{code} -type InExpr = CoreExpr -- Pre-cloning +type InExpr = CoreExpr -- Pre-cloning type InBndr = CoreBndr type InAlt = CoreAlt -type OutExpr = CoreExpr -- Post-cloning +type OutExpr = CoreExpr -- Post-cloning type OutBndr = CoreBndr type OutAlt = CoreAlt --- See Note [Keep old CsEnv rep] -#ifdef OLD_CSENV_REP -data CSEnv = CS { cs_map :: CSEMap - , cs_subst :: Subst } - -type CSEMap = UniqFM [(OutExpr, OutExpr)] -- This is the reverse mapping - -- It maps the hash-code of an expression e to list of (e,e') pairs - -- This means that it's good to replace e by e' - -- INVARIANT: The expr in the range has already been CSE'd - -emptyCSEnv :: CSEnv -emptyCSEnv = CS { cs_map = emptyUFM, cs_subst = emptySubst } - -lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr -lookupCSEnv (CS { cs_map = oldmap, cs_subst = sub}) expr - = case lookupUFM oldmap (hashExpr expr) of - Nothing -> Nothing - Just pairs -> lookup_list pairs - where - in_scope = substInScope sub - - -- In this lookup we use full expression equality - -- Reason: when expressions differ we generally find out quickly - -- but I found that cheapEqExpr was saying (\x.x) /= (\y.y), - -- and this kind of thing happened in real programs - lookup_list :: [(OutExpr,OutExpr)] -> Maybe OutExpr - lookup_list ((e,e'):es) - | eqExpr in_scope e expr = Just e' - | otherwise = lookup_list es - lookup_list [] = Nothing - -addCSEnvItem :: CSEnv -> OutExpr -> OutExpr -> CSEnv -addCSEnvItem env expr expr' | exprIsBig expr = env - | otherwise = extendCSEnv env expr expr' - -- We don't try to CSE big expressions, because they are expensive to compare - -- (and are unlikely to be the same anyway) - -extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv -extendCSEnv cse@(CS { cs_map = oldmap }) expr expr' - = cse { cs_map = addToUFM_C combine oldmap hash [(expr, expr')] } - where - hash = hashExpr expr - combine old new - = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result - where - result = new ++ old - short_msg = ptext (sLit "extendCSEnv: long list, length") <+> int (length result) - long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result - | otherwise = empty - -#else ------------- NEW ---------------- - data CSEnv = CS { cs_map :: CoreMap (OutExpr, OutExpr) -- Key, value , cs_subst :: Subst } @@ -359,7 +281,7 @@ emptyCSEnv :: CSEnv emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst } lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr -lookupCSEnv (CS { cs_map = csmap }) expr +lookupCSEnv (CS { cs_map = csmap }) expr = case lookupCoreMap csmap expr of Just (_,e) -> Just e Nothing -> Nothing @@ -375,7 +297,6 @@ addCSEnvItem = extendCSEnv extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv extendCSEnv cse expr expr' = cse { cs_map = extendCoreMap (cs_map cse) expr (expr,expr') } -#endif csEnvSubst :: CSEnv -> Subst csEnvSubst = cs_subst @@ -387,17 +308,17 @@ extendCSSubst :: CSEnv -> Id -> Id -> CSEnv extendCSSubst cse x y = cse { cs_subst = extendIdSubst (cs_subst cse) x (Var y) } addBinder :: CSEnv -> Var -> (CSEnv, Var) -addBinder cse v = (cse { cs_subst = sub' }, v') +addBinder cse v = (cse { cs_subst = sub' }, v') where (sub', v') = substBndr (cs_subst cse) v addBinders :: CSEnv -> [Var] -> (CSEnv, [Var]) -addBinders cse vs = (cse { cs_subst = sub' }, vs') +addBinders cse vs = (cse { cs_subst = sub' }, vs') where (sub', vs') = substBndrs (cs_subst cse) vs addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id]) -addRecBinders cse vs = (cse { cs_subst = sub' }, vs') +addRecBinders cse vs = (cse { cs_subst = sub' }, vs') where (sub', vs') = substRecBndrs (cs_subst cse) vs \end{code} diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 3afb8cdf5d..31547e14a2 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -762,7 +762,8 @@ instance Monad CoreM where mx >>= f = CoreM $ \s -> do (x, s', w1) <- unCoreM mx s (y, s'', w2) <- unCoreM (f x) s' - return (y, s'', w1 `plusWriter` w2) + let w = w1 `plusWriter` w2 -- forcing w before returning avoids a space leak (Trac #7702) + return $ seq w (y, s'', w) instance Applicative CoreM where pure = return @@ -781,6 +782,12 @@ instance MonadUnique CoreM where modifyS (\s -> s { cs_uniq_supply = us2 }) return us1 + getUniqueM = do + us <- getS cs_uniq_supply + let (u,us') = takeUniqFromSupply us + modifyS (\s -> s { cs_uniq_supply = us' }) + return u + runCoreM :: HscEnv -> RuleBase -> UniqSupply @@ -896,6 +903,14 @@ not be a problem, except that the new copy has its own mutable state that is not shared with that state that has already been initialized by the original GHC package. +(NB This mechanism is sufficient for granting plugins read-only access to +globals that are guaranteed to be initialized before the plugin is loaded. If +any further synchronization is necessary, I would suggest using the more +sophisticated mechanism involving GHC.Conc.Sync.sharedCAF and rts/Globals.c to +share a single instance of the global variable among the compiler and the +plugins. Perhaps we should migrate all global variables to use that mechanism, +for robustness... -- NSF July 2013) + This leads to loaded plugins calling GHC code which pokes the static flags, and then dying with a panic because the static flags *it* sees are uninitialized. diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index 681c183132..0d1c9764c5 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -256,7 +256,7 @@ course. Note [extra_fvs (1): avoid floating into RHS] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consdider let x=\y....t... in body. We do not necessarily want to float +Consider let x=\y....t... in body. We do not necessarily want to float a binding for t into the RHS, because it'll immediately be floated out again. (It won't go inside the lambda else we risk losing work.) In letrec, we need to be more careful still. We don't want to transform diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index f32130ed76..52c564507a 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -31,10 +31,9 @@ import Coercion import VarSet import VarEnv import Var - +import Demand ( argOneShots, argsOneShots ) import Maybes ( orElse ) import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR ) -import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) import Unique import UniqFM import Util @@ -138,7 +137,7 @@ occAnalBind env _ imp_rules_edges (NonRec binder rhs) body_usage = (body_usage' +++ rhs_usage4, [NonRec tagged_binder rhs']) where (body_usage', tagged_binder) = tagBinder body_usage binder - (rhs_usage1, rhs') = occAnalRhs env (Just tagged_binder) rhs + (rhs_usage1, rhs') = occAnalNonRecRhs env tagged_binder rhs rhs_usage2 = addIdOccs rhs_usage1 (idUnfoldingVars binder) rhs_usage3 = addIdOccs rhs_usage2 (idRuleVars binder) -- See Note [Rules are extra RHSs] and Note [Rule dependency info] @@ -665,7 +664,7 @@ makeNode env imp_rules_edges bndr_set (bndr, rhs) -- Constructing the edges for the main Rec computation -- See Note [Forming Rec groups] - (rhs_usage1, rhs') = occAnalRhs env Nothing rhs + (rhs_usage1, rhs') = occAnalRecRhs env rhs rhs_usage2 = addIdOccs rhs_usage1 all_rule_fvs -- Note [Rules are extra RHSs] -- Note [Rule dependency info] rhs_usage3 = case mb_unf_fvs of @@ -692,7 +691,7 @@ makeNode env imp_rules_edges bndr_set (bndr, rhs) -- Finding the free variables of the INLINE pragma (if any) unf = realIdUnfolding bndr -- Ignore any current loop-breaker flag - mb_unf_fvs = stableUnfoldingVars isLocalId unf + mb_unf_fvs = stableUnfoldingVars unf -- Find the "nd_inl" free vars; for the loop-breaker phase inl_fvs = case mb_unf_fvs of @@ -1065,28 +1064,36 @@ ToDo: try using the occurrence info for the inline'd binder. \begin{code} -occAnalRhs :: OccEnv - -> Maybe Id -> CoreExpr -- Binder and rhs - -- Just b => non-rec, and alrady tagged with occurrence info - -- Nothing => Rec, no occ info +occAnalRecRhs :: OccEnv -> CoreExpr -- Rhs -> (UsageDetails, CoreExpr) -- Returned usage details covers only the RHS, -- and *not* the RULE or INLINE template for the Id -occAnalRhs env mb_bndr rhs - = occAnal ctxt rhs +occAnalRecRhs env rhs = occAnal (rhsCtxt env) rhs + +occAnalNonRecRhs :: OccEnv + -> Id -> CoreExpr -- Binder and rhs + -- Binder is already tagged with occurrence info + -> (UsageDetails, CoreExpr) + -- Returned usage details covers only the RHS, + -- and *not* the RULE or INLINE template for the Id +occAnalNonRecRhs env bndr rhs + = occAnal rhs_env rhs where + -- See Note [Use one-shot info] + env1 = env { occ_one_shots = argOneShots dmd } + -- See Note [Cascading inlines] - ctxt = case mb_bndr of - Just b | certainly_inline b -> env - _other -> rhsCtxt env + rhs_env | certainly_inline = env1 + | otherwise = rhsCtxt env1 - certainly_inline bndr -- See Note [Cascading inlines] + certainly_inline -- See Note [Cascading inlines] = case idOccInfo bndr of OneOcc in_lam one_br _ -> not in_lam && one_br && active && not_stable _ -> False - where - active = isAlwaysActive (idInlineActivation bndr) - not_stable = not (isStableUnfolding (idUnfolding bndr)) + + dmd = idDemandInfo bndr + active = isAlwaysActive (idInlineActivation bndr) + not_stable = not (isStableUnfolding (idUnfolding bndr)) addIdOccs :: UsageDetails -> VarSet -> UsageDetails addIdOccs usage id_set = foldVarSet add usage id_set @@ -1223,24 +1230,13 @@ occAnal env expr@(Lam _ _) (final_usage, tagged_binders) = tagLamBinders body_usage binders' -- Use binders' to put one-shot info on the lambdas - -- URGH! Sept 99: we don't seem to be able to use binders' here, because - -- we get linear-typed things in the resulting program that we can't handle yet. - -- (e.g. PrelShow) TODO - - really_final_usage = if linear then - final_usage - else - mapVarEnv markInsideLam final_usage + really_final_usage | linear = final_usage + | otherwise = mapVarEnv markInsideLam final_usage in - (really_final_usage, - mkLams tagged_binders body') } + (really_final_usage, mkLams tagged_binders body') } where - env_body = vanillaCtxt env - -- Body is (no longer) an RhsContext - (binders, body) = collectBinders expr - binders' = oneShotGroup env binders - linear = all is_one_shot binders' - is_one_shot b = isId b && isOneShotBndr b + (binders, body) = collectBinders expr + (env_body, binders', linear) = oneShotGroup env binders occAnal env (Case scrut bndr ty alts) = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> @@ -1282,12 +1278,20 @@ occAnal env (Let bind body) case occAnalBind env env emptyVarEnv bind body_usage of { (final_usage, new_binds) -> (final_usage, mkLets new_binds body') }} -occAnalArgs :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr]) -occAnalArgs env args - = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') -> - (foldr (+++) emptyDetails arg_uds_s, args')} - where - arg_env = vanillaCtxt env +occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr]) +occAnalArgs _ [] _ + = (emptyDetails, []) + +occAnalArgs env (arg:args) one_shots + | isTypeArg arg + = case occAnalArgs env args one_shots of { (uds, args') -> + (uds, arg:args') } + + | otherwise + = case argCtxt env one_shots of { (arg_env, one_shots') -> + case occAnal arg_env arg of { (uds1, arg') -> + case occAnalArgs env args one_shots' of { (uds2, args') -> + (uds1 +++ uds2, arg':args') }}} \end{code} Applications are dealt with specially because we want @@ -1324,27 +1328,23 @@ occAnalApp env (Var fun, args) in (fun_uds +++ final_args_uds, mkApps (Var fun) args') } where - fun_uniq = idUnique fun fun_uds = mkOneOcc env fun (valArgCount args > 0) is_exp = isExpandableApp fun (valArgCount args) -- See Note [CONLIKE pragma] in BasicTypes -- The definition of is_exp should match that in -- Simplify.prepareRhs - -- Hack for build, fold, runST - args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args - | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args - | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args - | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args + one_shots = argsOneShots (idStrictness fun) (valArgCount args) + -- See Note [Use one-shot info] + + args_stuff = occAnalArgs env args one_shots + -- (foldr k z xs) may call k many times, but it never -- shares a partial application of k; hence [False,True] -- This means we can optimise -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs -- by floating in the v - | otherwise = occAnalArgs env args - - occAnalApp env (fun, args) = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') -> -- The addAppCtxt is a bit cunning. One iteration of the simplifier @@ -1354,11 +1354,8 @@ occAnalApp env (fun, args) -- thing much like a let. We do this by pushing some True items -- onto the context stack. - case occAnalArgs env args of { (args_uds, args') -> - let - final_uds = fun_uds +++ args_uds - in - (final_uds, mkApps fun' args') }} + case occAnalArgs env args [] of { (args_uds, args') -> + (fun_uds +++ args_uds, mkApps fun' args') }} markManyIf :: Bool -- If this is true @@ -1366,29 +1363,23 @@ markManyIf :: Bool -- If this is true -> UsageDetails markManyIf True uds = mapVarEnv markMany uds markManyIf False uds = uds +\end{code} -appSpecial :: OccEnv - -> Int -> CtxtTy -- Argument number, and context to use for it - -> [CoreExpr] - -> (UsageDetails, [CoreExpr]) -appSpecial env n ctxt args - = go n args - where - arg_env = vanillaCtxt env - - go _ [] = (emptyDetails, []) -- Too few args - - go 1 (arg:args) -- The magic arg - = case occAnal (setCtxtTy arg_env ctxt) arg of { (arg_uds, arg') -> - case occAnalArgs env args of { (args_uds, args') -> - (arg_uds +++ args_uds, arg':args') }} +Note [Use one-shot information] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The occurrrence analyser propagates one-shot-lambda information in two situation + * Applications: eg build (\cn -> blah) + Propagate one-shot info from the strictness signature of 'build' to + the \cn - go n (arg:args) - = case occAnal arg_env arg of { (arg_uds, arg') -> - case go (n-1) args of { (args_uds, args') -> - (arg_uds +++ args_uds, arg':args') }} -\end{code} + * Let-bindings: eg let f = \c. let ... in \n -> blah + in (build f, build f) + Propagate one-shot info from the demanand-info on 'f' to the + lambdas in its RHS (which may not be syntactically at the top) +Some of this is done by the demand analyser, but this way it happens +much earlier, taking advantage of the strictness signature of +imported functions. Note [Binders in case alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1441,10 +1432,10 @@ wrapProxy _ _ _ body_usg body \begin{code} data OccEnv - = OccEnv { occ_encl :: !OccEncl -- Enclosing context information - , occ_ctxt :: !CtxtTy -- Tells about linearity - , occ_gbl_scrut :: GlobalScruts - , occ_rule_act :: Activation -> Bool -- Which rules are active + = OccEnv { occ_encl :: !OccEncl -- Enclosing context information + , occ_one_shots :: !OneShots -- Tells about linearity + , occ_gbl_scrut :: GlobalScruts + , occ_rule_act :: Activation -> Bool -- Which rules are active -- See Note [Finding rule RHS free vars] , occ_binder_swap :: !Bool -- enable the binder_swap -- See CorePrep Note [Dead code in CorePrep] @@ -1471,7 +1462,7 @@ instance Outputable OccEncl where ppr OccRhs = ptext (sLit "occRhs") ppr OccVanilla = ptext (sLit "occVanilla") -type CtxtTy = [Bool] +type OneShots = [Bool] -- [] No info -- -- True:ctxt Analysing a function-valued expression that will be @@ -1479,51 +1470,66 @@ type CtxtTy = [Bool] -- -- False:ctxt Analysing a function-valued expression that may -- be applied many times; but when it is, - -- the CtxtTy inside applies + -- the OneShots inside applies initOccEnv :: (Activation -> Bool) -> OccEnv initOccEnv active_rule - = OccEnv { occ_encl = OccVanilla - , occ_ctxt = [] + = OccEnv { occ_encl = OccVanilla + , occ_one_shots = [] , occ_gbl_scrut = emptyVarSet -- PE emptyVarEnv emptyVarSet - , occ_rule_act = active_rule + , occ_rule_act = active_rule , occ_binder_swap = True } vanillaCtxt :: OccEnv -> OccEnv -vanillaCtxt env = env { occ_encl = OccVanilla, occ_ctxt = [] } +vanillaCtxt env = env { occ_encl = OccVanilla, occ_one_shots = [] } rhsCtxt :: OccEnv -> OccEnv -rhsCtxt env = env { occ_encl = OccRhs, occ_ctxt = [] } +rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] } -setCtxtTy :: OccEnv -> CtxtTy -> OccEnv -setCtxtTy env ctxt = env { occ_ctxt = ctxt } +argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots]) +argCtxt env [] + = (env { occ_encl = OccVanilla, occ_one_shots = [] }, []) +argCtxt env (one_shots:one_shots_s) + = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s) isRhsEnv :: OccEnv -> Bool isRhsEnv (OccEnv { occ_encl = OccRhs }) = True isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False -oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr] +oneShotGroup :: OccEnv -> [CoreBndr] + -> ( OccEnv + , [CoreBndr] + , Bool ) -- True <=> all binders are one-shot -- The result binders have one-shot-ness set that they might not have had originally. -- This happens in (build (\cn -> e)). Here the occurrence analyser -- linearity context knows that c,n are one-shot, and it records that fact in -- the binder. This is useful to guide subsequent float-in/float-out tranformations -oneShotGroup (OccEnv { occ_ctxt = ctxt }) bndrs - = go ctxt bndrs [] +oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs + = go ctxt bndrs [] True where - go _ [] rev_bndrs = reverse rev_bndrs - - go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs - | isId bndr = go ctxt bndrs (bndr':rev_bndrs) - where - bndr' | lin_ctxt = setOneShotLambda bndr - | otherwise = bndr - - go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs) + go ctxt [] rev_bndrs linear + = ( env { occ_one_shots = ctxt, occ_encl = OccVanilla } + , reverse rev_bndrs + , linear ) + + go ctxt (bndr:bndrs) rev_bndrs lin_acc + | isId bndr + = case ctxt of + [] -> go [] bndrs (bndr:rev_bndrs) (lin_acc && one_shot) + (linear : ctxt) + | one_shot -> go ctxt bndrs (bndr : rev_bndrs) lin_acc + | linear -> go ctxt bndrs (bndr': rev_bndrs) lin_acc + | otherwise -> go ctxt bndrs (bndr : rev_bndrs) False + | otherwise + = go ctxt bndrs (bndr:rev_bndrs) lin_acc + where + one_shot = isOneShotBndr bndr + bndr' = setOneShotLambda bndr addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv -addAppCtxt env@(OccEnv { occ_ctxt = ctxt }) args - = env { occ_ctxt = replicate (valArgCount args) True ++ ctxt } +addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args + = env { occ_one_shots = replicate (valArgCount args) True ++ ctxt } \end{code} @@ -1717,7 +1723,7 @@ information right. \begin{code} mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr)) --- Does two things: a) makes the occ_ctxt = OccVanilla +-- Does two things: a) makes the occ_one_shots = OccVanilla -- b) extends the GlobalScruts if possible -- c) returns a proxy mapping, binding the scrutinee -- to the case binder, if possible diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index a5eb116d82..4c3c72d301 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -145,8 +145,8 @@ instance MonadUnique SimplM where (us1, us2) -> return (us1, us2, sc)) getUniqueM - = SM (\_st_env us sc -> case splitUniqSupply us of - (us1, us2) -> return (uniqFromSupply us1, us2, sc)) + = SM (\_st_env us sc -> case takeUniqFromSupply us of + (u, us') -> return (u, us', sc)) getUniquesM = SM (\_st_env us sc -> case splitUniqSupply us of diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 7bc10de43f..ab4937e8f3 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -15,15 +15,17 @@ module SimplUtils ( simplEnvForGHCi, updModeForInlineRules, -- The continuation type - SimplCont(..), DupFlag(..), ArgInfo(..), + SimplCont(..), DupFlag(..), isSimplified, contIsDupable, contResultType, contInputType, contIsTrivial, contArgs, dropArgs, - pushSimplifiedArgs, countValArgs, countArgs, addArgTo, + pushSimplifiedArgs, countValArgs, countArgs, mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg, - interestingCallContext, + interestingCallContext, interestingArg, - interestingArg, mkArgInfo, + -- ArgInfo + ArgInfo(..), ArgSpec(..), mkArgInfo, addArgTo, addCastTo, + argInfoExpr, argInfoValArgs, abstractFloats ) where @@ -132,7 +134,7 @@ data SimplCont data ArgInfo = ArgInfo { ai_fun :: OutId, -- The function - ai_args :: [OutExpr], -- ...applied to these args (which are in *reverse* order) + ai_args :: [ArgSpec], -- ...applied to these args (which are in *reverse* order) ai_type :: OutType, -- Type of (f a1 ... an) ai_rules :: [CoreRule], -- Rules for this function @@ -149,10 +151,38 @@ data ArgInfo -- Always infinite } +data ArgSpec = ValArg OutExpr -- Apply to this + | CastBy OutCoercion -- Cast by this + +instance Outputable ArgSpec where + ppr (ValArg e) = ptext (sLit "ValArg") <+> ppr e + ppr (CastBy c) = ptext (sLit "CastBy") <+> ppr c + addArgTo :: ArgInfo -> OutExpr -> ArgInfo -addArgTo ai arg = ai { ai_args = arg : ai_args ai +addArgTo ai arg = ai { ai_args = ValArg arg : ai_args ai , ai_type = applyTypeToArg (ai_type ai) arg } +addCastTo :: ArgInfo -> OutCoercion -> ArgInfo +addCastTo ai co = ai { ai_args = CastBy co : ai_args ai + , ai_type = pSnd (coercionKind co) } + +argInfoValArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> ([OutExpr], SimplCont) +argInfoValArgs env args cont + = go args [] cont + where + go :: [ArgSpec] -> [OutExpr] -> SimplCont -> ([OutExpr], SimplCont) + go (ValArg e : as) acc cont = go as (e:acc) cont + go (CastBy co : as) acc cont = go as [] (CoerceIt co (pushSimplifiedArgs env acc cont)) + go [] acc cont = (acc, cont) + +argInfoExpr :: OutId -> [ArgSpec] -> OutExpr +argInfoExpr fun args + = go args + where + go [] = Var fun + go (ValArg a : as) = go as `App` a + go (CastBy co : as) = mkCast (go as) co + instance Outputable SimplCont where ppr (Stop ty interesting) = ptext (sLit "Stop") <> brackets (ppr interesting) <+> ppr ty ppr (ApplyTo dup arg _ cont) = ((ptext (sLit "ApplyTo") <+> ppr dup <+> pprParendExpr arg) @@ -258,21 +288,27 @@ countArgs (ApplyTo _ _ _ cont) = 1 + countArgs cont countArgs _ = 0 contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont) --- Uses substitution to turn each arg into an OutExpr -contArgs cont@(ApplyTo {}) - = case go [] cont of { (args, cont') -> (False, args, cont') } +-- Summarises value args, discards type args and coercions +-- The returned continuation of the call is only used to +-- answer questions like "are you interesting?" +contArgs cont + | lone cont = (True, [], cont) + | otherwise = go [] cont where + lone (ApplyTo {}) = False -- See Note [Lone variables] in CoreUnfold + lone (CoerceIt {}) = False + lone _ = True + go args (ApplyTo _ arg se cont) - | isTypeArg arg = go args cont - | otherwise = go (is_interesting arg se : args) cont - go args cont = (reverse args, cont) + | isTypeArg arg = go args cont + | otherwise = go (is_interesting arg se : args) cont + go args (CoerceIt _ cont) = go args cont + go args cont = (False, reverse args, cont) is_interesting arg se = interestingArg (substExpr (text "contArgs") se arg) -- Do *not* use short-cutting substitution here -- because we want to get as much IdInfo as possible -contArgs cont = (True, [], cont) - pushSimplifiedArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont pushSimplifiedArgs _env [] cont = cont pushSimplifiedArgs env (arg:args) cont = ApplyTo Simplified arg env (pushSimplifiedArgs env args cont) @@ -641,19 +677,21 @@ activeUnfolding env where mode = getMode env -getUnfoldingInRuleMatch :: SimplEnv -> IdUnfoldingFun +getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv -- When matching in RULE, we want to "look through" an unfolding -- (to see a constructor) if *rules* are on, even if *inlinings* -- are not. A notable example is DFuns, which really we want to -- match in rules like (op dfun) in gentle mode. Another example -- is 'otherwise' which we want exprIsConApp_maybe to be able to -- see very early on -getUnfoldingInRuleMatch env id - | unf_is_active = idUnfolding id - | otherwise = NoUnfolding +getUnfoldingInRuleMatch env + = (in_scope, id_unf) where + in_scope = seInScope env mode = getMode env - unf_is_active + id_unf id | unf_is_active id = idUnfolding id + | otherwise = NoUnfolding + unf_is_active id | not (sm_rules mode) = active_unfolding_minimal id | otherwise = isActive (sm_phase mode) (idInlineActivation id) @@ -1062,7 +1100,7 @@ mkLam _env bndrs body | not (any bad bndrs) -- Note [Casts and lambdas] = do { lam <- mkLam' dflags bndrs body - ; return (mkCast lam (mkPiCos bndrs co)) } + ; return (mkCast lam (mkPiCos Representational bndrs co)) } where co_vars = tyCoVarsOfCo co bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars @@ -1124,6 +1162,7 @@ because the latter is not well-kinded. \begin{code} tryEtaExpand :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr) -- See Note [Eta-expanding at let bindings] +-- and Note [Eta expansion to manifest arity] tryEtaExpand env bndr rhs = do { dflags <- getDynFlags ; (new_arity, new_rhs) <- try_expand dflags @@ -1471,7 +1510,7 @@ prepareAlts tries these things: Here "cannot match" includes knowledge from GADTs -It's a good idea do do this stuff before simplifying the alternatives, to +It's a good idea to do this stuff before simplifying the alternatives, to avoid simplifying alternatives we know can't happen, and to come up with the list of constructors that are handled, to put into the IdInfo of the case binder, for use when simplifying the alternatives. diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 9939e20ba6..b65feb295b 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -33,7 +33,6 @@ import CoreUtils import qualified CoreSubst import CoreArity import Rules ( lookupRule, getRules ) -import BasicTypes ( Arity ) import TysPrim ( realWorldStatePrimTy ) import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) ) import MonadUtils ( foldlM, mapAccumLM, liftIO ) @@ -537,6 +536,11 @@ These strange casts can happen as a result of case-of-case \begin{code} +makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (SimplEnv, ArgSpec) +makeTrivialArg env (ValArg e) = do { (env', e') <- makeTrivial NotTopLevel env e + ; return (env', ValArg e') } +makeTrivialArg env (CastBy co) = return (env, CastBy co) + makeTrivial :: TopLevelFlag -> SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Binds the expression to a variable, if it's not trivial, returning the variable makeTrivial top_lvl env expr = makeTrivialWithInfo top_lvl env vanillaIdInfo expr @@ -723,10 +727,10 @@ simplUnfolding :: SimplEnv-> TopLevelFlag -> OutExpr -> Unfolding -> SimplM Unfolding -- Note [Setting the new unfolding] -simplUnfolding env _ _ _ (DFunUnfolding ar con ops) - = return (DFunUnfolding ar con ops') - where - ops' = map (fmap (substExpr (text "simplUnfolding") env)) ops +simplUnfolding env _ _ _ df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = do { (env', bndrs') <- simplBinders env bndrs + ; args' <- mapM (simplExpr env') args + ; return (df { df_bndrs = bndrs', df_args = args' }) } simplUnfolding env top_lvl id _ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity @@ -1393,12 +1397,6 @@ completeCall env var cont = do { ------------- Try inlining ---------------- dflags <- getDynFlags ; let (lone_variable, arg_infos, call_cont) = contArgs cont - -- The args are OutExprs, obtained by *lazily* substituting - -- in the args found in cont. These args are only examined - -- to limited depth (unless a rule fires). But we must do - -- the substitution; rule matching on un-simplified args would - -- be bogus - n_val_args = length arg_infos interesting_cont = interestingCallContext call_cont unfolding = activeUnfolding env var @@ -1447,9 +1445,12 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con | not (contIsTrivial cont) -- Only do this if there is a non-trivial = return (env, castBottomExpr res cont_ty) -- contination to discard, else we do it where -- again and again! - res = mkApps (Var fun) (reverse rev_args) + res = argInfoExpr fun rev_args cont_ty = contResultType cont +rebuildCall env info (CoerceIt co cont) + = rebuildCall env (addCastTo info co) cont + rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont) = do { arg_ty' <- if isSimplified dup_flag then return arg_ty else simplType (se `setInScope` env) arg_ty @@ -1481,17 +1482,21 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty | otherwise = BoringCtxt -- Nothing interesting rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont + | null rules + = rebuild env (argInfoExpr fun rev_args) cont -- No rules, common case + + | otherwise = do { -- We've accumulated a simplified call in <fun,rev_args> -- so try rewrite rules; see Note [RULEs apply to simplified arguments] -- See also Note [Rules for recursive functions] - ; let args = reverse rev_args - env' = zapSubstEnv env - ; mb_rule <- tryRules env rules fun args cont + ; let env' = zapSubstEnv env + (args, cont') = argInfoValArgs env' rev_args cont + ; mb_rule <- tryRules env' rules fun args cont' ; case mb_rule of { - Just (n_args, rule_rhs) -> simplExprF env' rule_rhs $ - pushSimplifiedArgs env' (drop n_args args) cont ; - -- n_args says how many args the rule consumed - ; Nothing -> rebuild env (mkApps (Var fun) args) cont -- No rules + Just (rule_rhs, cont'') -> simplExprF env' rule_rhs cont'' + + -- Rules don't match + ; Nothing -> rebuild env (argInfoExpr fun rev_args) cont -- No rules } } \end{code} @@ -1551,22 +1556,25 @@ all this at once is TOO HARD! \begin{code} tryRules :: SimplEnv -> [CoreRule] -> Id -> [OutExpr] -> SimplCont - -> SimplM (Maybe (Arity, CoreExpr)) -- The arity is the number of - -- args consumed by the rule + -> SimplM (Maybe (CoreExpr, SimplCont)) +-- The SimplEnv already has zapSubstEnv applied to it + tryRules env rules fn args call_cont | null rules = return Nothing | otherwise = do { dflags <- getDynFlags - ; case lookupRule dflags (activeRule env) (getUnfoldingInRuleMatch env) - (getInScope env) fn args rules of { + ; case lookupRule dflags (getUnfoldingInRuleMatch env) (activeRule env) + fn args rules of { Nothing -> return Nothing ; -- No rule matches Just (rule, rule_rhs) -> - do { checkedTick (RuleFired (ru_name rule)) - ; dflags <- getDynFlags ; dump dflags rule rule_rhs - ; return (Just (ruleArity rule, rule_rhs)) }}} + ; let cont' = pushSimplifiedArgs env + (drop (ruleArity rule) args) + call_cont + -- (ruleArity rule) says how many args the rule consumed + ; return (Just (rule_rhs, cont')) }}} where dump dflags rule rule_rhs | dopt Opt_D_dump_rule_rewrites dflags @@ -1585,7 +1593,6 @@ tryRules env rules fn args call_cont log_rule dflags flag hdr details = liftIO . dumpSDoc dflags flag "" $ sep [text hdr, nest 4 details] - \end{code} Note [Rules for recursive functions] @@ -1857,17 +1864,16 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont | all isDeadBinder (case_bndr : bndrs) -- So this is just 'seq' = do { let rhs' = substExpr (text "rebuild-case") env rhs + env' = zapSubstEnv env out_args = [Type (substTy env (idType case_bndr)), Type (exprType rhs'), scrut, rhs'] -- Lazily evaluated, so we don't do most of this ; rule_base <- getSimplRules - ; mb_rule <- tryRules env (getRules rule_base seqId) seqId out_args cont + ; mb_rule <- tryRules env' (getRules rule_base seqId) seqId out_args cont ; case mb_rule of - Just (n_args, res) -> simplExprF (zapSubstEnv env) - (mkApps res (drop n_args out_args)) - cont - Nothing -> reallyRebuildCase env scrut case_bndr alts cont } + Just (rule_rhs, cont') -> simplExprF env' rule_rhs cont' + Nothing -> reallyRebuildCase env scrut case_bndr alts cont } rebuildCase env scrut case_bndr alts cont = reallyRebuildCase env scrut case_bndr alts cont @@ -2314,7 +2320,7 @@ mkDupableCont env cont@(StrictBind {}) mkDupableCont env (StrictArg info cci cont) -- See Note [Duplicating StrictArg] = do { (env', dup, nodup) <- mkDupableCont env cont - ; (env'', args') <- mapAccumLM (makeTrivial NotTopLevel) env' (ai_args info) + ; (env'', args') <- mapAccumLM makeTrivialArg env' (ai_args info) ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) } mkDupableCont env (ApplyTo _ arg se cont) diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 9c473e5a3a..b88888c96c 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -47,8 +47,8 @@ import Name ( Name, NamedThing(..) ) import NameEnv import Unify ( ruleMatchTyX, MatchEnv(..) ) import BasicTypes ( Activation, CompilerPhase, isActive ) -import DynFlags ( DynFlags ) import StaticFlags ( opt_PprStyle_Debug ) +import DynFlags ( DynFlags ) import Outputable import FastString import Maybes @@ -111,7 +111,7 @@ Note [Overall plumbing for rules] from HscEnv. [NB: we are inconsistent here. We should do the same for external - pacakges, but we don't. Same for type-class instances.] + packages, but we don't. Same for type-class instances.] * So in the outer simplifier loop, we combine (b-d) into a single RuleBase, reading @@ -351,16 +351,14 @@ pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs) -- supplied rules to this instance of an application in a given -- context, returning the rule applied and the resulting expression if -- successful. -lookupRule :: DynFlags - -> (Activation -> Bool) -- When rule is active - -> IdUnfoldingFun -- When Id can be unfolded - -> InScopeSet - -> Id -> [CoreExpr] - -> [CoreRule] -> Maybe (CoreRule, CoreExpr) +lookupRule :: DynFlags -> InScopeEnv + -> (Activation -> Bool) -- When rule is active + -> Id -> [CoreExpr] + -> [CoreRule] -> Maybe (CoreRule, CoreExpr) -- See Note [Extra args in rule matching] -- See comments on matchRule -lookupRule dflags is_active id_unf in_scope fn args rules +lookupRule dflags in_scope is_active fn args rules = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $ case go [] rules of [] -> Nothing @@ -370,7 +368,7 @@ lookupRule dflags is_active id_unf in_scope fn args rules go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] go ms [] = ms - go ms (r:rs) = case (matchRule dflags fn is_active id_unf in_scope args rough_args r) of + go ms (r:rs) = case (matchRule dflags in_scope is_active fn args rough_args r) of Just e -> go ((r,e):ms) rs Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$ -- ppr [ (arg_id, unfoldingTemplate unf) @@ -418,7 +416,7 @@ isMoreSpecific (BuiltinRule {}) _ = False isMoreSpecific (Rule {}) (BuiltinRule {}) = True isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 }) (Rule { ru_bndrs = bndrs2, ru_args = args2 }) - = isJust (matchN id_unfolding_fun in_scope bndrs2 args2 args1) + = isJust (matchN (in_scope, id_unfolding_fun) bndrs2 args2 args1) where id_unfolding_fun _ = NoUnfolding -- Don't expand in templates in_scope = mkInScopeSet (mkVarSet bndrs1) @@ -447,9 +445,8 @@ to lookupRule are the result of a lazy substitution \begin{code} ------------------------------------ -matchRule :: DynFlags -> Id -> (Activation -> Bool) -> IdUnfoldingFun - -> InScopeSet - -> [CoreExpr] -> [Maybe Name] +matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool) + -> Id -> [CoreExpr] -> [Maybe Name] -> CoreRule -> Maybe CoreExpr -- If (matchRule rule args) returns Just (name,rhs) @@ -474,21 +471,21 @@ matchRule :: DynFlags -> Id -> (Activation -> Bool) -> IdUnfoldingFun -- Any 'surplus' arguments in the input are simply put on the end -- of the output. -matchRule dflags fn _is_active id_unf _in_scope args _rough_args +matchRule dflags rule_env _is_active fn args _rough_args (BuiltinRule { ru_try = match_fn }) -- Built-in rules can't be switched off, it seems - = case match_fn dflags fn id_unf args of + = case match_fn dflags rule_env fn args of Just expr -> Just expr Nothing -> Nothing -matchRule _ _ is_active id_unf in_scope args rough_args - (Rule { ru_act = act, ru_rough = tpl_tops, - ru_bndrs = tpl_vars, ru_args = tpl_args, - ru_rhs = rhs }) +matchRule _ in_scope is_active _ args rough_args + (Rule { ru_act = act, ru_rough = tpl_tops + , ru_bndrs = tpl_vars, ru_args = tpl_args + , ru_rhs = rhs }) | not (is_active act) = Nothing | ruleCantMatch tpl_tops rough_args = Nothing | otherwise - = case matchN id_unf in_scope tpl_vars tpl_args args of + = case matchN in_scope tpl_vars tpl_args args of Nothing -> Nothing Just (bind_wrapper, tpl_vals) -> Just (bind_wrapper $ rule_fn `mkApps` tpl_vals) @@ -497,8 +494,7 @@ matchRule _ _ is_active id_unf in_scope args rough_args -- We could do this when putting things into the rulebase, I guess --------------------------------------- -matchN :: IdUnfoldingFun - -> InScopeSet -- ^ In-scope variables +matchN :: InScopeEnv -> [Var] -- ^ Match template type variables -> [CoreExpr] -- ^ Match template -> [CoreExpr] -- ^ Target; can have more elements than the template @@ -508,7 +504,7 @@ matchN :: IdUnfoldingFun -- the entire result and what should be substituted for each template variable. -- Fail if there are two few actual arguments from the target to match the template -matchN id_unf in_scope tmpl_vars tmpl_es target_es +matchN (in_scope, id_unf) tmpl_vars tmpl_es target_es = do { subst <- go init_menv emptyRuleSubst tmpl_es target_es ; return (rs_binds subst, map (lookup_tmpl subst) tmpl_vars') } @@ -572,14 +568,15 @@ necessary; the renamed ones are the tmpl_vars' -- * The BindWrapper in a RuleSubst are the bindings floated out -- from nested matches; see the Let case of match, below -- -data RuleEnv = RV { rv_tmpls :: VarSet -- Template variables - , rv_lcl :: RnEnv2 -- Renamings for *local bindings* - -- (lambda/case) - , rv_fltR :: Subst -- Renamings for floated let-bindings - -- domain disjoint from envR of rv_lcl - -- See Note [Matching lets] - , rv_unf :: IdUnfoldingFun - } +data RuleMatchEnv + = RV { rv_tmpls :: VarSet -- Template variables + , rv_lcl :: RnEnv2 -- Renamings for *local bindings* + -- (lambda/case) + , rv_fltR :: Subst -- Renamings for floated let-bindings + -- domain disjoint from envR of rv_lcl + -- See Note [Matching lets] + , rv_unf :: IdUnfoldingFun + } data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the , rs_id_subst :: IdSubstEnv -- template variables @@ -604,7 +601,7 @@ emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv -- SLPJ July 99 -match :: RuleEnv +match :: RuleMatchEnv -> RuleSubst -> CoreExpr -- Template -> CoreExpr -- Target @@ -720,23 +717,24 @@ match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text Nothing ------------- -match_co :: RuleEnv +match_co :: RuleMatchEnv -> RuleSubst -> Coercion -> Coercion -> Maybe RuleSubst match_co renv subst (CoVarCo cv) co = match_var renv subst cv (Coercion co) -match_co renv subst (Refl ty1) co +match_co renv subst (Refl r1 ty1) co = case co of - Refl ty2 -> match_ty renv subst ty1 ty2 - _ -> Nothing + Refl r2 ty2 + | r1 == r2 -> match_ty renv subst ty1 ty2 + _ -> Nothing match_co _ _ co1 _ = pprTrace "match_co: needs more cases" (ppr co1) Nothing -- Currently just deals with CoVarCo and Refl ------------- -rnMatchBndr2 :: RuleEnv -> RuleSubst -> Var -> Var -> RuleEnv +rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv rnMatchBndr2 renv subst x1 x2 = renv { rv_lcl = rnBndr2 rn_env x1 x2 , rv_fltR = delBndr (rv_fltR renv) x2 } @@ -746,7 +744,7 @@ rnMatchBndr2 renv subst x1 x2 -- there are some floated let-bindings ------------------------------------------ -match_alts :: RuleEnv +match_alts :: RuleMatchEnv -> RuleSubst -> [CoreAlt] -- Template -> [CoreAlt] -- Target @@ -772,7 +770,7 @@ okToFloat rn_env bind_fvs not_captured fv = not (inRnEnvR rn_env fv) ------------------------------------------ -match_var :: RuleEnv +match_var :: RuleMatchEnv -> RuleSubst -> Var -- Template -> CoreExpr -- Target @@ -801,7 +799,7 @@ match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env }) -- template x, so we must rename first! ------------------------------------------ -match_tmpl_var :: RuleEnv +match_tmpl_var :: RuleMatchEnv -> RuleSubst -> Var -- Template -> CoreExpr -- Target @@ -842,7 +840,7 @@ match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) -- because no free var of e2' is in the rnEnvR of the envt ------------------------------------------ -match_ty :: RuleEnv +match_ty :: RuleMatchEnv -> RuleSubst -> Type -- Template -> Type -- Target @@ -1096,7 +1094,8 @@ ruleAppCheck_help env fn args rules = ptext (sLit "Rule") <+> doubleQuotes (ftext name) rule_info dflags rule - | Just _ <- matchRule dflags fn noBlackList (rc_id_unf env) emptyInScopeSet args rough_args rule + | Just _ <- matchRule dflags (emptyInScopeSet, rc_id_unf env) + noBlackList fn args rough_args rule = text "matches (which is very peculiar!)" rule_info _ (BuiltinRule {}) = text "does not match" diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index 16c368e5c5..a5df7d52bc 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -132,7 +132,7 @@ because now t is allocated by the caller, then r and s are passed to the recursive call, which allocates the (r,s) pair again. This happens if - (a) the argument p is used in other than a case-scrutinsation way. + (a) the argument p is used in other than a case-scrutinisation way. (b) the argument to the call is not a 'fresh' tuple; you have to look into its unfolding to see that it's a tuple @@ -394,6 +394,22 @@ use the calls in the un-specialised RHS as seeds. We call these "boring call patterns", and callsToPats reports if it finds any of these. +Note [Top-level recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If all the bindings in a top-level recursive group are not exported, +all the calls are in the rest of the top-level bindings. +This means we can specialise with those call patterns instead of with the RHSs +of the recursive group. + +To get the call usage information, we work backwards through the top-level bindings +so we see the usage before we get to the binding of the function. +Before we can collect the usage though, we go through all the bindings and add them +to the environment. This is necessary because usage is only tracked for functions +in the environment. + +The actual seeding of the specialisation is very similar to Note [Local recursive group]. + + Note [Do not specialise diverging functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Specialising a function that just diverges is a waste of code. @@ -402,7 +418,7 @@ Furthermore, it broke GHC (simpl014) thus: f = \x. case x of (a,b) -> f x If we specialise f we get f = \x. case x of (a,b) -> fspec a b -But fspec doesn't have decent strictnes info. As it happened, +But fspec doesn't have decent strictness info. As it happened, (f x) :: IO t, so the state hack applied and we eta expanded fspec, and hence f. But now f's strictness is less than its arity, which breaks an invariant. @@ -451,7 +467,7 @@ foldl_loop. Note that This is all quite ugly; we ought to come up with a better design. ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set -sc_force to True when calling specLoop. This flag does three things: +sc_force to True when calling specLoop. This flag does four things: * Ignore specConstrThreshold, to specialise functions of arbitrary size (see scTopBind) * Ignore specConstrCount, to make arbitrary numbers of specialisations @@ -459,7 +475,7 @@ sc_force to True when calling specLoop. This flag does three things: * Specialise even for arguments that are not scrutinised in the loop (see argToPat; Trac #4488) * Only specialise on recursive types a finite number of times - (see is_too_recursive; Trac #5550) + (see is_too_recursive; Trac #5550; Note [Limit recursive specialisation]) This flag is inherited for nested non-recursive bindings (which are likely to be join points and hence should be fully specialised) but reset for nested @@ -507,6 +523,39 @@ Without the SPEC, if 'loop' were strict, the case would move out and we'd see loop applied to a pair. But if 'loop' isn't strict this doesn't look like a specialisable call. +Note [Limit recursive specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is possible for ForceSpecConstr to cause an infinite loop of specialisation. +Because there is no limit on the number of specialisations, a recursive call with +a recursive constructor as an argument (for example, list cons) will generate +a specialisation for that constructor. If the resulting specialisation also +contains a recursive call with the constructor, this could proceed indefinitely. + +For example, if ForceSpecConstr is on: + loop :: [Int] -> [Int] -> [Int] + loop z [] = z + loop z (x:xs) = loop (x:z) xs +this example will create a specialisation for the pattern + loop (a:b) c = loop' a b c + + loop' a b [] = (a:b) + loop' a b (x:xs) = loop (x:(a:b)) xs +and a new pattern is found: + loop (a:(b:c)) d = loop'' a b c d +which can continue indefinitely. + +Roman's suggestion to fix this was to stop after a couple of times on recursive types, +but still specialising on non-recursive types as much as possible. + +To implement this, we count the number of recursive constructors in each +function argument. If the maximum is greater than the specConstrRecursive limit, +do not specialise on that pattern. + +This is only necessary when ForceSpecConstr is on: otherwise the specConstrCount +will force termination anyway. + +See Trac #5550. + Note [NoSpecConstr] ~~~~~~~~~~~~~~~~~~~ The ignoreDataCon stuff allows you to say @@ -605,13 +654,22 @@ specConstrProgram guts dflags <- getDynFlags us <- getUniqueSupplyM annos <- getFirstAnnotations deserializeWithData guts - let binds' = fst $ initUs us (go (initScEnv dflags annos) (mg_binds guts)) + let binds' = reverse $ fst $ initUs us $ do + -- Note [Top-level recursive groups] + (env, binds) <- goEnv (initScEnv dflags annos) (mg_binds guts) + go env nullUsage (reverse binds) + return (guts { mg_binds = binds' }) where - go _ [] = return [] - go env (bind:binds) = do (env', bind') <- scTopBind env bind - binds' <- go env' binds - return (bind' : binds') + goEnv env [] = return (env, []) + goEnv env (bind:binds) = do (env', bind') <- scTopBindEnv env bind + (env'', binds') <- goEnv env' binds + return (env'', bind' : binds') + + go _ _ [] = return [] + go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind + binds' <- go env usg' binds + return (bind' : binds') \end{code} @@ -621,6 +679,48 @@ specConstrProgram guts %* * %************************************************************************ +Note [Work-free values only in environment] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The sc_vals field keeps track of in-scope value bindings, so +that if we come across (case x of Just y ->...) we can reduce the +case from knowing that x is bound to a pair. + +But only *work-free* values are ok here. For example if the envt had + x -> Just (expensive v) +then we do NOT want to expand to + let y = expensive v in ... +because the x-binding still exists and we've now duplicated (expensive v). + +This seldom happens because let-bound constructor applications are +ANF-ised, but it can happen as a result of on-the-fly transformations in +SpecConstr itself. Here is Trac #7865: + + let { + a'_shr = + case xs_af8 of _ { + [] -> acc_af6; + : ds_dgt [Dmd=<L,A>] ds_dgu [Dmd=<L,A>] -> + (expensive x_af7, x_af7 + } } in + let { + ds_sht = + case a'_shr of _ { (p'_afd, q'_afe) -> + TSpecConstr_DoubleInline.recursive + (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd) + } } in + +When processed knowing that xs_af8 was bound to a cons, we simplify to + a'_shr = (expensive x_af7, x_af7) +and we do NOT want to inline that at the occurrence of a'_shr in ds_sht. +(There are other occurrences of a'_shr.) No no no. + +It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned +into a work-free value again, thus + a1 = expensive x_af7 + a'_shr = (a1, x_af7) +but that's more work, so until its shown to be important I'm going to +leave it for now. + \begin{code} data ScEnv = SCE { sc_dflags :: DynFlags, sc_size :: Maybe Int, -- Size threshold @@ -643,6 +743,10 @@ data ScEnv = SCE { sc_dflags :: DynFlags, sc_vals :: ValueEnv, -- Domain is OutIds (*after* applying the substitution) -- Used even for top-level bindings (but not imported ones) + -- The range of the ValueEnv is *work-free* values + -- such as (\x. blah), or (Just v) + -- but NOT (Just (expensive v)) + -- See Note [Work-free values only in environment] sc_annotations :: UniqFM SpecConstrAnnotation } @@ -753,7 +857,10 @@ extendBndr env bndr = (env { sc_subst = subst' }, bndr') extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv extendValEnv env _ Nothing = env -extendValEnv env id (Just cv) = env { sc_vals = extendVarEnv (sc_vals env) id cv } +extendValEnv env id (Just cv) + | valueIsWorkFree cv -- Don't duplicate work!! Trac #7865 + = env { sc_vals = extendVarEnv (sc_vals env) id cv } +extendValEnv env _ _ = env extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var]) -- When we encounter @@ -863,7 +970,7 @@ Note [Avoiding exponential blowup] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The sc_count field of the ScEnv says how many times we are prepared to duplicate a single function. But we must take care with recursive -specialiations. Consider +specialisations. Consider let $j1 = let $j2 = let $j3 = ... in @@ -1176,38 +1283,62 @@ mkVarUsage env fn args | otherwise = evalScrutOcc ---------------------- -scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind) -scTopBind env (Rec prs) +scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind) +scTopBindEnv env (Rec prs) + = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs + rhs_env2 = extendHowBound rhs_env1 bndrs RecFun + + prs' = zip bndrs' rhss + ; return (rhs_env2, Rec prs') } + where + (bndrs,rhss) = unzip prs + +scTopBindEnv env (NonRec bndr rhs) + = do { let (env1, bndr') = extendBndr env bndr + env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs) + ; return (env2, NonRec bndr' rhs) } + +---------------------- +scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind) + +{- +scTopBind _ usage _ + | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False + = error "false" +-} + +scTopBind env usage (Rec prs) | Just threshold <- sc_size env , not force_spec , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss) -- No specialisation - = do { let (rhs_env,bndrs') = extendRecBndrs env bndrs - ; (_, rhss') <- mapAndUnzipM (scExpr rhs_env) rhss - ; return (rhs_env, Rec (bndrs' `zip` rhss')) } + = do { (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss + ; return (usage `combineUsage` (combineUsages rhs_usgs), Rec (bndrs `zip` rhss')) } | otherwise -- Do specialisation - = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs - rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun + = do { (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs env) (bndrs `zip` rhss) + -- ; pprTrace "scTopBind" (ppr bndrs $$ ppr (map (lookupVarEnv (scu_calls usage)) bndrs)) (return ()) - ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss) - ; let rhs_usg = combineUsages rhs_usgs + -- Note [Top-level recursive groups] + ; let (usg,rest) = if all (not . isExportedId) bndrs + then -- pprTrace "scTopBind-T" (ppr bndrs $$ ppr (map (fmap (map snd) . lookupVarEnv (scu_calls usage)) bndrs)) + ( usage + , [SI [] 0 (Just us) | us <- rhs_usgs] ) + else ( combineUsages rhs_usgs + , [SI [] 0 Nothing | _ <- rhs_usgs] ) - ; (_, specs) <- specLoop (scForce rhs_env2 force_spec) - (scu_calls rhs_usg) rhs_infos nullUsage - [SI [] 0 Nothing | _ <- bndrs] + ; (usage', specs) <- specLoop (scForce env force_spec) + (scu_calls usg) rhs_infos nullUsage rest - ; return (rhs_env1, -- For the body of the letrec, delete the RecFun business + ; return (usage `combineUsage` usage', Rec (concat (zipWith specInfoBinds rhs_infos specs))) } where (bndrs,rhss) = unzip prs force_spec = any (forceSpecBndr env) bndrs -- Note [Forcing specialisation] -scTopBind env (NonRec bndr rhs) - = do { (_, rhs') <- scExpr env rhs - ; let (env1, bndr') = extendBndr env bndr - env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs') - ; return (env2, NonRec bndr' rhs') } +scTopBind env usage (NonRec bndr rhs) + = do { (rhs_usg', rhs') <- scExpr env rhs + ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') } ---------------------- scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (ScUsage, RhsInfo) @@ -1233,6 +1364,7 @@ specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _) -- And now the original binding where rules = [r | OS _ r _ _ <- specs] + \end{code} @@ -1540,6 +1672,7 @@ is_too_recursive :: ScEnv -> (CallPat, ValueEnv) -> Bool -- filter out if there are more than the maximum. -- This is only necessary if ForceSpecConstr is in effect: -- otherwise specConstrCount will cause specialisation to terminate. + -- See Note [Limit recursive specialisation] is_too_recursive env ((_,exprs), val_env) = sc_force env && maximum (map go exprs) > sc_recursive env where @@ -1568,7 +1701,7 @@ callToPats env bndr_occs (con_env, args) ; let pat_fvs = varSetElems (exprsFreeVars pats) in_scope_vars = getInScopeVars in_scope qvars = filterOut (`elemVarSet` in_scope_vars) pat_fvs - -- Quantify over variables that are not in sccpe + -- Quantify over variables that are not in scope -- at the call site -- See Note [Free type variables of the qvar types] -- See Note [Shadowing] at the top @@ -1647,7 +1780,7 @@ argToPat env in_scope val_env (Cast arg co) arg_occ { -- Make a wild-card pattern for the coercion uniq <- getUniqueUs ; let co_name = mkSysTvName uniq (fsLit "sg") - co_var = mkCoVar co_name (mkCoercionType ty1 ty2) + co_var = mkCoVar co_name (mkCoercionType Representational ty1 ty2) ; return (interesting, Cast arg' (mkCoVarCo co_var)) } } where Pair ty1 ty2 = coercionKind co @@ -1747,10 +1880,10 @@ isValue _env (Lit lit) | otherwise = Just (ConVal (LitAlt lit) []) isValue env (Var v) - | Just stuff <- lookupVarEnv env v - = Just stuff -- You might think we could look in the idUnfolding here - -- but that doesn't take account of which branch of a - -- case we are in, which is the whole point + | Just cval <- lookupVarEnv env v + = Just cval -- You might think we could look in the idUnfolding here + -- but that doesn't take account of which branch of a + -- case we are in, which is the whole point | not (isLocalId v) && isCheapUnfolding unf = isValue env (unfoldingTemplate unf) @@ -1782,6 +1915,10 @@ isValue _env expr -- Maybe it's a constructor application isValue _env _expr = Nothing +valueIsWorkFree :: Value -> Bool +valueIsWorkFree LambdaVal = True +valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args + samePat :: CallPat -> CallPat -> Bool samePat (vs1, as1) (vs2, as2) = all2 same as1 as2 diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index e6e4c48092..bf73bec240 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -10,7 +10,7 @@ module Specialise ( specProgram ) where import Id import TcType hiding( substTy, extendTvSubstList ) -import Type( TyVar, isDictTy, mkPiTypes ) +import Type( TyVar, isDictTy, mkPiTypes, classifyPredType, PredTree(..), isIPClass ) import Coercion( Coercion ) import CoreMonad import qualified CoreSubst @@ -1044,7 +1044,8 @@ specCalls env rules_for_me calls_for_me fn rhs ; return (spec_rules, spec_defns, plusUDList spec_uds) } | otherwise -- No calls or RHS doesn't fit our preconceptions - = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for") + = WARN( not (exprIsTrivial rhs) && notNull calls_for_me, + ptext (sLit "Missed specialisation opportunity for") <+> ppr fn $$ _trace_doc ) -- Note [Specialisation shape] -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $ @@ -1077,8 +1078,9 @@ specCalls env rules_for_me calls_for_me fn rhs already_covered :: DynFlags -> [CoreExpr] -> Bool already_covered dflags args -- Note [Specialisations already covered] - = isJust (lookupRule dflags (const True) realIdUnfolding - (CoreSubst.substInScope (se_subst env)) + = isJust (lookupRule dflags + (CoreSubst.substInScope (se_subst env), realIdUnfolding) + (const True) fn args rules_for_me) mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr] @@ -1429,6 +1431,18 @@ It's a silly exapmle, but we get where choose doesn't have any dict arguments. Thus far I have not tried to fix this (wait till there's a real example). +Mind you, then 'choose' will be inlined (since RHS is trivial) so +it doesn't matter. This comes up with single-method classes + + class C a where { op :: a -> a } + instance C a => C [a] where .... +==> + $fCList :: C a => C [a] + $fCList = $copList |> (...coercion>...) + ....(uses of $fCList at particular types)... + +So we suppress the WARN if the rhs is trivial. + Note [Inline specialisations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is what we do with the InlinePragma of the original function @@ -1583,7 +1597,9 @@ mkCallUDs :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails mkCallUDs env f args | not (want_calls_for f) -- Imported from elsewhere || null theta -- Not overloaded - || not (all type_determines_value theta) + = emptyUDs + + | not (all type_determines_value theta) || not (spec_tys `lengthIs` n_tyvars) || not ( dicts `lengthIs` n_dicts) || not (any (interestingDict env) dicts) -- Note [Interesting dictionary arguments] @@ -1611,14 +1627,36 @@ mkCallUDs env f args want_calls_for f = isLocalId f || isInlinablePragma (idInlinePragma f) - type_determines_value pred = isClassPred pred && not (isIPPred pred) - -- Only specialise if all overloading is on non-IP *class* params, - -- because these are the ones whose *type* determines their *value*. - -- In ptic, with implicit params, the type args - -- *don't* say what the value of the implicit param is! - -- See Trac #7101 + type_determines_value pred -- See Note [Type determines value] + = case classifyPredType pred of + ClassPred cls _ -> not (isIPClass cls) + TuplePred ps -> all type_determines_value ps + EqPred {} -> True + IrredPred {} -> True -- Things like (D []) where D is a + -- Constraint-ranged family; Trac #7785 \end{code} +Note [Type determines value] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Only specialise if all overloading is on non-IP *class* params, +because these are the ones whose *type* determines their *value*. In +parrticular, with implicit params, the type args *don't* say what the +value of the implicit param is! See Trac #7101 + +However, consider + type family D (v::*->*) :: Constraint + type instance D [] = () + f :: D v => v Char -> Int +If we see a call (f "foo"), we'll pass a "dictionary" + () |> (g :: () ~ D []) +and it's good to specialise f at this dictionary. + +So the question is: can an implicit parameter "hide inside" a +type-family constraint like (D a). Well, no. We don't allow + type instance D Maybe = ?x:Int +Hence the IrredPred case in type_determines_value. +See Trac #7785. + Note [Interesting dictionary arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this @@ -1844,6 +1882,12 @@ instance MonadUnique SpecM where put $ st { spec_uniq_supply = us2 } return us1 + getUniqueM + = SpecM $ do st <- get + let (u,us') = takeUniqFromSupply $ spec_uniq_supply st + put $ st { spec_uniq_supply = us' } + return u + instance HasDynFlags SpecM where getDynFlags = SpecM $ liftM spec_dflags get diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index ac253f3e95..c87de4e65f 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -1,12 +1,15 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -% -\section[CoreToStg]{Converts Core to STG Syntax} +\begin{code} +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-- -And, as we have the info in hand, we may convert some lets to -let-no-escapes. +-------------------------------------------------------------- +-- Converting Core to STG Syntax +-------------------------------------------------------------- + +-- And, as we have the info in hand, we may convert some lets to +-- let-no-escapes. -\begin{code} module CoreToStg ( coreToStg, coreExprToStg ) where #include "HsVersions.h" @@ -26,6 +29,7 @@ import CostCentre ( noCCS ) import VarSet import VarEnv import Maybes ( maybeToBool ) +import Module import Name ( getOccName, isExternalName, nameOccName ) import OccName ( occNameString, occNameFS ) import BasicTypes ( Arity ) @@ -37,114 +41,151 @@ import FastString import Util import DynFlags import ForeignCall +import Demand ( isSingleUsed ) import PrimOp ( PrimCall(..) ) -\end{code} - -%************************************************************************ -%* * -\subsection[live-vs-free-doc]{Documentation} -%* * -%************************************************************************ - -(There is other relevant documentation in codeGen/CgLetNoEscape.) - -The actual Stg datatype is decorated with {\em live variable} -information, as well as {\em free variable} information. The two are -{\em not} the same. Liveness is an operational property rather than a -semantic one. A variable is live at a particular execution point if -it can be referred to {\em directly} again. In particular, a dead -variable's stack slot (if it has one): -\begin{enumerate} -\item -should be stubbed to avoid space leaks, and -\item -may be reused for something else. -\end{enumerate} - -There ought to be a better way to say this. Here are some examples: -\begin{verbatim} - let v = [q] \[x] -> e - in - ...v... (but no q's) -\end{verbatim} - -Just after the `in', v is live, but q is dead. If the whole of that -let expression was enclosed in a case expression, thus: -\begin{verbatim} - case (let v = [q] \[x] -> e in ...v...) of - alts[...q...] -\end{verbatim} -(ie @alts@ mention @q@), then @q@ is live even after the `in'; because -we'll return later to the @alts@ and need it. - -Let-no-escapes make this a bit more interesting: -\begin{verbatim} - let-no-escape v = [q] \ [x] -> e - in - ...v... -\end{verbatim} -Here, @q@ is still live at the `in', because @v@ is represented not by -a closure but by the current stack state. In other words, if @v@ is -live then so is @q@. Furthermore, if @e@ mentions an enclosing -let-no-escaped variable, then {\em its} free variables are also live -if @v@ is. - -%************************************************************************ -%* * -\subsection[caf-info]{Collecting live CAF info} -%* * -%************************************************************************ - -In this pass we also collect information on which CAFs are live for -constructing SRTs (see SRT.lhs). - -A top-level Id has CafInfo, which is - - - MayHaveCafRefs, if it may refer indirectly to - one or more CAFs, or - - NoCafRefs if it definitely doesn't - -The CafInfo has already been calculated during the CoreTidy pass. - -During CoreToStg, we then pin onto each binding and case expression, a -list of Ids which represents the "live" CAFs at that point. The meaning -of "live" here is the same as for live variables, see above (which is -why it's convenient to collect CAF information here rather than elsewhere). - -The later SRT pass takes these lists of Ids and uses them to construct -the actual nested SRTs, and replaces the lists of Ids with (offset,length) -pairs. - - -Interaction of let-no-escape with SRTs [Sept 01] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - let-no-escape x = ...caf1...caf2... - in - ...x...x...x... - -where caf1,caf2 are CAFs. Since x doesn't have a closure, we -build SRTs just as if x's defn was inlined at each call site, and -that means that x's CAF refs get duplicated in the overall SRT. - -This is unlike ordinary lets, in which the CAF refs are not duplicated. - -We could fix this loss of (static) sharing by making a sort of pseudo-closure -for x, solely to put in the SRTs lower down. - -%************************************************************************ -%* * -\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs} -%* * -%************************************************************************ - -\begin{code} -coreToStg :: DynFlags -> CoreProgram -> IO [StgBinding] -coreToStg dflags pgm +-- Note [Live vs free] +-- ~~~~~~~~~~~~~~~~~~~ +-- +-- The actual Stg datatype is decorated with live variable information, as well +-- as free variable information. The two are not the same. Liveness is an +-- operational property rather than a semantic one. A variable is live at a +-- particular execution point if it can be referred to directly again. In +-- particular, a dead variable's stack slot (if it has one): +-- +-- - should be stubbed to avoid space leaks, and +-- - may be reused for something else. +-- +-- There ought to be a better way to say this. Here are some examples: +-- +-- let v = [q] \[x] -> e +-- in +-- ...v... (but no q's) +-- +-- Just after the `in', v is live, but q is dead. If the whole of that +-- let expression was enclosed in a case expression, thus: +-- +-- case (let v = [q] \[x] -> e in ...v...) of +-- alts[...q...] +-- +-- (ie `alts' mention `q'), then `q' is live even after the `in'; because +-- we'll return later to the `alts' and need it. +-- +-- Let-no-escapes make this a bit more interesting: +-- +-- let-no-escape v = [q] \ [x] -> e +-- in +-- ...v... +-- +-- Here, `q' is still live at the `in', because `v' is represented not by +-- a closure but by the current stack state. In other words, if `v' is +-- live then so is `q'. Furthermore, if `e' mentions an enclosing +-- let-no-escaped variable, then its free variables are also live if `v' is. + +-- Note [Collecting live CAF info] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- In this pass we also collect information on which CAFs are live for +-- constructing SRTs (see SRT.lhs). +-- +-- A top-level Id has CafInfo, which is +-- +-- - MayHaveCafRefs, if it may refer indirectly to +-- one or more CAFs, or +-- - NoCafRefs if it definitely doesn't +-- +-- The CafInfo has already been calculated during the CoreTidy pass. +-- +-- During CoreToStg, we then pin onto each binding and case expression, a +-- list of Ids which represents the "live" CAFs at that point. The meaning +-- of "live" here is the same as for live variables, see above (which is +-- why it's convenient to collect CAF information here rather than elsewhere). +-- +-- The later SRT pass takes these lists of Ids and uses them to construct +-- the actual nested SRTs, and replaces the lists of Ids with (offset,length) +-- pairs. + + +-- Note [Interaction of let-no-escape with SRTs] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Consider +-- +-- let-no-escape x = ...caf1...caf2... +-- in +-- ...x...x...x... +-- +-- where caf1,caf2 are CAFs. Since x doesn't have a closure, we +-- build SRTs just as if x's defn was inlined at each call site, and +-- that means that x's CAF refs get duplicated in the overall SRT. +-- +-- This is unlike ordinary lets, in which the CAF refs are not duplicated. +-- +-- We could fix this loss of (static) sharing by making a sort of pseudo-closure +-- for x, solely to put in the SRTs lower down. + +-- Note [What is a non-escaping let] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Consider: +-- +-- let x = fvs \ args -> e +-- in +-- if ... then x else +-- if ... then x else ... +-- +-- `x' is used twice (so we probably can't unfold it), but when it is +-- entered, the stack is deeper than it was when the definition of `x' +-- happened. Specifically, if instead of allocating a closure for `x', +-- we saved all `x's fvs on the stack, and remembered the stack depth at +-- that moment, then whenever we enter `x' we can simply set the stack +-- pointer(s) to these remembered (compile-time-fixed) values, and jump +-- to the code for `x'. +-- +-- All of this is provided x is: +-- 1. non-updatable; +-- 2. guaranteed to be entered before the stack retreats -- ie x is not +-- buried in a heap-allocated closure, or passed as an argument to +-- something; +-- 3. all the enters have exactly the right number of arguments, +-- no more no less; +-- 4. all the enters are tail calls; that is, they return to the +-- caller enclosing the definition of `x'. +-- +-- Under these circumstances we say that `x' is non-escaping. +-- +-- An example of when (4) does not hold: +-- +-- let x = ... +-- in case x of ...alts... +-- +-- Here, `x' is certainly entered only when the stack is deeper than when +-- `x' is defined, but here it must return to ...alts... So we can't just +-- adjust the stack down to `x''s recalled points, because that would lost +-- alts' context. +-- +-- Things can get a little more complicated. Consider: +-- +-- let y = ... +-- in let x = fvs \ args -> ...y... +-- in ...x... +-- +-- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a +-- non-escaping way in ...y..., then `y' is non-escaping. +-- +-- `x' can even be recursive! Eg: +-- +-- letrec x = [y] \ [v] -> if v then x True else ... +-- in +-- ...(x b)... + +-- -------------------------------------------------------------- +-- Setting variable info: top-level, binds, RHSs +-- -------------------------------------------------------------- + +coreToStg :: DynFlags -> Module -> CoreProgram -> IO [StgBinding] +coreToStg dflags this_mod pgm = return pgm' - where (_, _, pgm') = coreTopBindsToStg dflags emptyVarEnv pgm + where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm coreExprToStg :: CoreExpr -> StgExpr coreExprToStg expr @@ -153,35 +194,37 @@ coreExprToStg expr coreTopBindsToStg :: DynFlags + -> Module -> IdEnv HowBound -- environment for the bindings -> CoreProgram -> (IdEnv HowBound, FreeVarsInfo, [StgBinding]) -coreTopBindsToStg _ env [] = (env, emptyFVInfo, []) -coreTopBindsToStg dflags env (b:bs) +coreTopBindsToStg _ _ env [] = (env, emptyFVInfo, []) +coreTopBindsToStg dflags this_mod env (b:bs) = (env2, fvs2, b':bs') where -- Notice the mutually-recursive "knot" here: -- env accumulates down the list of binds, -- fvs accumulates upwards - (env1, fvs2, b' ) = coreTopBindToStg dflags env fvs1 b - (env2, fvs1, bs') = coreTopBindsToStg dflags env1 bs + (env1, fvs2, b' ) = coreTopBindToStg dflags this_mod env fvs1 b + (env2, fvs1, bs') = coreTopBindsToStg dflags this_mod env1 bs coreTopBindToStg :: DynFlags + -> Module -> IdEnv HowBound -> FreeVarsInfo -- Info about the body -> CoreBind -> (IdEnv HowBound, FreeVarsInfo, StgBinding) -coreTopBindToStg dflags env body_fvs (NonRec id rhs) +coreTopBindToStg dflags this_mod env body_fvs (NonRec id rhs) = let env' = extendVarEnv env id how_bound how_bound = LetBound TopLet $! manifestArity rhs (stg_rhs, fvs') = initLne env $ do - (stg_rhs, fvs') <- coreToTopStgRhs dflags body_fvs (id,rhs) + (stg_rhs, fvs') <- coreToTopStgRhs dflags this_mod body_fvs (id,rhs) return (stg_rhs, fvs') bind = StgNonRec id stg_rhs @@ -193,7 +236,7 @@ coreTopBindToStg dflags env body_fvs (NonRec id rhs) -- assertion again! (env', fvs' `unionFVInfo` body_fvs, bind) -coreTopBindToStg dflags env body_fvs (Rec pairs) +coreTopBindToStg dflags this_mod env body_fvs (Rec pairs) = ASSERT( not (null pairs) ) let binders = map fst pairs @@ -204,7 +247,7 @@ coreTopBindToStg dflags env body_fvs (Rec pairs) (stg_rhss, fvs') = initLne env' $ do - (stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs dflags body_fvs) pairs + (stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs dflags this_mod body_fvs) pairs let fvs' = unionFVInfos fvss' return (stg_rhss, fvs') @@ -228,20 +271,19 @@ consistentCafInfo id bind id_marked_caffy = mayHaveCafRefs (idCafInfo id) binding_is_caffy = stgBindHasCafRefs bind is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat" -\end{code} -\begin{code} coreToTopStgRhs :: DynFlags + -> Module -> FreeVarsInfo -- Free var info for the scope of the binding -> (Id,CoreExpr) -> LneM (StgRhs, FreeVarsInfo) -coreToTopStgRhs dflags scope_fv_info (bndr, rhs) +coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs) = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs ; lv_info <- freeVarsToLiveVars rhs_fvs - ; let stg_rhs = mkTopStgRhs dflags rhs_fvs (mkSRT lv_info) bndr_info new_rhs + ; let stg_rhs = mkTopStgRhs dflags this_mod rhs_fvs (mkSRT lv_info) bndr bndr_info new_rhs stg_arity = stgRhsArity stg_rhs ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs, rhs_fvs) } @@ -267,35 +309,37 @@ coreToTopStgRhs dflags scope_fv_info (bndr, rhs) ptext (sLit "Id arity:") <+> ppr id_arity, ptext (sLit "STG arity:") <+> ppr stg_arity] -mkTopStgRhs :: DynFlags -> FreeVarsInfo - -> SRT -> StgBinderInfo -> StgExpr +mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo + -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs -mkTopStgRhs _ rhs_fvs srt binder_info (StgLam bndrs body) +mkTopStgRhs _ _ rhs_fvs srt _ binder_info (StgLam bndrs body) = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) ReEntrant srt bndrs body -mkTopStgRhs dflags _ _ _ (StgConApp con args) - | not (isDllConApp dflags con args) -- Dynamic StgConApps are updatable +mkTopStgRhs dflags this_mod _ _ _ _ (StgConApp con args) + | not (isDllConApp dflags this_mod con args) -- Dynamic StgConApps are updatable = StgRhsCon noCCS con args -mkTopStgRhs _ rhs_fvs srt binder_info rhs +mkTopStgRhs _ _ rhs_fvs srt bndr binder_info rhs = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) - Updatable + (getUpdateFlag bndr) srt [] rhs -\end{code} +getUpdateFlag :: Id -> UpdateFlag +getUpdateFlag bndr + = if isSingleUsed (idDemandInfo bndr) + then SingleEntry else Updatable -- --------------------------------------------------------------------------- -- Expressions -- --------------------------------------------------------------------------- -\begin{code} coreToStgExpr :: CoreExpr -> LneM (StgExpr, -- Decorated STG expr @@ -305,15 +349,13 @@ coreToStgExpr -- because we are only interested in the escapees -- for vars which might be turned into -- let-no-escaped ones. -\end{code} -The second and third components can be derived in a simple bottom up pass, not -dependent on any decisions about which variables will be let-no-escaped or -not. The first component, that is, the decorated expression, may then depend -on these components, but it in turn is not scrutinised as the basis for any -decisions. Hence no black holes. +-- The second and third components can be derived in a simple bottom up pass, not +-- dependent on any decisions about which variables will be let-no-escaped or +-- not. The first component, that is, the decorated expression, may then depend +-- on these components, but it in turn is not scrutinised as the basis for any +-- decisions. Hence no black holes. -\begin{code} -- No LitInteger's should be left by the time this is called. CorePrep -- should have converted them all to a real core representation. coreToStgExpr (Lit (LitInteger {})) = panic "coreToStgExpr: LitInteger" @@ -436,13 +478,12 @@ coreToStgExpr (Case scrut bndr _ alts) = do rhs_escs `delVarSetList` binders' ) -- ToDo: remove the delVarSet; -- since escs won't include any of these binders -\end{code} -Lets not only take quite a bit of work, but this is where we convert -then to let-no-escapes, if we wish. +-- Lets not only take quite a bit of work, but this is where we convert +-- then to let-no-escapes, if we wish. +-- (Meanwhile, we don't expect to see let-no-escapes...) + -(Meanwhile, we don't expect to see let-no-escapes...) -\begin{code} coreToStgExpr (Let bind body) = do (new_let, fvs, escs, _) <- mfix (\ ~(_, _, _, no_binder_escapes) -> @@ -452,9 +493,7 @@ coreToStgExpr (Let bind body) = do return (new_let, fvs, escs) coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e) -\end{code} -\begin{code} mkStgAltType :: Id -> [CoreAlt] -> AltType mkStgAltType bndr alts = case repType (idType bndr) of UnaryRep rep_ty -> case tyConAppTyCon_maybe rep_ty of @@ -486,14 +525,11 @@ mkStgAltType bndr alts = case repType (idType bndr) of PolyAlt where (data_alts, _deflt) = findDefault alts -\end{code} - -- --------------------------------------------------------------------------- -- Applications -- --------------------------------------------------------------------------- -\begin{code} coreToStgApp :: Maybe UpdateFlag -- Just upd <=> this application is -- the rhs of a thunk binding @@ -766,10 +802,8 @@ is_join_var :: Id -> Bool -- A hack (used only for compiler debuggging) to tell if -- a variable started life as a join point ($j) is_join_var j = occNameString (getOccName j) == "$j" -\end{code} -\begin{code} -coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding +coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding -> [Id] -> (Id,CoreExpr) -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet) @@ -777,27 +811,27 @@ coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the bi coreToStgRhs scope_fv_info binders (bndr, rhs) = do (new_rhs, rhs_fvs, rhs_escs) <- coreToStgExpr rhs lv_info <- freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs) - return (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs, + return (mkStgRhs rhs_fvs (mkSRT lv_info) bndr bndr_info new_rhs, rhs_fvs, lv_info, rhs_escs) where bndr_info = lookupFVInfo scope_fv_info bndr -mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs +mkStgRhs :: FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs -mkStgRhs _ _ _ (StgConApp con args) = StgRhsCon noCCS con args +mkStgRhs _ _ _ _ (StgConApp con args) = StgRhsCon noCCS con args -mkStgRhs rhs_fvs srt binder_info (StgLam bndrs body) +mkStgRhs rhs_fvs srt _ binder_info (StgLam bndrs body) = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) ReEntrant srt bndrs body -mkStgRhs rhs_fvs srt binder_info rhs +mkStgRhs rhs_fvs srt bndr binder_info rhs = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) upd_flag srt [] rhs where - upd_flag = Updatable + upd_flag = getUpdateFlag bndr {- SDM: disabled. Eval/Apply can't handle functions with arity zero very well; and making these into simple non-updatable thunks breaks other @@ -805,7 +839,32 @@ mkStgRhs rhs_fvs srt binder_info rhs upd_flag | isPAP env rhs = ReEntrant | otherwise = Updatable - -} + +-- Detect thunks which will reduce immediately to PAPs, and make them +-- non-updatable. This has several advantages: +-- +-- - the non-updatable thunk behaves exactly like the PAP, +-- +-- - the thunk is more efficient to enter, because it is +-- specialised to the task. +-- +-- - we save one update frame, one stg_update_PAP, one update +-- and lots of PAP_enters. +-- +-- - in the case where the thunk is top-level, we save building +-- a black hole and futhermore the thunk isn't considered to +-- be a CAF any more, so it doesn't appear in any SRTs. +-- +-- We do it here, because the arity information is accurate, and we need +-- to do it before the SRT pass to save the SRT entries associated with +-- any top-level PAPs. + +isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args + where + arity = stgArity f (lookupBinding env f) +isPAP env _ = False + +-} {- ToDo: upd = if isOnceDem dem @@ -823,43 +882,14 @@ mkStgRhs rhs_fvs srt binder_info rhs -- specifically Main.lvl6 in spectral/cryptarithm2. -- So no great loss. KSW 2000-07. -} -\end{code} - -Detect thunks which will reduce immediately to PAPs, and make them -non-updatable. This has several advantages: - - - the non-updatable thunk behaves exactly like the PAP, - - - the thunk is more efficient to enter, because it is - specialised to the task. - - - we save one update frame, one stg_update_PAP, one update - and lots of PAP_enters. - - - in the case where the thunk is top-level, we save building - a black hole and futhermore the thunk isn't considered to - be a CAF any more, so it doesn't appear in any SRTs. - -We do it here, because the arity information is accurate, and we need -to do it before the SRT pass to save the SRT entries associated with -any top-level PAPs. -isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args - where - arity = stgArity f (lookupBinding env f) -isPAP env _ = False - - -%************************************************************************ -%* * -\subsection[LNE-monad]{A little monad for this let-no-escaping pass} -%* * -%************************************************************************ +-- --------------------------------------------------------------------------- +-- A little monad for this let-no-escaping pass +-- --------------------------------------------------------------------------- -There's a lot of stuff to pass around, so we use this @LneM@ monad to -help. All the stuff here is only passed *down*. +-- There's a lot of stuff to pass around, so we use this LneM monad to +-- help. All the stuff here is only passed *down*. -\begin{code} newtype LneM a = LneM { unLneM :: IdEnv HowBound -> LiveInfo -- Vars and CAFs live in continuation @@ -899,23 +929,21 @@ topLevelBound :: HowBound -> Bool topLevelBound ImportBound = True topLevelBound (LetBound TopLet _) = True topLevelBound _ = False -\end{code} - -For a let(rec)-bound variable, x, we record LiveInfo, the set of -variables that are live if x is live. This LiveInfo comprises - (a) dynamic live variables (ones with a non-top-level binding) - (b) static live variabes (CAFs or things that refer to CAFs) - -For "normal" variables (a) is just x alone. If x is a let-no-escaped -variable then x is represented by a code pointer and a stack pointer -(well, one for each stack). So all of the variables needed in the -execution of x are live if x is, and are therefore recorded in the -LetBound constructor; x itself *is* included. -The set of dynamic live variables is guaranteed ot have no further let-no-escaped -variables in it. +-- For a let(rec)-bound variable, x, we record LiveInfo, the set of +-- variables that are live if x is live. This LiveInfo comprises +-- (a) dynamic live variables (ones with a non-top-level binding) +-- (b) static live variabes (CAFs or things that refer to CAFs) +-- +-- For "normal" variables (a) is just x alone. If x is a let-no-escaped +-- variable then x is represented by a code pointer and a stack pointer +-- (well, one for each stack). So all of the variables needed in the +-- execution of x are live if x is, and are therefore recorded in the +-- LetBound constructor; x itself *is* included. +-- +-- The set of dynamic live variables is guaranteed ot have no further +-- let-no-escaped variables in it. -\begin{code} emptyLiveInfo :: LiveInfo emptyLiveInfo = (emptyVarSet,emptyVarSet) @@ -936,11 +964,9 @@ mkSRT (_, cafs) = SRTEntries cafs getLiveVars :: LiveInfo -> StgLiveVars getLiveVars (lvs, _) = lvs -\end{code} +-- The std monad functions: -The std monad functions: -\begin{code} initLne :: IdEnv HowBound -> LneM a -> a initLne env m = unLneM m env emptyLiveInfo @@ -964,11 +990,9 @@ instance MonadFix LneM where mfix expr = LneM $ \env lvs_cont -> let result = unLneM (expr result) env lvs_cont in result -\end{code} -Functions specific to this monad: +-- Functions specific to this monad: -\begin{code} getVarsLiveInCont :: LneM LiveInfo getVarsLiveInCont = LneM $ \_env lvs_cont -> lvs_cont @@ -1015,15 +1039,12 @@ freeVarsToLiveVars fvs = LneM freeVarsToLiveVars' -- (see the invariant on NestedLet) _lambda_or_case_binding -> unitLiveVar v -- Bound by lambda or case -\end{code} -%************************************************************************ -%* * -\subsection[Free-var info]{Free variable information} -%* * -%************************************************************************ -\begin{code} +-- --------------------------------------------------------------------------- +-- Free variable information +-- --------------------------------------------------------------------------- + type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo) -- The Var is so we can gather up the free variables -- as a set. @@ -1049,9 +1070,7 @@ type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo) -- -- For ILX we track free var info for type variables too; -- hence VarEnv not IdEnv -\end{code} -\begin{code} emptyFVInfo :: FreeVarsInfo emptyFVInfo = emptyVarEnv @@ -1105,7 +1124,7 @@ plusFVInfo :: (Var, HowBound, StgBinderInfo) -> (Var, HowBound, StgBinderInfo) -> (Var, HowBound, StgBinderInfo) plusFVInfo (id1,hb1,info1) (id2,hb2,info2) - = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2) + = ASSERT(id1 == id2 && hb1 `check_eq_how_bound` hb2) (id1, hb1, combineStgBinderInfo info1 info2) -- The HowBound info for a variable in the FVInfo should be consistent @@ -1119,16 +1138,12 @@ check_eq_li :: LetInfo -> LetInfo -> Bool check_eq_li (NestedLet _) (NestedLet _) = True check_eq_li TopLet TopLet = True check_eq_li _ _ = False -\end{code} -Misc. -\begin{code} +-- Misc. + filterStgBinders :: [Var] -> [Var] filterStgBinders bndrs = filter isId bndrs -\end{code} - -\begin{code} myCollectBinders :: Expr Var -> ([Var], Expr Var) myCollectBinders expr = go [] expr @@ -1154,14 +1169,13 @@ myCollectArgs expr go (Lam b e) as | isTyVar b = go e as -- Note [Collect args] go _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr) -\end{code} -Note [Collect args] -~~~~~~~~~~~~~~~~~~~ -This big-lambda case occurred following a rather obscure eta expansion. -It all seems a bit yukky to me. +-- Note [Collect args] +-- ~~~~~~~~~~~~~~~~~~~ +-- +-- This big-lambda case occurred following a rather obscure eta expansion. +-- It all seems a bit yukky to me. -\begin{code} stgArity :: Id -> HowBound -> Arity stgArity _ (LetBound _ arity) = arity stgArity f ImportBound = idArity f diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs index fe8b1fc975..3fa8c68c16 100644 --- a/compiler/stgSyn/StgSyn.lhs +++ b/compiler/stgSyn/StgSyn.lhs @@ -103,17 +103,17 @@ data GenStgArg occ -- | Does this constructor application refer to -- anything in a different *Windows* DLL? -- If so, we can't allocate it statically -isDllConApp :: DynFlags -> DataCon -> [StgArg] -> Bool -isDllConApp dflags con args +isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool +isDllConApp dflags this_mod con args | platformOS (targetPlatform dflags) == OSMinGW32 - = isDllName dflags this_pkg (dataConName con) || any is_dll_arg args + = isDllName dflags this_pkg this_mod (dataConName con) || any is_dll_arg args | otherwise = False where -- NB: typePrimRep is legit because any free variables won't have -- unlifted type (there are no unlifted things at top level) is_dll_arg :: StgArg -> Bool is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep (idType v)) - && isDllName dflags this_pkg (idName v) + && isDllName dflags this_pkg this_mod (idName v) is_dll_arg _ = False this_pkg = thisPackage dflags diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 0eca72fa00..0aff8ffd93 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -23,17 +23,16 @@ import VarEnv import BasicTypes import FastString import Data.List -import DataCon ( dataConTyCon, dataConRepStrictness, isMarkedStrict ) +import DataCon import Id -import CoreUtils ( exprIsHNF, exprIsTrivial ) -import PprCore -import UniqFM ( filterUFM ) +import CoreUtils ( exprIsHNF, exprType, exprIsTrivial ) +-- import PprCore import TyCon -import Pair -import Type ( eqType, tyConAppTyCon_maybe ) -import Coercion ( coercionKind ) +import Type ( eqType ) +-- import Pair +-- import Coercion ( coercionKind ) import Util -import Maybes ( orElse ) +import Maybes ( isJust, orElse ) import TysWiredIn ( unboxedPairDataCon ) import TysPrim ( realWorldStatePrimTy ) \end{code} @@ -45,7 +44,6 @@ import TysPrim ( realWorldStatePrimTy ) %************************************************************************ \begin{code} - dmdAnalProgram :: DynFlags -> CoreProgram -> IO CoreProgram dmdAnalProgram dflags binds = do { @@ -54,29 +52,27 @@ dmdAnalProgram dflags binds } where do_prog :: CoreProgram -> CoreProgram - do_prog binds = snd $ mapAccumL (dmdAnalTopBind dflags) emptySigEnv binds + do_prog binds = snd $ mapAccumL dmdAnalTopBind (emptyAnalEnv dflags) binds -- Analyse a (group of) top-level binding(s) -dmdAnalTopBind :: DynFlags - -> SigEnv +dmdAnalTopBind :: AnalEnv -> CoreBind - -> (SigEnv, CoreBind) -dmdAnalTopBind dflags sigs (NonRec id rhs) - = (sigs2, NonRec id2 rhs2) + -> (AnalEnv, CoreBind) +dmdAnalTopBind sigs (NonRec id rhs) + = (extendAnalEnv TopLevel sigs id sig, NonRec id2 rhs2) where - ( _, _, (_, rhs1)) = dmdAnalRhs dflags TopLevel NonRecursive (virgin sigs) (id, rhs) - (sigs2, _, (id2, rhs2)) = dmdAnalRhs dflags TopLevel NonRecursive (nonVirgin sigs) (id, rhs1) + ( _, _, _, rhs1) = dmdAnalRhs TopLevel Nothing sigs id rhs + (sig, _, id2, rhs2) = dmdAnalRhs TopLevel Nothing (nonVirgin sigs) id rhs1 -- Do two passes to improve CPR information -- See comments with ignore_cpr_info in mk_sig_ty -- and with extendSigsWithLam -dmdAnalTopBind dflags sigs (Rec pairs) +dmdAnalTopBind sigs (Rec pairs) = (sigs', Rec pairs') where - (sigs', _, pairs') = dmdFix dflags TopLevel (virgin sigs) pairs + (sigs', _, pairs') = dmdFix TopLevel sigs pairs -- We get two iterations automatically -- c.f. the NonRec case above - \end{code} %************************************************************************ @@ -101,90 +97,78 @@ c) The application rule wouldn't be right either Evaluating (f x) in a L demand does *not* cause evaluation of f in a C(L) demand! -Note [Always analyse in virgin pass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tricky point: make sure that we analyse in the 'virgin' pass. Consider - rec { f acc x True = f (...rec { g y = ...g... }...) - f acc x False = acc } -In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type. -That might mean that we analyse the sub-expression containing the -E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse* -E, but just retuned botType. - -Then in the *next* (non-virgin) iteration for 'f', we might analyse E -in a weaker demand, and that will trigger doing a fixpoint iteration -for g. But *because it's not the virgin pass* we won't start g's -iteration at bottom. Disaster. (This happened in $sfibToList' of -nofib/spectral/fibheaps.) - -So in the virgin pass we make sure that we do analyse the expression -at least once, to initialise its signatures. - \begin{code} -evalDmdAnal :: DynFlags -> AnalEnv -> CoreExpr -> (DmdType, CoreExpr) --- See Note [Ensure demand is strict] -evalDmdAnal dflags env e - | (res_ty, e') <- dmdAnal dflags env evalDmd e - = (deferType res_ty, e') - -simpleDmdAnal :: DynFlags -> AnalEnv -> DmdType -> CoreExpr -> (DmdType, CoreExpr) -simpleDmdAnal dflags env res_ty e - | ae_virgin env -- See Note [Always analyse in virgin pass] - , (_discarded_res_ty, e') <- dmdAnal dflags env evalDmd e - = (res_ty, e') - | otherwise - = (res_ty, e) - -dmdAnal :: DynFlags -> AnalEnv -> Demand -> CoreExpr -> (DmdType, CoreExpr) -dmdAnal dflags env dmd e - | isBotDmd dmd = simpleDmdAnal dflags env botDmdType e - | isAbsDmd dmd = simpleDmdAnal dflags env topDmdType e - | not (isStrictDmd dmd) = evalDmdAnal dflags env e - -dmdAnal _ _ _ (Lit lit) = (topDmdType, Lit lit) -dmdAnal _ _ _ (Type ty) = (topDmdType, Type ty) -- Doesn't happen, in fact -dmdAnal _ _ _ (Coercion co) = (topDmdType, Coercion co) - -dmdAnal _ env dmd (Var var) +dmdAnalThunk :: AnalEnv + -> Demand -- This one takes a *Demand* + -> CoreExpr -> (DmdType, CoreExpr) +dmdAnalThunk env dmd e + | exprIsTrivial e = dmdAnalStar env dmd e + | otherwise = dmdAnalStar env (oneifyDmd dmd) e + +-- Do not process absent demands +-- Otherwise act like in a normal demand analysis +-- See |-* relation in the companion paper +dmdAnalStar :: AnalEnv + -> Demand -- This one takes a *Demand* + -> CoreExpr -> (DmdType, CoreExpr) +dmdAnalStar env dmd e = toCleanDmd (dmdAnal env) dmd e + +-- Main Demand Analsysis machinery +dmdAnal :: AnalEnv + -> CleanDemand -- The main one takes a *CleanDemand* + -> CoreExpr -> (DmdType, CoreExpr) + +-- The CleanDemand is always strict and not absent +-- See Note [Ensure demand is strict] + +dmdAnal _ _ (Lit lit) = (topDmdType, Lit lit) +dmdAnal _ _ (Type ty) = (topDmdType, Type ty) -- Doesn't happen, in fact +dmdAnal _ _ (Coercion co) = (topDmdType, Coercion co) + +dmdAnal env dmd (Var var) = (dmdTransform env var dmd, Var var) -dmdAnal dflags env dmd (Cast e co) +dmdAnal env dmd (Cast e co) = (dmd_ty, Cast e' co) where - (dmd_ty, e') = dmdAnal dflags env dmd' e + (dmd_ty, e') = dmdAnal env dmd e + +{- ----- I don't get this, so commenting out ------- to_co = pSnd (coercionKind co) dmd' | Just tc <- tyConAppTyCon_maybe to_co - , isRecursiveTyCon tc = evalDmd + , isRecursiveTyCon tc = cleanEvalDmd | otherwise = dmd -- This coerce usually arises from a recursive -- newtype, and we don't want to look inside them -- for exactly the same reason that we don't look -- inside recursive products -- we might not reach -- a fixpoint. So revert to a vanilla Eval demand +-} -dmdAnal dflags env dmd (Tick t e) +dmdAnal env dmd (Tick t e) = (dmd_ty, Tick t e') where - (dmd_ty, e') = dmdAnal dflags env dmd e + (dmd_ty, e') = dmdAnal env dmd e -dmdAnal dflags env dmd (App fun (Type ty)) +dmdAnal env dmd (App fun (Type ty)) = (fun_ty, App fun' (Type ty)) where - (fun_ty, fun') = dmdAnal dflags env dmd fun + (fun_ty, fun') = dmdAnal env dmd fun -dmdAnal dflags sigs dmd (App fun (Coercion co)) +dmdAnal sigs dmd (App fun (Coercion co)) = (fun_ty, App fun' (Coercion co)) where - (fun_ty, fun') = dmdAnal dflags sigs dmd fun + (fun_ty, fun') = dmdAnal sigs dmd fun -- Lots of the other code is there to make this -- beautiful, compositional, application rule :-) -dmdAnal dflags env dmd (App fun arg) -- Non-type arguments - = let -- [Type arg handled above] - (fun_ty, fun') = dmdAnal dflags env (mkCallDmd dmd) fun - (arg_ty, arg') = dmdAnal dflags env arg_dmd arg +dmdAnal env dmd (App fun arg) -- Non-type arguments + = let -- [Type arg handled above] + call_dmd = mkCallDmd dmd + (fun_ty, fun') = dmdAnal env call_dmd fun (arg_dmd, res_ty) = splitDmdTy fun_ty + (arg_ty, arg') = dmdAnalThunk env arg_dmd arg in -- pprTrace "dmdAnal:app" (vcat -- [ text "dmd =" <+> ppr dmd @@ -196,37 +180,35 @@ dmdAnal dflags env dmd (App fun arg) -- Non-type arguments -- , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ]) (res_ty `bothDmdType` arg_ty, App fun' arg') -dmdAnal dflags env dmd (Lam var body) +dmdAnal env dmd (Lam var body) | isTyVar var - = let - (body_ty, body') = dmdAnal dflags env dmd body + = let + (body_ty, body') = dmdAnal env dmd body in (body_ty, Lam var body') - | Just body_dmd <- peelCallDmd dmd -- A call demand: good! - = let - env' = extendSigsWithLam env var - (body_ty, body') = dmdAnal dflags env' body_dmd body - (lam_ty, var') = annotateLamIdBndr dflags env body_ty var - in - (lam_ty, Lam var' body') + | otherwise + = let (body_dmd, defer_me, one_shot) = peelCallDmd dmd + -- body_dmd - a demand to analyze the body + -- one_shot - one-shotness of the lambda + -- hence, cardinality of its free vars - | otherwise -- Not enough demand on the lambda; but do the body - = let -- anyway to annotate it and gather free var info - (body_ty, body') = dmdAnal dflags env evalDmd body - (lam_ty, var') = annotateLamIdBndr dflags env body_ty var + env' = extendSigsWithLam env var + (body_ty, body') = dmdAnal env' body_dmd body + (lam_ty, var') = annotateLamIdBndr env body_ty one_shot var in - (deferType lam_ty, Lam var' body') + (deferAndUse defer_me one_shot lam_ty, Lam var' body') -dmdAnal dflags env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)]) +dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)]) -- Only one alternative with a product constructor | let tycon = dataConTyCon dc , isProductTyCon tycon - , not (isRecursiveTyCon tycon) + , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon = let - env_alt = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig - (alt_ty, alt') = dmdAnalAlt dflags env_alt dmd alt - (alt_ty1, case_bndr') = annotateBndr alt_ty case_bndr + env_w_tc = env { ae_rec_tc = rec_tc' } + env_alt = extendAnalEnv NotTopLevel env_w_tc case_bndr case_bndr_sig + (alt_ty, alt') = dmdAnalAlt env_alt dmd alt + (alt_ty1, case_bndr') = annotateBndr env alt_ty case_bndr (_, bndrs', _) = alt' case_bndr_sig = cprProdSig -- Inside the alternative, the case binder has the CPR property. @@ -258,17 +240,16 @@ dmdAnal dflags env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)]) -- The above code would compute a Keep for x, since y is not Abs, which is silly -- The insight is, of course, that a demand on y is a demand on the -- scrutinee, so we need to `both` it with the scrut demand + + scrut_dmd1 = mkProdDmd [idDemandInfo b | b <- bndrs', isId b] + scrut_dmd2 = strictenDmd (idDemandInfo case_bndr') + scrut_dmd = scrut_dmd1 `bothCleanDmd` scrut_dmd2 - alt_dmd = mkProdDmd [idDemandInfo b | b <- bndrs', isId b] - scrut_dmd = alt_dmd `bothDmd` - idDemandInfo case_bndr' - - (scrut_ty, scrut') = dmdAnal dflags env scrut_dmd scrut + (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut res_ty = alt_ty1 `bothDmdType` scrut_ty in -- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut -- , text "dmd" <+> ppr dmd --- , text "alt_dmd" <+> ppr alt_dmd -- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr') -- , text "scrut_dmd" <+> ppr scrut_dmd -- , text "scrut_ty" <+> ppr scrut_ty @@ -276,26 +257,32 @@ dmdAnal dflags env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)]) -- , text "res_ty" <+> ppr res_ty ]) $ (res_ty, Case scrut' case_bndr' ty [alt']) -dmdAnal dflags env dmd (Case scrut case_bndr ty alts) +dmdAnal env dmd (Case scrut case_bndr ty alts) = let -- Case expression with multiple alternatives - (alt_tys, alts') = mapAndUnzip (dmdAnalAlt dflags env dmd) alts - (scrut_ty, scrut') = dmdAnal dflags env evalDmd scrut - (alt_ty, case_bndr') = annotateBndr (foldr lubDmdType botDmdType alt_tys) case_bndr - res_ty = alt_ty `bothDmdType` scrut_ty + (alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd) alts + (scrut_ty, scrut') = dmdAnal env cleanEvalDmd scrut + (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr + res_ty = alt_ty `bothDmdType` scrut_ty in -- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut -- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_tys" <+> ppr alt_tys -- , text "alt_ty" <+> ppr alt_ty -- , text "res_ty" <+> ppr res_ty ]) $ (res_ty, Case scrut' case_bndr' ty alts') -dmdAnal dflags env dmd (Let (NonRec id rhs) body) - = let - (sigs', lazy_fv, (id1, rhs')) = dmdAnalRhs dflags NotTopLevel NonRecursive env (id, rhs) - (body_ty, body') = dmdAnal dflags (updSigEnv env sigs') dmd body - (body_ty1, id2) = annotateBndr body_ty id1 - body_ty2 = addLazyFVs body_ty1 lazy_fv - in +dmdAnal env dmd (Let (NonRec id rhs) body) + = (body_ty2, Let (NonRec id2 annotated_rhs) body') + where + (sig, lazy_fv, id1, rhs') = dmdAnalRhs NotTopLevel Nothing env id rhs + (body_ty, body') = dmdAnal (extendAnalEnv NotTopLevel env id sig) dmd body + (body_ty1, id2) = annotateBndr env body_ty id1 + body_ty2 = addLazyFVs body_ty1 lazy_fv + + -- Annotate top-level lambdas at RHS basing on the aggregated demand info + -- See Note [Annotating lambdas at right-hand side] + annotated_rhs = annLamWithShotness (idDemandInfo id2) rhs' + -- If the actual demand is better than the vanilla call -- demand, you might think that we might do better to re-analyse -- the RHS with the stronger demand. @@ -308,32 +295,42 @@ dmdAnal dflags env dmd (Let (NonRec id rhs) body) -- In practice, all the times the actual demand on id2 is more than -- the vanilla call demand seem to be due to (b). So we don't -- bother to re-analyse the RHS. - (body_ty2, Let (NonRec id2 rhs') body') -dmdAnal dflags env dmd (Let (Rec pairs) body) +dmdAnal env dmd (Let (Rec pairs) body) = let - bndrs = map fst pairs - (sigs', lazy_fv, pairs') = dmdFix dflags NotTopLevel env pairs - (body_ty, body') = dmdAnal dflags (updSigEnv env sigs') dmd body - body_ty1 = addLazyFVs body_ty lazy_fv - in - sigs' `seq` body_ty `seq` - let - (body_ty2, _) = annotateBndrs body_ty1 bndrs - -- Don't bother to add demand info to recursive - -- binders as annotateBndr does; - -- being recursive, we can't treat them strictly. - -- But we do need to remove the binders from the result demand env + (env', lazy_fv, pairs') = dmdFix NotTopLevel env pairs + (body_ty, body') = dmdAnal env' dmd body + body_ty1 = deleteFVs body_ty (map fst pairs) + body_ty2 = addLazyFVs body_ty1 lazy_fv in + body_ty2 `seq` (body_ty2, Let (Rec pairs') body') +annLamWithShotness :: Demand -> CoreExpr -> CoreExpr +annLamWithShotness d e + | Just u <- cleanUseDmd_maybe d + = go u e + | otherwise = e + where + go u e + | Just (c, u') <- peelUseCall u + , Lam bndr body <- e + = if isTyVar bndr + then Lam bndr (go u body) + else Lam (setOneShotness c bndr) (go u' body) + | otherwise + = e + +setOneShotness :: Count -> Id -> Id +setOneShotness One bndr = setOneShotLambda bndr +setOneShotness Many bndr = bndr -dmdAnalAlt :: DynFlags -> AnalEnv -> Demand -> Alt Var -> (DmdType, Alt Var) -dmdAnalAlt dflags env dmd (con,bndrs,rhs) +dmdAnalAlt :: AnalEnv -> CleanDemand -> Alt Var -> (DmdType, Alt Var) +dmdAnalAlt env dmd (con,bndrs,rhs) = let - (rhs_ty, rhs') = dmdAnal dflags env dmd rhs + (rhs_ty, rhs') = dmdAnal env dmd rhs rhs_ty' = addDataConPatDmds con bndrs rhs_ty - (alt_ty, bndrs') = annotateBndrs rhs_ty' bndrs + (alt_ty, bndrs') = annotateBndrs env rhs_ty' bndrs final_alt_ty | io_hack_reqd = alt_ty `lubDmdType` topDmdType | otherwise = alt_ty @@ -358,7 +355,66 @@ dmdAnalAlt dflags env dmd (con,bndrs,rhs) idType (head bndrs) `eqType` realWorldStatePrimTy in (final_alt_ty, (con, bndrs', rhs')) +\end{code} +Note [Aggregated demand for cardinality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use different strategies for strictness and usage/cardinality to +"unleash" demands captured on free variables by bindings. Let us +consider the example: + +f1 y = let {-# NOINLINE h #-} + h = y + in (h, h) + +We are interested in obtaining cardinality demand U1 on |y|, as it is +used only in a thunk, and, therefore, is not going to be updated any +more. Therefore, the demand on |y|, captured and unleashed by usage of +|h| is U1. However, if we unleash this demand every time |h| is used, +and then sum up the effects, the ultimate demand on |y| will be U1 + +U1 = U. In order to avoid it, we *first* collect the aggregate demand +on |h| in the body of let-expression, and only then apply the demand +transformer: + +transf[x](U) = {y |-> U1} + +so the resulting demand on |y| is U1. + +The situation is, however, different for strictness, where this +aggregating approach exhibits worse results because of the nature of +|both| operation for strictness. Consider the example: + +f y c = + let h x = y |seq| x + in case of + True -> h True + False -> y + +It is clear that |f| is strict in |y|, however, the suggested analysis +will infer from the body of |let| that |h| is used lazily (as it is +used in one branch only), therefore lazy demand will be put on its +free variable |y|. Conversely, if the demand on |h| is unleashed right +on the spot, we will get the desired result, namely, that |f| is +strict in |y|. + +Note [Annotating lambdas at right-hand side] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Let us take a look at the following example: + +g f = let x = 100 + h = \y -> f x y + in h 5 + +One can see that |h| is called just once, therefore the RHS of h can +be annotated as a one-shot lambda. This is done by the function +annLamWithShotness *a posteriori*, i.e., basing on the aggregated +usage demand on |h| from the body of |let|-expression, which is C1(U) +in this case. + +In other words, for locally-bound lambdas we can infer +one-shotness. + +\begin{code} addDataConPatDmds :: AltCon -> [Var] -> DmdType -> DmdType -- See Note [Add demands for strict constructors] addDataConPatDmds DEFAULT _ dmd_ty = dmd_ty @@ -366,14 +422,45 @@ addDataConPatDmds (LitAlt _) _ dmd_ty = dmd_ty addDataConPatDmds (DataAlt con) bndrs dmd_ty = foldr add dmd_ty str_bndrs where - add bndr dmd_ty = addVarDmd dmd_ty bndr absDmd + add bndr dmd_ty = addVarDmd dmd_ty bndr seqDmd str_bndrs = [ b | (b,s) <- zipEqual "addDataConPatBndrs" (filter isId bndrs) (dataConRepStrictness con) , isMarkedStrict s ] - \end{code} +Note [Add demands for strict constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this program (due to Roman): + + data X a = X !a + + foo :: X Int -> Int -> Int + foo (X a) n = go 0 + where + go i | i < n = a + go (i+1) + | otherwise = 0 + +We want the worker for 'foo' too look like this: + + $wfoo :: Int# -> Int# -> Int# + +with the first argument unboxed, so that it is not eval'd each time +around the loop (which would otherwise happen, since 'foo' is not +strict in 'a'. It is sound for the wrapper to pass an unboxed arg +because X is strict, so its argument must be evaluated. And if we +*don't* pass an unboxed argument, we can't even repair it by adding a +`seq` thus: + + foo (X a) n = a `seq` go 0 + +because the seq is discarded (very early) since X is strict! + +There is the usual danger of reboxing, which as usual we ignore. But +if X is monomorphic, and has an UNPACK pragma, then this optimisation +is even more important. We don't want the wrapper to rebox an unboxed +argument, and pass an Int to $wfoo! + %************************************************************************ %* * Demand transformer @@ -383,7 +470,7 @@ addDataConPatDmds (DataAlt con) bndrs dmd_ty \begin{code} dmdTransform :: AnalEnv -- The strictness environment -> Id -- The function - -> Demand -- The demand on the function + -> CleanDemand -- The demand on the function -> DmdType -- The demand type of the function in this context -- Returned DmdEnv includes the demand on -- this function plus demand on its free variables @@ -394,16 +481,19 @@ dmdTransform env var dmd (idArity var) (idStrictness var) dmd | isGlobalId var -- Imported function - = dmdTransformSig (idStrictness var) dmd + = let res = dmdTransformSig (idStrictness var) dmd in +-- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res]) + res | Just (sig, top_lvl) <- lookupSigEnv env var -- Local letrec bound thing , let fn_ty = dmdTransformSig sig dmd - = if isTopLevel top_lvl - then fn_ty -- Don't record top level things - else addVarDmd fn_ty var dmd + = -- pprTrace "dmdTransform" (vcat [ppr var, ppr dmd, ppr fn_ty]) $ + if isTopLevel top_lvl + then fn_ty -- Don't record top level things + else addVarDmd fn_ty var (mkOnceUsedDmd dmd) | otherwise -- Local non-letrec-bound thing - = unitVarDmd var dmd + = unitVarDmd var (mkOnceUsedDmd dmd) \end{code} %************************************************************************ @@ -415,42 +505,44 @@ dmdTransform env var dmd \begin{code} -- Recursive bindings -dmdFix :: DynFlags - -> TopLevelFlag +dmdFix :: TopLevelFlag -> AnalEnv -- Does not include bindings for this binding -> [(Id,CoreExpr)] - -> (SigEnv, DmdEnv, + -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info -dmdFix dflags top_lvl env orig_pairs - = loop 1 initial_env orig_pairs +dmdFix top_lvl env orig_pairs + = (updSigEnv env (sigEnv final_env), lazy_fv, pairs') + -- Return to original virgin state, keeping new signatures where bndrs = map fst orig_pairs initial_env = addInitialSigs top_lvl env bndrs + (final_env, lazy_fv, pairs') = loop 1 initial_env orig_pairs loop :: Int -> AnalEnv -- Already contains the current sigs -> [(Id,CoreExpr)] - -> (SigEnv, DmdEnv, [(Id,CoreExpr)]) + -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) loop n env pairs = -- pprTrace "dmd loop" (ppr n <+> ppr bndrs $$ ppr env) $ loop' n env pairs loop' n env pairs | found_fixpoint - = (sigs', lazy_fv, pairs') + = (env', lazy_fv, pairs') -- Note: return pairs', not pairs. pairs' is the result of -- processing the RHSs with sigs (= sigs'), whereas pairs -- is the result of processing the RHSs with the *previous* -- iteration of sigs. - | n >= 10 - = pprTrace "dmdFix loop" (ppr n <+> (vcat - [ text "Sigs:" <+> ppr [ (id,lookupVarEnv sigs id, lookupVarEnv sigs' id) - | (id,_) <- pairs], - text "env:" <+> ppr env, - text "binds:" <+> pprCoreBinding (Rec pairs)])) - (sigEnv env, lazy_fv, orig_pairs) -- Safe output + | n >= 10 + = -- pprTrace "dmdFix loop" (ppr n <+> (vcat + -- [ text "Sigs:" <+> ppr [ (id,lookupVarEnv (sigEnv env) id, + -- lookupVarEnv (sigEnv env') id) + -- | (id,_) <- pairs], + -- text "env:" <+> ppr env, + -- text "binds:" <+> pprCoreBinding (Rec pairs)])) + (env, lazy_fv, orig_pairs) -- Safe output -- The lazy_fv part is really important! orig_pairs has no strictness -- info, including nothing about free vars. But if we have -- letrec f = ....y..... in ...f... @@ -458,21 +550,21 @@ dmdFix dflags top_lvl env orig_pairs -- otherwise y will get recorded as absent altogether | otherwise - = loop (n+1) (nonVirgin sigs') pairs' + = loop (n+1) (nonVirgin env') pairs' where - sigs = sigEnv env - found_fixpoint = all (same_sig sigs sigs') bndrs + found_fixpoint = all (same_sig (sigEnv env) (sigEnv env')) bndrs - ((sigs',lazy_fv), pairs') = mapAccumL my_downRhs (sigs, emptyDmdEnv) pairs + ((env',lazy_fv), pairs') = mapAccumL my_downRhs (env, emptyDmdEnv) pairs -- mapAccumL: Use the new signature to do the next pair -- The occurrence analyser has arranged them in a good order -- so this can significantly reduce the number of iterations needed - my_downRhs (sigs,lazy_fv) (id,rhs) - = ((sigs', lazy_fv'), pair') + my_downRhs (env, lazy_fv) (id,rhs) + = ((env', lazy_fv'), (id', rhs')) where - (sigs', lazy_fv1, pair') = dmdAnalRhs dflags top_lvl Recursive (updSigEnv env sigs) (id,rhs) - lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1 + (sig, lazy_fv1, id', rhs') = dmdAnalRhs top_lvl (Just bndrs) env id rhs + lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1 + env' = extendAnalEnv top_lvl env id sig same_sig sigs sigs' var = lookup sigs var == lookup sigs' var lookup sigs var = case lookupVarEnv sigs var of @@ -480,26 +572,104 @@ dmdFix dflags top_lvl env orig_pairs Nothing -> pprPanic "dmdFix" (ppr var) -- Non-recursive bindings -dmdAnalRhs :: DynFlags -> TopLevelFlag -> RecFlag - -> AnalEnv -> (Id, CoreExpr) - -> (SigEnv, DmdEnv, (Id, CoreExpr)) +dmdAnalRhs :: TopLevelFlag + -> Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive + -> AnalEnv -> Id -> CoreExpr + -> (StrictSig, DmdEnv, Id, CoreExpr) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. -dmdAnalRhs dflags top_lvl rec_flag env (id, rhs) - = (sigs', lazy_fv, (id', rhs')) - where - arity = idArity id -- The idArity should be up to date - -- The simplifier was run just beforehand - (rhs_dmd_ty, rhs') = dmdAnal dflags env (vanillaCall arity) rhs - (lazy_fv, sig_ty) = WARN( arity /= dmdTypeDepth rhs_dmd_ty && not (exprIsTrivial rhs), ppr id ) - -- The RHS can be eta-reduced to just a variable, - -- in which case we should not complain. - mkSigTy top_lvl rec_flag env id rhs rhs_dmd_ty - id' = id `setIdStrictness` sig_ty - sigs' = extendSigEnv top_lvl (sigEnv env) id sig_ty +dmdAnalRhs top_lvl rec_flag env id rhs + | Just fn <- unpackTrivial rhs -- See Note [Trivial right-hand sides] + , let fn_str = getStrictness env fn + = (fn_str, emptyDmdEnv, set_idStrictness env id fn_str, rhs) + | otherwise + = (sig_ty, lazy_fv, id', mkLams bndrs' body') + where + (bndrs, body) = collectBinders rhs + env_body = foldl extendSigsWithLam env bndrs + (body_dmd_ty, body') = dmdAnal env_body body_dmd body + (rhs_dmd_ty, bndrs') = annotateLamBndrs env body_dmd_ty bndrs + id' = set_idStrictness env id sig_ty + sig_ty = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res') + -- See Note [NOINLINE and strictness] + + -- See Note [Product demands for function body] + body_dmd = case deepSplitProductType_maybe (exprType body) of + Nothing -> cleanEvalDmd + Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc) + + DmdType rhs_fv rhs_dmds rhs_res = rhs_dmd_ty + + -- See Note [Lazy and unleashable free variables] + -- See Note [Aggregated demand for cardinality] + rhs_fv1 = case rec_flag of + Just bs -> useEnv (delVarEnvList rhs_fv bs) + Nothing -> rhs_fv + + (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1 + + rhs_res' | returnsCPR rhs_res + , discard_cpr_info = topRes + | otherwise = rhs_res + + discard_cpr_info = nested_sum || (is_thunk && not_strict) + nested_sum -- See Note [CPR for sum types ] + = not (isTopLevel top_lvl || returnsCPRProd rhs_res) + + -- See Note [CPR for thunks] + is_thunk = not (exprIsHNF rhs) + not_strict + = isTopLevel top_lvl -- Top level and recursive things don't + || isJust rec_flag -- get their demandInfo set at all + || not (isStrictDmd (idDemandInfo id) || ae_virgin env) + -- See Note [Optimistic CPR in the "virgin" case] + +unpackTrivial :: CoreExpr -> Maybe Id +-- Returns (Just v) if the arg is really equal to v, modulo +-- casts, type applications etc +-- See Note [Trivial right-hand sides] +unpackTrivial (Var v) = Just v +unpackTrivial (Cast e _) = unpackTrivial e +unpackTrivial (Lam v e) | isTyVar v = unpackTrivial e +unpackTrivial (App e a) | isTypeArg a = unpackTrivial e +unpackTrivial _ = Nothing \end{code} +Note [Trivial right-hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + foo = plusInt |> co +where plusInt is an arity-2 function with known strictness. Clearly +we want plusInt's strictness to propagate to foo! But because it has +no manifest lambdas, it won't do so automatically. So we have a +special case for right-hand sides that are "trivial", namely variables, +casts, type applications, and the like. + +Note [Product demands for function body] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This example comes from shootout/binary_trees: + + Main.check' = \ b z ds. case z of z' { I# ip -> + case ds_d13s of + Main.Nil -> z' + Main.Node s14k s14l s14m -> + Main.check' (not b) + (Main.check' b + (case b { + False -> I# (-# s14h s14k); + True -> I# (+# s14h s14k) + }) + s14l) + s14m } } } + +Here we *really* want to unbox z, even though it appears to be used boxed in +the Nil case. Partly the Nil case is not a hot path. But more specifically, +the whole function gets the CPR property if we do. + +So for the demand on the body of a RHS we use a product demand if it's +a product type. + %************************************************************************ %* * \subsection{Strictness signatures and types} @@ -516,19 +686,17 @@ addVarDmd (DmdType fv ds res) var dmd = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res addLazyFVs :: DmdType -> DmdEnv -> DmdType -addLazyFVs (DmdType fv ds res) lazy_fvs - = DmdType both_fv1 ds res - where - both_fv = plusVarEnv_C bothDmd fv lazy_fvs - both_fv1 = modifyEnv (isBotRes res) (`bothDmd` botDmd) lazy_fvs fv both_fv - -- This modifyEnv is vital. Consider +addLazyFVs dmd_ty lazy_fvs + = dmd_ty `bothDmdType` mkDmdType lazy_fvs [] topRes + -- Using bothDmdType (rather than just both'ing the envs) + -- is vital. Consider -- let f = \x -> (x,y) -- in error (f 3) -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L -- demand with the bottom coming up from 'error' -- -- I got a loop in the fixpointer without this, due to an interaction - -- with the lazy_fv filtering in mkSigTy. Roughly, it was + -- with the lazy_fv filtering in dmdAnalRhs. Roughly, it was -- letrec f n x -- = letrec g y = x `fatbar` -- letrec h z = z + ...g... @@ -543,13 +711,9 @@ addLazyFVs (DmdType fv ds res) lazy_fvs -- which floats out of the defn for h. Without the modifyEnv, that -- L demand doesn't get both'd with the Bot coming up from the inner -- call to f. So we just get an L demand for x for g. - -- - -- A better way to say this is that the lazy-fv filtering should give the - -- same answer as putting the lazy fv demands in the function's type. - -removeFV :: DmdEnv -> Var -> DmdResult -> (DmdEnv, Demand) -removeFV fv id res = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) +peelFV :: DmdEnv -> Var -> DmdResult -> (DmdEnv, Demand) +peelFV fv id res = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) (fv', dmd) where fv' = fv `delVarEnv` id @@ -570,73 +734,55 @@ possible to safely ignore non-mentioned variables (their joint demand is <L,A>). \begin{code} -annotateBndr :: DmdType -> Var -> (DmdType, Var) +annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var) -- The returned env has the var deleted -- The returned var is annotated with demand info -- according to the result demand of the provided demand type -- No effect on the argument demands -annotateBndr dmd_ty@(DmdType fv ds res) var +annotateBndr env dmd_ty@(DmdType fv ds res) var | isTyVar var = (dmd_ty, var) - | otherwise = (DmdType fv' ds res, setIdDemandInfo var dmd) + | otherwise = (DmdType fv' ds res, set_idDemandInfo env var dmd) where - (fv', dmd) = removeFV fv var res + (fv', dmd) = peelFV fv var res -annotateBndrs :: DmdType -> [Var] -> (DmdType, [Var]) -annotateBndrs = mapAccumR annotateBndr +annotateBndrs :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Var]) +annotateBndrs env = mapAccumR (annotateBndr env) + +annotateLamBndrs :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Var]) +annotateLamBndrs env ty bndrs = mapAccumR annotate ty bndrs + where + annotate dmd_ty bndr + | isId bndr = annotateLamIdBndr env dmd_ty Many bndr + | otherwise = (dmd_ty, bndr) -annotateLamIdBndr :: DynFlags - -> AnalEnv +annotateLamIdBndr :: AnalEnv -> DmdType -- Demand type of body + -> Count -- One-shot-ness of the lambda -> Id -- Lambda binder -> (DmdType, -- Demand type of lambda Id) -- and binder annotated with demand -annotateLamIdBndr dflags env (DmdType fv ds res) id +annotateLamIdBndr env _dmd_ty@(DmdType fv ds res) one_shot id -- For lambdas we add the demand to the argument demands -- Only called for Ids = ASSERT( isId id ) - (final_ty, setIdDemandInfo id dmd) + -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $ + (final_ty, setOneShotness one_shot (set_idDemandInfo env id dmd)) where -- Watch out! See note [Lambda-bound unfoldings] final_ty = case maybeUnfoldingTemplate (idUnfolding id) of Nothing -> main_ty Just unf -> main_ty `bothDmdType` unf_ty where - (unf_ty, _) = dmdAnal dflags env dmd unf + (unf_ty, _) = dmdAnalStar env dmd unf main_ty = DmdType fv' (dmd:ds) res - (fv', dmd) = removeFV fv id res + (fv', dmd) = peelFV fv id res -mkSigTy :: TopLevelFlag -> RecFlag -> AnalEnv -> Id -> - CoreExpr -> DmdType -> (DmdEnv, StrictSig) -mkSigTy top_lvl rec_flag env id rhs (DmdType fv dmds res) - = (lazy_fv, mkStrictSig dmd_ty) - -- See Note [NOINLINE and strictness] - where - dmd_ty = mkDmdType strict_fv dmds res' - - -- See Note [Lazy and strict free variables] - lazy_fv = filterUFM (not . isStrictDmd) fv - strict_fv = filterUFM isStrictDmd fv - - ignore_cpr_info = not (exprIsHNF rhs || thunk_cpr_ok) - res' | returnsCPR res - , not (isTopLevel top_lvl || returnsCPRProd res) - -- See Note [CPR for sum types ] - || ignore_cpr_info = topRes - | otherwise = res - - -- Is it okay or not to assign CPR - -- (not okay in the first pass) - thunk_cpr_ok -- See Note [CPR for thunks] - | isTopLevel top_lvl = False -- Top level things don't get - -- their demandInfo set at all - | isRec rec_flag = False -- Ditto recursive things - | ae_virgin env = True -- Optimistic, first time round - -- See Note [Optimistic CPR in the "virgin" case] - | isStrictDmd (idDemandInfo id) = True - | otherwise = False +deleteFVs :: DmdType -> [Var] -> DmdType +deleteFVs (DmdType fvs dmds res) bndrs + = DmdType (delVarEnvList fvs bndrs) dmds res \end{code} Note [CPR for sum types] @@ -728,7 +874,6 @@ NB: strictly_demanded is never true of a top-level Id, or of a recursive Id. Note [Optimistic CPR in the "virgin" case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Demand and strictness info are initialized by top elements. However, this prevents from inferring a CPR property in the first pass of the analyser, so we keep an explicit flag ae_virgin in the AnalEnv @@ -789,10 +934,9 @@ strictness. For example, if you have a function implemented by an error stub, but which has RULES, you may want it not to be eliminated in favour of error! -Note [Lazy and strict free variables] +Note [Lazy and unleasheable free variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -We put the strict FVs in the DmdType of the Id, so +We put the strict and once-used FVs in the DmdType of the Id, so that at its call sites we unleash demands on its strict fvs. An example is 'roll' in imaginary/wheel-sieve2 Something like this: @@ -842,9 +986,13 @@ forget that fact, otherwise we might make 'x' absent when it isn't. \begin{code} data AnalEnv - = AE { ae_sigs :: SigEnv - , ae_virgin :: Bool } -- True on first iteration only + = AE { ae_dflags :: DynFlags + , ae_sigs :: SigEnv + , ae_virgin :: Bool -- True on first iteration only -- See Note [Initialising strictness] + , ae_rec_tc :: RecTcChecker + } + -- We use the se_env to tell us whether to -- record info about a variable in the DmdEnv -- We do so if it's a LocalId, but not top-level @@ -860,6 +1008,10 @@ instance Outputable AnalEnv where [ ptext (sLit "ae_virgin =") <+> ppr virgin , ptext (sLit "ae_sigs =") <+> ppr env ]) +emptyAnalEnv :: DynFlags -> AnalEnv +emptyAnalEnv dflags = AE { ae_dflags = dflags, ae_sigs = emptySigEnv + , ae_virgin = True, ae_rec_tc = initRecTc } + emptySigEnv :: SigEnv emptySigEnv = emptyVarEnv @@ -879,6 +1031,12 @@ extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl) lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag) lookupSigEnv env id = lookupVarEnv (ae_sigs env) id +getStrictness :: AnalEnv -> Id -> StrictSig +getStrictness env fn + | isGlobalId fn = idStrictness fn + | Just (sig, _) <- lookupSigEnv env fn = sig + | otherwise = topSig + addInitialSigs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv -- See Note [Initialising strictness] addInitialSigs top_lvl env@(AE { ae_sigs = sigs, ae_virgin = virgin }) ids @@ -888,22 +1046,29 @@ addInitialSigs top_lvl env@(AE { ae_sigs = sigs, ae_virgin = virgin }) ids init_sig | virgin = \_ -> botSig | otherwise = idStrictness -virgin, nonVirgin :: SigEnv -> AnalEnv -virgin sigs = AE { ae_sigs = sigs, ae_virgin = True } -nonVirgin sigs = AE { ae_sigs = sigs, ae_virgin = False } +nonVirgin :: AnalEnv -> AnalEnv +nonVirgin env = env { ae_virgin = False } extendSigsWithLam :: AnalEnv -> Id -> AnalEnv -- Extend the AnalEnv when we meet a lambda binder extendSigsWithLam env id - | isStrictDmd dmd_info || ae_virgin env + | isId id + , isStrictDmd (idDemandInfo id) || ae_virgin env -- See Note [Optimistic CPR in the "virgin" case] -- See Note [Initial CPR for strict binders] , Just {} <- deepSplitProductType_maybe $ idType id = extendAnalEnv NotTopLevel env id cprProdSig - | otherwise = env - where - dmd_info = idDemandInfo id + | otherwise + = env + +set_idDemandInfo :: AnalEnv -> Id -> Demand -> Id +set_idDemandInfo env id dmd + = setIdDemandInfo id (zapDemand (ae_dflags env) dmd) + +set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id +set_idStrictness env id sig + = setIdStrictness id (zapStrictSig (ae_dflags env) sig) \end{code} Note [Initial CPR for strict binders] diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index 810db2069b..ca64a7fbce 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -488,7 +488,7 @@ deepSplitProductType_maybe :: Type -> Maybe (DataCon, [Type], [Type], Coercion) -- If deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co) -- then dc @ tys (args::arg_tys) |> co :: ty deepSplitProductType_maybe ty - | let (ty1, co) = topNormaliseNewType ty `orElse` (ty, mkReflCo ty) + | let (ty1, co) = topNormaliseNewType ty `orElse` (ty, mkReflCo Representational ty) , Just (tc, tc_args) <- splitTyConApp_maybe ty1 , Just con <- isDataProductTyCon_maybe tc = Just (con, tc_args, dataConInstArgTys con tc_args, co) @@ -496,7 +496,7 @@ deepSplitProductType_maybe _ = Nothing deepSplitCprType_maybe :: ConTag -> Type -> Maybe (DataCon, [Type], [Type], Coercion) deepSplitCprType_maybe con_tag ty - | let (ty1, co) = topNormaliseNewType ty `orElse` (ty, mkReflCo ty) + | let (ty1, co) = topNormaliseNewType ty `orElse` (ty, mkReflCo Representational ty) , Just (tc, tc_args) <- splitTyConApp_maybe ty1 , isDataTyCon tc , let cons = tyConDataCons tc diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 2f81ca6088..3ca28ef203 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -11,7 +11,7 @@ The @FamInst@ type: family instance heads module FamInst ( checkFamInstConsistency, tcExtendLocalFamInstEnv, - tcLookupFamInst, tcLookupDataFamInst, + tcLookupFamInst, tcGetFamInstEnvs, newFamInst ) where @@ -35,6 +35,7 @@ import Maybes import TcMType import TcType import Name +import VarSet import Control.Monad import Data.Map (Map) import qualified Data.Map as Map @@ -53,34 +54,27 @@ import qualified Data.Map as Map -- creates the fresh variables and applies the necessary substitution -- It is defined here to avoid a dependency from FamInstEnv on the monad -- code. -newFamInst :: FamFlavor -> Bool -> CoAxiom br -> TcRnIf gbl lcl(FamInst br) + +newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcRnIf gbl lcl FamInst -- Freshen the type variables of the FamInst branches -- Called from the vectoriser monad too, hence the rather general type -newFamInst flavor is_group axiom@(CoAxiom { co_ax_tc = fam_tc - , co_ax_branches = ax_branches }) - = do { fam_branches <- go ax_branches - ; return (FamInst { fi_fam = tyConName fam_tc +newFamInst flavor axiom@(CoAxiom { co_ax_branches = FirstBranch branch + , co_ax_tc = fam_tc }) + = do { (subst, tvs') <- tcInstSkolTyVarsLoc loc tvs + ; return (FamInst { fi_fam = fam_tc_name , fi_flavor = flavor - , fi_branches = fam_branches - , fi_group = is_group + , fi_tcs = roughMatchTcs lhs + , fi_tvs = tvs' + , fi_tys = substTys subst lhs + , fi_rhs = substTy subst rhs , fi_axiom = axiom }) } where - go :: BranchList CoAxBranch br -> TcRnIf gbl lcl (BranchList FamInstBranch br) - go (FirstBranch br) = do { br' <- go_branch br - ; return (FirstBranch br') } - go (NextBranch br brs) = do { br' <- go_branch br - ; brs' <- go brs - ;return (NextBranch br' brs') } - go_branch :: CoAxBranch -> TcRnIf gbl lcl FamInstBranch - go_branch (CoAxBranch { cab_tvs = tvs1 - , cab_lhs = lhs - , cab_loc = loc - , cab_rhs = rhs }) - = do { (subst, tvs2) <- tcInstSkolTyVarsLoc loc tvs1 - ; return (FamInstBranch { fib_tvs = tvs2 - , fib_lhs = substTys subst lhs - , fib_rhs = substTy subst rhs - , fib_tcs = roughMatchTcs lhs }) } + fam_tc_name = tyConName fam_tc + CoAxBranch { cab_loc = loc + , cab_tvs = tvs + , cab_lhs = lhs + , cab_rhs = rhs } = branch + \end{code} @@ -218,68 +212,21 @@ which implies that :R42T was declared as 'data instance T [a]'. \begin{code} tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe FamInstMatch) tcLookupFamInst tycon tys - | not (isFamilyTyCon tycon) + | not (isOpenFamilyTyCon tycon) = return Nothing | otherwise = do { instEnv <- tcGetFamInstEnvs ; let mb_match = lookupFamInstEnv instEnv tycon tys --- ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ --- pprTvBndrs (varSetElems (tyVarsOfTypes tys)) $$ --- ppr mb_match $$ ppr instEnv) + ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ + pprTvBndrs (varSetElems (tyVarsOfTypes tys)) $$ + ppr mb_match $$ ppr instEnv) ; case mb_match of [] -> return Nothing (match:_) -> return $ Just match } - -tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type]) --- Find the instance of a data family --- Note [Looking up family instances for deriving] -tcLookupDataFamInst tycon tys - | not (isFamilyTyCon tycon) - = return (tycon, tys) - | otherwise - = ASSERT( isAlgTyCon tycon ) - do { maybeFamInst <- tcLookupFamInst tycon tys - ; case maybeFamInst of - Nothing -> famInstNotFound tycon tys - Just (FamInstMatch { fim_instance = famInst - , fim_index = index - , fim_tys = tys }) - -> ASSERT( index == 0 ) - let tycon' = dataFamInstRepTyCon famInst - in return (tycon', tys) } - -famInstNotFound :: TyCon -> [Type] -> TcM a -famInstNotFound tycon tys - = failWithTc (ptext (sLit "No family instance for") - <+> quotes (pprTypeApp tycon tys)) \end{code} -Note [Looking up family instances for deriving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcLookupFamInstExact is an auxiliary lookup wrapper which requires -that looked-up family instances exist. If called with a vanilla -tycon, the old type application is simply returned. - -If we have - data instance F () = ... deriving Eq - data instance F () = ... deriving Eq -then tcLookupFamInstExact will be confused by the two matches; -but that can't happen because tcInstDecls1 doesn't call tcDeriving -if there are any overlaps. - -There are two other things that might go wrong with the lookup. -First, we might see a standalone deriving clause - deriving Eq (F ()) -when there is no data instance F () in scope. - -Note that it's OK to have - data instance F [a] = ... - deriving Eq (F [(a,b)]) -where the match is not exact; the same holds for ordinary data types -with standalone deriving declrations. - %************************************************************************ %* * @@ -289,7 +236,7 @@ with standalone deriving declrations. \begin{code} -- Add new locally-defined family instances -tcExtendLocalFamInstEnv :: [FamInst br] -> TcM a -> TcM a +tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a tcExtendLocalFamInstEnv fam_insts thing_inside = do { env <- getGblEnv ; (inst_env', fam_insts') <- foldlM addLocalFamInst @@ -304,7 +251,7 @@ tcExtendLocalFamInstEnv fam_insts thing_inside -- and then add it to the home inst env -- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match] -- in FamInstEnv.lhs -addLocalFamInst :: (FamInstEnv,[FamInst Branched]) -> FamInst br -> TcM (FamInstEnv, [FamInst Branched]) +addLocalFamInst :: (FamInstEnv,[FamInst]) -> FamInst -> TcM (FamInstEnv, [FamInst]) addLocalFamInst (home_fie, my_fis) fam_inst -- home_fie includes home package and this module -- my_fies is just the ones from this module @@ -323,13 +270,12 @@ addLocalFamInst (home_fie, my_fis) fam_inst -- overlaps correctly ; eps <- getEps ; let inst_envs = (eps_fam_inst_env eps, home_fie') - fam_inst' = toBranchedFamInst fam_inst - home_fie'' = extendFamInstEnv home_fie fam_inst' + home_fie'' = extendFamInstEnv home_fie fam_inst -- Check for conflicting instance decls - ; no_conflict <- checkForConflicts inst_envs fam_inst' + ; no_conflict <- checkForConflicts inst_envs fam_inst ; if no_conflict then - return (home_fie'', fam_inst' : my_fis') + return (home_fie'', fam_inst : my_fis') else return (home_fie, my_fis) } @@ -345,39 +291,35 @@ Check whether a single family instance conflicts with those in two instance environments (one for the EPS and one for the HPT). \begin{code} -checkForConflicts :: FamInstEnvs -> FamInst Branched -> TcM Bool -checkForConflicts inst_envs fam_inst@(FamInst { fi_branches = branches - , fi_group = group }) - = do { let conflicts = brListMap (lookupFamInstEnvConflicts inst_envs group fam_tc) branches - no_conflicts = all null conflicts - ; traceTc "checkForConflicts" (ppr conflicts $$ ppr fam_inst $$ ppr inst_envs) - ; unless no_conflicts $ - zipWithM_ (conflictInstErr fam_inst) (brListIndices branches) conflicts +checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool +checkForConflicts inst_envs fam_inst + = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst + no_conflicts = null conflicts + ; traceTc "checkForConflicts" (ppr (map fim_instance conflicts) $$ + ppr fam_inst $$ ppr inst_envs) + ; unless no_conflicts $ conflictInstErr fam_inst conflicts ; return no_conflicts } - where fam_tc = famInstTyCon fam_inst -conflictInstErr :: FamInst Branched -> BranchIndex -> [FamInstMatch] -> TcRn () -conflictInstErr fam_inst branch conflictingMatch - | (FamInstMatch { fim_instance = confInst - , fim_index = confIndex }) : _ <- conflictingMatch +conflictInstErr :: FamInst -> [FamInstMatch] -> TcRn () +conflictInstErr fam_inst conflictingMatch + | (FamInstMatch { fim_instance = confInst }) : _ <- conflictingMatch = addFamInstsErr (ptext (sLit "Conflicting family instance declarations:")) - [(fam_inst, branch), - (confInst, confIndex) ] - | otherwise -- no conflict on this branch; see Trac #7560 - = return () + [fam_inst, confInst] + | otherwise + = panic "conflictInstErr" -addFamInstsErr :: SDoc -> [(FamInst Branched, Int)] -> TcRn () +addFamInstsErr :: SDoc -> [FamInst] -> TcRn () addFamInstsErr herald insts = ASSERT( not (null insts) ) setSrcSpan srcSpan $ addErr $ hang herald - 2 (vcat [ pprCoAxBranchHdr (famInstAxiom fi) index - | (fi,index) <- sorted ]) + 2 (vcat [ pprCoAxBranchHdr (famInstAxiom fi) 0 + | fi <- sorted ]) where - getSpan = getSrcLoc . famInstAxiom . fst + getSpan = getSrcLoc . famInstAxiom sorted = sortWith getSpan insts - (fi1,ix1) = head sorted - srcSpan = coAxBranchSpan (coAxiomNthBranch (famInstAxiom fi1) ix1) + fi1 = head sorted + srcSpan = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1)) -- The sortWith just arranges that instances are dislayed in order -- of source location, which reduced wobbling in error messages, -- and is better for users diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 3ced71334e..b8bef9e0b2 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -325,9 +325,10 @@ tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside ; return ( [(NonRecursive, binds1)], thing) } tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside - = -- To maximise polymorphism (assumes -XRelaxedPolyRec), we do a new + = -- To maximise polymorphism, we do a new -- strongly-connected-component analysis, this time omitting -- any references to variables with type signatures. + -- (This used to be optional, but isn't now.) do { traceTc "tc_group rec" (pprLHsBinds binds) ; (binds1, _ids, thing) <- go sccs -- Here is where we should do bindInstsOfLocalFuns @@ -511,6 +512,7 @@ tcPolyInfer top_lvl rec_tc prag_fn tc_sig_fn mono closed bind_list tcMonoBinds top_lvl rec_tc tc_sig_fn LetLclBndr bind_list ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos] + ; traceTc "simplifyInfer call" (ppr name_taus $$ ppr wanted) ; (qtvs, givens, mr_bites, ev_binds) <- simplifyInfer closed mono name_taus wanted @@ -557,9 +559,11 @@ mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id) -- In the inference case (no signature) this stuff figures out -- the right type variables and theta to quantify over -- See Note [Impedence matching] - my_tv_set = growThetaTyVars theta (tyVarsOfType mono_ty) - my_tvs = filter (`elemVarSet` my_tv_set) qtvs -- Maintain original order - my_theta = filter (quantifyPred my_tv_set) theta + my_tvs1 = growThetaTyVars theta (tyVarsOfType mono_ty) + my_tvs2 = foldVarSet (\tv tvs -> tyVarsOfType (tyVarKind tv) `unionVarSet` tvs) + my_tvs1 my_tvs1 -- Add kind variables! Trac #7916 + my_tvs = filter (`elemVarSet` my_tvs2) qtvs -- Maintain original order + my_theta = filter (quantifyPred my_tvs2) theta inferred_poly_ty = mkSigmaTy my_tvs my_theta mono_ty ; poly_id <- addInlinePrags poly_id prag_sigs @@ -1006,7 +1010,12 @@ type MonoBindInfo = (Name, Maybe TcSigInfo, TcId) tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches }) | Just sig <- sig_fn name - = do { mono_id <- newSigLetBndr no_gen name sig + = ASSERT2( case no_gen of { LetLclBndr -> True; LetGblBndr {} -> False } + , ppr name ) -- { f :: ty; f x = e } is always done via CheckGen + -- which gives rise to LetLclBndr. It wouldn't make + -- sense to have a *polymorphic* function Id at this point + do { mono_name <- newLocalName name + ; let mono_id = mkLocalId mono_name (sig_tau sig) ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) } | otherwise = do { mono_ty <- newFlexiTyVarTy openTypeKind @@ -1098,17 +1107,6 @@ However, we do *not* support this f :: forall a. a->a (f,g) = e - - For multiple function bindings, unless Opt_RelaxedPolyRec is on - f :: forall a. a -> a - f = g - g :: forall b. b -> b - g = ...f... - Reason: we use mutable variables for 'a' and 'b', since they may - unify to each other, and that means the scoped type variable would - not stand for a completely rigid variable. - - Currently, we simply make Opt_ScopedTypeVariables imply Opt_RelaxedPolyRec - Note [More instantiated than scoped] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There may be more instantiated type variables than lexically-scoped diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 15a7274943..c0c02fbcc0 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -27,7 +27,7 @@ import OccName( OccName ) import Outputable import Control.Monad ( when ) import TysWiredIn ( eqTyCon ) - +import DynFlags( DynFlags ) import VarSet import TcSMonad import FastString @@ -180,7 +180,7 @@ canonicalize (CTyEqCan { cc_loc = d , cc_tyvar = tv , cc_rhs = xi }) = {-# SCC "canEqLeafTyVarEq" #-} - canEqLeafTyVarEq d ev tv xi + canEqLeafTyVar d ev tv xi canonicalize (CFunEqCan { cc_loc = d , cc_ev = ev @@ -188,7 +188,7 @@ canonicalize (CFunEqCan { cc_loc = d , cc_tyargs = xis1 , cc_rhs = xi2 }) = {-# SCC "canEqLeafFunEq" #-} - canEqLeafFunEq d ev fn xis1 xi2 + canEqLeafFun d ev fn xis1 xi2 canonicalize (CIrredEvCan { cc_ev = ev , cc_loc = d }) @@ -544,20 +544,20 @@ flatten loc f ctxt (TyConApp tc tys) -- cache as well when we interact an equality with the inert. -- The design choice is: do we keep the flat cache rewritten or not? -- For now I say we don't keep it fully rewritten. - do { traceTcS "flatten/flat-cache hit" $ ppr ctev - ; (rhs_xi,co) <- flatten loc f flav rhs_ty + do { (rhs_xi,co) <- flatten loc f flav rhs_ty ; let final_co = evTermCoercion (ctEvTerm ctev) `mkTcTransCo` mkTcSymCo co + ; traceTcS "flatten/flat-cache hit" $ (ppr ctev $$ ppr rhs_xi $$ ppr final_co) ; return (final_co, rhs_xi) } - _ -> do { traceTcS "flatten/flat-cache miss" $ ppr fam_ty - ; (ctev, rhs_xi) <- newFlattenSkolem ctxt fam_ty + _ -> do { (ctev, rhs_xi) <- newFlattenSkolem ctxt fam_ty ; let ct = CFunEqCan { cc_ev = ctev , cc_fun = tc , cc_tyargs = xi_args , cc_rhs = rhs_xi , cc_loc = loc } ; updWorkListTcS $ extendWorkListFunEq ct + ; traceTcS "flatten/flat-cache miss" $ (ppr fam_ty $$ ppr rhs_xi $$ ppr ctev) ; return (evTermCoercion (ctEvTerm ctev), rhs_xi) } } -- Emit the flat constraints @@ -609,13 +609,15 @@ flattenTyVar loc f ctxt tv | otherwise = do { mb_ty <- isFilledMetaTyVar_maybe tv ; case mb_ty of { - Just ty -> flatten loc f ctxt ty ; + Just ty -> do { traceTcS "Following filled tyvar" (ppr tv <+> equals <+> ppr ty) + ; flatten loc f ctxt ty } ; Nothing -> -- Try in ty_binds do { ty_binds <- getTcSTyBindsMap ; case lookupVarEnv ty_binds tv of { - Just (_tv,ty) -> flatten loc f ctxt ty ; + Just (_tv,ty) -> do { traceTcS "Following bound tyvar" (ppr tv <+> equals <+> ppr ty) + ; flatten loc f ctxt ty } ; -- NB: ty_binds coercions are all ReflCo, -- so no need to transitively compose co' with another coercion, -- unlike in 'flatten_from_inerts' @@ -626,7 +628,8 @@ flattenTyVar loc f ctxt tv ; let mco = tv_eq_subst ieqs tv -- co : v ~ ty ; case mco of { Just (co,ty) -> - do { (ty_final,co') <- flatten loc f ctxt ty + do { traceTcS "Following inert tyvar" (ppr tv <+> equals <+> ppr ty) + ; (ty_final,co') <- flatten loc f ctxt ty ; return (ty_final, co' `mkTcTransCo` mkTcSymCo co) } ; -- NB recursive call. -- Why? Because inert subst. non-idempotent, Note [Detailed InertCans Invariants] @@ -1015,8 +1018,14 @@ reOrient (FunCls {}) _ = False -- Fun/Other on rhs reOrient (VarCls {}) (FunCls {}) = True reOrient (VarCls {}) (OtherCls {}) = False reOrient (VarCls tv1) (VarCls tv2) - | isMetaTyVar tv2 && not (isMetaTyVar tv1) = True - | otherwise = False + | not (k2 `isSubKind` k1), k1 `isSubKind` k2 = True -- Note [Kind orientation for CTyEqCan] + -- in TcRnTypes + | not (isMetaTyVar tv1), isMetaTyVar tv2 = True + | not (isFlatSkolTyVar tv1), isFlatSkolTyVar tv2 = True -- Note [Eliminate flat-skols] + | otherwise = False + where + k1 = tyVarKind tv1 + k2 = tyVarKind tv2 -- Just for efficiency, see CTyEqCan invariants ------------------ @@ -1059,18 +1068,14 @@ canEqLeaf loc ev s1 s2 canEqLeafOriented :: CtLoc -> CtEvidence -> TypeClassifier -> TcType -> TcS StopOrContinue -- By now s1 will either be a variable or a type family application --- Precondition: the LHS and RHS have `compatKind` kinds --- so we can safely generate a CTyEqCan or CFunEqCan -canEqLeafOriented loc ev (FunCls fn tys1) s2 = canEqLeafFunEq loc ev fn tys1 s2 -canEqLeafOriented loc ev (VarCls tv) s2 = canEqLeafTyVarEq loc ev tv s2 +canEqLeafOriented loc ev (FunCls fn tys1) s2 = canEqLeafFun loc ev fn tys1 s2 +canEqLeafOriented loc ev (VarCls tv) s2 = canEqLeafTyVar loc ev tv s2 canEqLeafOriented _ ev (OtherCls {}) _ = pprPanic "canEqLeafOriented" (ppr (ctEvPred ev)) -canEqLeafFunEq :: CtLoc -> CtEvidence - -> TyCon -> [TcType] -> TcType -> TcS StopOrContinue --- Precondition: LHS and RHS have compatible kinds --- (guaranteed by canEqLeaf0 -canEqLeafFunEq loc ev fn tys1 ty2 -- ev :: F tys1 ~ ty2 - = do { traceTcS "canEqLeafFunEq" $ pprEq (mkTyConApp fn tys1) ty2 +canEqLeafFun :: CtLoc -> CtEvidence + -> TyCon -> [TcType] -> TcType -> TcS StopOrContinue +canEqLeafFun loc ev fn tys1 ty2 -- ev :: F tys1 ~ ty2 + = do { traceTcS "canEqLeafFun" $ pprEq (mkTyConApp fn tys1) ty2 ; let flav = ctEvFlavour ev -- Flatten type function arguments @@ -1084,95 +1089,102 @@ canEqLeafFunEq loc ev fn tys1 ty2 -- ev :: F tys1 ~ ty2 ; let fam_head = mkTyConApp fn xis1 xco = mkHdEqPred ty2 (mkTcTyConAppCo fn cos1) co2 -- xco :: (F xis1 ~ xi2) ~ (F tys1 ~ ty2) - - ; checkKind loc ev fam_head xi2 xco $ \new_ev -> - continueWith (CFunEqCan { cc_ev = new_ev, cc_loc = loc - , cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 }) } - -canEqLeafTyVarEq :: CtLoc -> CtEvidence - -> TcTyVar -> TcType -> TcS StopOrContinue --- Precondition: LHS and RHS have compatible kinds --- (guaranteed by canEqLeaf0 -canEqLeafTyVarEq loc ev tv s2 -- ev :: tv ~ s2 - = do { traceTcS "canEqLeafTyVarEq" $ pprEq (mkTyVarTy tv) s2 + + ; mb <- rewriteCtFlavor ev (mkTcEqPred fam_head xi2) xco + ; case mb of + Nothing -> return Stop + Just new_ev | typeKind fam_head `isSubKind` typeKind xi2 + -- Establish CFunEqCan kind invariant + -> continueWith (CFunEqCan { cc_ev = new_ev, cc_loc = loc + , cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 }) + | otherwise + -> checkKind loc new_ev fam_head xi2 } + +canEqLeafTyVar :: CtLoc -> CtEvidence + -> TcTyVar -> TcType -> TcS StopOrContinue +canEqLeafTyVar loc ev tv s2 -- ev :: tv ~ s2 + = do { traceTcS "canEqLeafTyVar 1" $ pprEq (mkTyVarTy tv) s2 ; let flav = ctEvFlavour ev ; (xi1,co1) <- flattenTyVar loc FMFullFlatten flav tv -- co1 :: xi1 ~ tv ; (xi2,co2) <- flatten loc FMFullFlatten flav s2 -- co2 :: xi2 ~ s2 ; let co = mkHdEqPred s2 co1 co2 -- co :: (xi1 ~ xi2) ~ (tv ~ s2) - ; traceTcS "canEqLeafTyVarEq2" $ vcat [ppr xi1, ppr xi1] - ; case (getTyVar_maybe xi1, getTyVar_maybe xi2) of { + ; traceTcS "canEqLeafTyVar 2" $ vcat [ppr xi1, ppr xi2] + ; case (getTyVar_maybe xi1, getTyVar_maybe xi2) of (Nothing, _) -> -- Rewriting the LHS did not yield a type variable -- so go around again to canEq do { mb <- rewriteCtFlavor ev (mkTcEqPred xi1 xi2) co ; case mb of Nothing -> return Stop - Just new_ev -> canEqNC loc new_ev xi1 xi2 } ; + Just new_ev -> canEqNC loc new_ev xi1 xi2 } (Just tv1, Just tv2) | tv1 == tv2 -> do { when (isWanted ev) $ setEvBind (ctev_evar ev) (mkEvCast (EvCoercion (mkTcReflCo xi1)) co) - ; return Stop } ; - - (Just tv1, _) -> - - -- LHS rewrote to a type variable, RHS to something else - do { dflags <- getDynFlags - ; case occurCheckExpand dflags tv1 xi2 of - OC_OK xi2' -> -- No occurs check, so we can continue; but make sure - -- that the new goal has enough type synonyms expanded by - -- by the occurCheckExpand - checkKind loc ev xi1 xi2' co $ \new_ev -> - continueWith (CTyEqCan { cc_ev = new_ev, cc_loc = loc - , cc_tyvar = tv1, cc_rhs = xi2' }) - - _bad -> -- Occurs check error - do { mb <- rewriteCtFlavor ev (mkTcEqPred xi1 xi2) co - ; case mb of - Nothing -> return Stop - Just new_ev -> canEqFailure loc new_ev xi1 xi2 } - } } } + ; return Stop } + + (Just tv1, _) -> do { dflags <- getDynFlags + ; canEqLeafTyVar2 dflags loc ev tv1 xi2 co } } + +canEqLeafTyVar2 :: DynFlags -> CtLoc -> CtEvidence + -> TyVar -> Type -> TcCoercion + -> TcS StopOrContinue +-- LHS rewrote to a type variable, +-- RHS to something else (possibly a tyvar, but not the *same* tyvar) +canEqLeafTyVar2 dflags loc ev tv1 xi2 co + | OC_OK xi2' <- occurCheckExpand dflags tv1 xi2 -- No occurs check + = do { mb <- rewriteCtFlavor ev (mkTcEqPred xi1 xi2') co + -- Ensure that the new goal has enough type synonyms + -- expanded by the occurCheckExpand; hence using xi2' here + + ; case mb of + Nothing -> return Stop + Just new_ev | typeKind xi2' `isSubKind` tyVarKind tv1 + -- Establish CTyEqCan kind invariant + -- Reorientation has done its best, but the kinds might + -- simply be incompatible + -> continueWith (CTyEqCan { cc_ev = new_ev, cc_loc = loc + , cc_tyvar = tv1, cc_rhs = xi2' }) + | otherwise + -> checkKind loc new_ev xi1 xi2' } + + | otherwise -- Occurs check error + = do { mb <- rewriteCtFlavor ev (mkTcEqPred xi1 xi2) co + ; case mb of + Nothing -> return Stop + Just new_ev -> canEqFailure loc new_ev xi1 xi2 } + where + xi1 = mkTyVarTy tv1 checkKind :: CtLoc -> CtEvidence -- t1~t2 -> TcType -> TcType -- s1~s2, flattened and zonked - -> TcCoercion -- (s1~s2) ~ (t2~t2) - -> (CtEvidence -> TcS StopOrContinue) -- Do this if kinds are OK -> TcS StopOrContinue --- Do the rewrite, test for incompatible kinds, and continue --- --- See Note [Equalities with incompatible kinds] --- If there are incompatible kinds, emit an "irreducible" constraint +-- LHS and RHS have incompatible kinds, so emit an "irreducible" constraint -- CIrredEvCan (NOT CTyEqCan or CFunEqCan) -- for the type equality; and continue with the kind equality constraint. -- When the latter is solved, it'll kick out the irreducible equality for -- a second attempt at solving +-- See Note [Equalities with incompatible kinds] -checkKind loc ev s1 s2 co normal_kont - = do { mb <- rewriteCtFlavor ev (mkTcEqPred s1 s2) co - ; case mb of { - Nothing -> return Stop ; - Just new_ev | k1 `compatKind` k2 -> normal_kont new_ev - | otherwise -> - - ASSERT( isKind k1 && isKind k2 ) +checkKind loc new_ev s1 s2 + = ASSERT( isKind k1 && isKind k2 ) do { -- See Note [Equalities with incompatible kinds] - traceTcS "canEqLeaf: incompatible kinds" (vcat [ppr s1 <+> dcolon <+> ppr k1, - ppr s2 <+> dcolon <+> ppr k2]) + traceTcS "canEqLeaf: incompatible kinds" (vcat [ppr k1, ppr k2]) ; updWorkListTcS $ extendWorkListNonEq $ CIrredEvCan { cc_ev = new_ev, cc_loc = loc } ; mw <- newDerived (mkEqPred k1 k2) ; case mw of Nothing -> return Stop - Just kev -> canEqNC kind_co_loc kev k1 k2 } } } - where - k1 = typeKind s1 - k2 = typeKind s2 + Just kev -> canEqNC kind_co_loc kev k1 k2 } -- Always create a Wanted kind equality even if -- you are decomposing a given constraint. -- NB: DV finds this reasonable for now. Maybe we have to revisit. + where + k1 = typeKind s1 + k2 = typeKind s2 kind_co_loc = setCtLocOrigin loc (KindEqOrigin s1 s2 (ctLocOrigin loc)) @@ -1184,11 +1196,31 @@ mkHdEqPred t2 co1 co2 = mkTcTyConAppCo eqTyCon [mkTcReflCo (defaultKind (typeKin -- Why defaultKind? Same reason as the comment on TcType/mkTcEqPred. I truly hate this (DV) \end{code} +Note [Eliminate flat-skols] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have [G] Num (F [a]) +then we flatten to + [G] Num fsk + [G] F [a] ~ fsk +where fsk is a flatten-skolem (FlatSkol). Suppose we have + type instance F [a] = a +then we'll reduce the second constraint to + [G] a ~ fsk +and then replace all uses of 'a' with fsk. That's bad because +in error messages intead of saying 'a' we'll say (F [a]). In all +places, including those where the programmer wrote 'a' in the first +place. Very confusing! See Trac #7862. + +Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate +the fsk. + Note [Equalities with incompatible kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ canEqLeaf is about to make a CTyEqCan or CFunEqCan; but both have the -invariant that LHS and RHS have `compatKind` kinds. What if we try -to unify two things with incompatible kinds? +invariant that LHS and RHS satisfy the kind invariants for CTyEqCan, +CFunEqCan. What if we try to unify two things with incompatible +kinds? + eg a ~ b where a::*, b::*->* or a ~ b where a::*, b::k, k is a kind variable @@ -1208,6 +1240,9 @@ NB: it is important that the types s1,s2 are flattened and zonked E.g. it is WRONG to make an irred (a:k1)~(b:k2) if we already have a substitution k1:=k2 +See also Note [Kind orientation for CTyEqCan] and + Note [Kind orientation for CFunEqCan] in TcRnTypes + Note [Type synonyms and canonicalization] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We treat type synonym applications as xi types, that is, they do not diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 7da30d19b1..0a691651fb 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -46,7 +46,6 @@ import RdrName import Name import NameSet import TyCon -import CoAxiom import TcType import Var import VarSet @@ -355,7 +354,7 @@ tcDeriving tycl_decls inst_decls deriv_decls where ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name -> Bag TyCon -- ^ Empty data constructors - -> Bag (FamInst Unbranched) -- ^ Rep type family instances + -> Bag (FamInst) -- ^ Rep type family instances -> SDoc ddump_deriving inst_infos extra_binds repMetaTys repFamInsts = hang (ptext (sLit "Derived instances:")) @@ -370,12 +369,11 @@ tcDeriving tycl_decls inst_decls deriv_decls hangP s x = text "" $$ hang (ptext (sLit s)) 2 x -- Prints the representable type family instance -pprRepTy :: FamInst Unbranched -> SDoc -pprRepTy fi@(FamInst { fi_branches = FirstBranch (FamInstBranch { fib_lhs = lhs - , fib_rhs = rhs }) }) +pprRepTy :: FamInst -> SDoc +pprRepTy fi@(FamInst { fi_tys = lhs }) = ptext (sLit "type") <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+> - equals <+> ppr rhs - + equals <+> ppr rhs + where rhs = famInstRHS fi -- As of 24 April 2012, this only shares MetaTyCons between derivations of -- Generic and Generic1; thus the types and logic are quite simple. @@ -406,7 +404,7 @@ renameDeriv is_boot inst_infos bagBinds | otherwise = discardWarnings $ -- Discard warnings about unused bindings etc - setXOptM Opt_EmptyCase $ -- Derived decls (for empty types) can have + setXOptM Opt_EmptyCase $ -- Derived decls (for empty types) can have -- case x of {} do { -- Bring the extra deriving stuff into scope @@ -475,7 +473,7 @@ makeDerivSpecs :: Bool -> [LDerivDecl Name] -> TcM [EarlyDerivSpec] makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls - = do { eqns1 <- concatMapM (recoverM (return []) . deriveTyDecl) tycl_decls + = do { eqns1 <- concatMapM (recoverM (return []) . deriveTyDecl) tycl_decls ; eqns2 <- concatMapM (recoverM (return []) . deriveInstDecl) inst_decls ; eqns3 <- mapAndRecoverM deriveStandalone deriv_decls ; let eqns = eqns1 ++ eqns2 ++ eqns3 @@ -514,13 +512,27 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls ------------------------------------------------------------------ deriveTyDecl :: LTyClDecl Name -> TcM [EarlyDerivSpec] -deriveTyDecl (L _ decl@(DataDecl { tcdLName = L _ tc_name - , tcdDataDefn = HsDataDefn { dd_derivs = Just preds } })) +deriveTyDecl (L _ decl@(DataDecl { tcdLName = L loc tc_name + , tcdDataDefn = HsDataDefn { dd_derivs = preds } })) = tcAddDeclCtxt decl $ do { tc <- tcLookupTyCon tc_name - ; let tvs = tyConTyVars tc - tys = mkTyVarTys tvs - ; mapM (deriveTyData tvs tc tys) preds } + ; let tvs = tyConTyVars tc + tys = mkTyVarTys tvs + pdcs :: [LDerivDecl Name] + pdcs = [ L loc (DerivDecl (L loc (HsAppTy (noLoc (HsTyVar typeableClassName)) + (L loc (HsTyVar (tyConName pdc)))))) + | Just pdc <- map promoteDataCon_maybe (tyConDataCons tc) ] + -- If AutoDeriveTypeable and DataKinds is set, we add Typeable instances + -- for every promoted data constructor of datatypes in this module + ; isAutoTypeable <- xoptM Opt_AutoDeriveTypeable + ; isDataKinds <- xoptM Opt_DataKinds + ; prom_dcs_Typeable_instances <- if isAutoTypeable && isDataKinds + then mapM deriveStandalone pdcs + else return [] + ; other_instances <- case preds of + Just preds' -> mapM (deriveTyData tvs tc tys) preds' + Nothing -> return [] + ; return (prom_dcs_Typeable_instances ++ other_instances) } deriveTyDecl _ = return [] @@ -538,8 +550,9 @@ deriveFamInst decl@(DataFamInstDecl { dfid_tycon = L _ tc_name, dfid_pats = pats , dfid_defn = HsDataDefn { dd_derivs = Just preds } }) = tcAddDataFamInstCtxt decl $ do { fam_tc <- tcLookupTyCon tc_name - ; tcFamTyPats fam_tc pats (\_ -> return ()) $ \ tvs' pats' _ -> - mapM (deriveTyData tvs' fam_tc pats') preds } + ; tcFamTyPats tc_name (tyConKind fam_tc) pats (\_ -> return ()) $ + \ tvs' pats' _ -> + mapM (deriveTyData tvs' fam_tc pats') preds } -- Tiresomely we must figure out the "lhs", which is awkward for type families -- E.g. data T a b = .. deriving( Eq ) -- Here, the lhs is (T a b) @@ -566,6 +579,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) , text "cls:" <+> ppr cls , text "tys:" <+> ppr inst_tys ] -- C.f. TcInstDcls.tcLocalInstDecl1 + ; checkTc (not (null inst_tys)) derivingNullaryErr ; let cls_tys = take (length inst_tys - 1) inst_tys inst_ty = last inst_tys @@ -577,8 +591,8 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) (Just theta) } ------------------------------------------------------------------ -deriveTyData :: [TyVar] -> TyCon -> [Type] - -> LHsType Name -- The deriving predicate +deriveTyData :: [TyVar] -> TyCon -> [Type] -- LHS of data or data instance + -> LHsType Name -- The deriving predicate -> TcM EarlyDerivSpec -- The deriving clause of a data or newtype declaration deriveTyData tvs tc tc_args (L loc deriv_pred) @@ -592,22 +606,28 @@ deriveTyData tvs tc tc_args (L loc deriv_pred) -- Typeable is special ; if className cls == typeableClassName - then mkEqnHelp DerivOrigin - tvs cls cls_tys - (mkTyConApp tc (kindVarsOnly tc_args)) Nothing + then do { + ; dflags <- getDynFlags + ; case checkTypeableConditions (dflags, tc, tc_args) of + Just err -> failWithTc (derivingThingErr False cls cls_tys + (mkTyConApp tc tc_args) err) + Nothing -> mkEqnHelp DerivOrigin tvs cls cls_tys + (mkTyConApp tc (kindVarsOnly tc_args)) Nothing } else do { -- Given data T a b c = ... deriving( C d ), -- we want to drop type variables from T so that (C d (T a)) is well-kinded ; let cls_tyvars = classTyVars cls - kind = tyVarKind (last cls_tyvars) + ; checkTc (not (null cls_tyvars)) derivingNullaryErr + + ; let kind = tyVarKind (last cls_tyvars) (arg_kinds, _) = splitKindFunTys kind n_args_to_drop = length arg_kinds n_args_to_keep = tyConArity tc - n_args_to_drop args_to_drop = drop n_args_to_keep tc_args inst_ty = mkTyConApp tc (take n_args_to_keep tc_args) inst_ty_kind = typeKind inst_ty - dropped_tvs = mkVarSet (mapCatMaybes getTyVar_maybe args_to_drop) + dropped_tvs = tyVarsOfTypes args_to_drop univ_tvs = (mkVarSet tvs `extendVarSetList` deriv_tvs) `minusVarSet` dropped_tvs @@ -618,22 +638,19 @@ deriveTyData tvs tc tc_args (L loc deriv_pred) ; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind)) (derivingKindErr tc cls cls_tys kind) - ; checkTc (sizeVarSet dropped_tvs == n_args_to_drop && -- (a) - tyVarsOfTypes (inst_ty:cls_tys) `subVarSet` univ_tvs) -- (b) + ; checkTc (all isTyVarTy args_to_drop && -- (a) + sizeVarSet dropped_tvs == n_args_to_drop && -- (b) + tyVarsOfTypes (inst_ty:cls_tys) `subVarSet` univ_tvs) -- (c) (derivingEtaErr cls cls_tys inst_ty) -- Check that + -- (a) The args to drop are all type variables; eg reject: + -- data instance T a Int = .... deriving( Monad ) -- (a) The data type can be eta-reduced; eg reject: -- data instance T a a = ... deriving( Monad ) -- (b) The type class args do not mention any of the dropped type -- variables -- newtype T a s = ... deriving( ST s ) - -- Type families can't be partially applied - -- e.g. newtype instance T Int a = MkT [a] deriving( Monad ) - -- Note [Deriving, type families, and partial applications] - ; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0) - (typeFamilyPapErr tc cls cls_tys inst_ty) - ; mkEqnHelp DerivOrigin (varSetElemsKvsFirst univ_tvs) cls cls_tys inst_ty Nothing } } where kindVarsOnly :: [Type] -> [Type] @@ -643,33 +660,6 @@ deriveTyData tvs tc tc_args (L loc deriv_pred) | otherwise = kindVarsOnly ts \end{code} -Note [Deriving, type families, and partial applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When there are no type families, it's quite easy: - - newtype S a = MkS [a] - -- :CoS :: S ~ [] -- Eta-reduced - - instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a) - instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S - -When type familes are involved it's trickier: - - data family T a b - newtype instance T Int a = MkT [a] deriving( Eq, Monad ) - -- :RT is the representation type for (T Int a) - -- :CoF:R1T a :: T Int a ~ :RT a -- Not eta reduced - -- :Co:R1T :: :RT ~ [] -- Eta-reduced - - instance Eq [a] => Eq (T Int a) -- easy by coercion - instance Monad [] => Monad (T Int) -- only if we can eta reduce??? - -The "???" bit is that we don't build the :CoF thing in eta-reduced form -Henc the current typeFamilyPapErr, even though the instance makes sense. -After all, we can write it out - instance Monad [] => Monad (T Int) -- only if we can eta reduce??? - return x = MkT [x] - ... etc ... \begin{code} mkEqnHelp :: CtOrigin -> [TyVar] -> Class -> [Type] -> Type @@ -683,8 +673,10 @@ mkEqnHelp :: CtOrigin -> [TyVar] -> Class -> [Type] -> Type mkEqnHelp orig tvs cls cls_tys tc_app mtheta | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app - , isAlgTyCon tycon -- Check for functions, primitive types etc + , className cls == typeableClassName || isAlgTyCon tycon + -- Avoid functions, primitive types, etc, unless it's Typeable = mk_alg_eqn tycon tc_args + | otherwise = failWithTc (derivingThingErr False cls cls_tys tc_app (ptext (sLit "The last argument of the instance must be a data or newtype application"))) @@ -700,27 +692,33 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta Nothing -> mkOldTypeableEqn orig tvs cls tycon tc_args mtheta } | className cls == typeableClassName - = do { dflags <- getDynFlags - ; case checkTypeableConditions (dflags, tycon, tc_args) of - Just err -> bale_out err - Nothing -> mkPolyKindedTypeableEqn orig tvs cls cls_tys tycon tc_args mtheta } - - | isDataFamilyTyCon tycon - , length tc_args /= tyConArity tycon - = bale_out (ptext (sLit "Unsaturated data family application")) + -- We checked for errors before, so we don't need to do that again + = mkPolyKindedTypeableEqn orig tvs cls cls_tys tycon tc_args mtheta | otherwise - = do { (rep_tc, rep_tc_args) <- tcLookupDataFamInst tycon tc_args + = do { (rep_tc, rep_tc_args) <- lookup_data_fam tycon tc_args -- Be careful to test rep_tc here: in the case of families, -- we want to check the instance tycon, not the family tycon -- For standalone deriving (mtheta /= Nothing), -- check that all the data constructors are in scope. ; rdr_env <- getGlobalRdrEnv - ; let hidden_data_cons = not (isWiredInName (tyConName rep_tc)) && + ; let data_con_names = map dataConName (tyConDataCons rep_tc) + hidden_data_cons = not (isWiredInName (tyConName rep_tc)) && (isAbstractTyCon rep_tc || - any not_in_scope (tyConDataCons rep_tc)) - not_in_scope dc = null (lookupGRE_Name rdr_env (dataConName dc)) + any not_in_scope data_con_names) + not_in_scope dc = null (lookupGRE_Name rdr_env dc) + + -- Make a Qual RdrName that will do for each DataCon + -- so we can report it as used (Trac #7969) + data_con_rdrs = [ mkRdrQual (is_as (is_decl imp_spec)) occ + | dc_name <- data_con_names + , let occ = nameOccName dc_name + gres = lookupGRE_Name rdr_env dc_name + , not (null gres) + , Imported (imp_spec:_) <- [gre_prov (head gres)] ] + + ; addUsedRdrNames data_con_rdrs ; unless (isNothing mtheta || not hidden_data_cons) (bale_out (derivingHiddenErr tycon)) @@ -731,8 +729,83 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta else mkNewTypeEqn orig dflags tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta } + + lookup_data_fam :: TyCon -> [Type] -> TcM (TyCon, [Type]) + -- Find the instance of a data family + -- Note [Looking up family instances for deriving] + lookup_data_fam tycon tys + | not (isFamilyTyCon tycon) + = return (tycon, tys) + | otherwise + = ASSERT( isAlgTyCon tycon ) + do { maybeFamInst <- tcLookupFamInst tycon tys + ; case maybeFamInst of + Nothing -> bale_out (ptext (sLit "No family instance for") + <+> quotes (pprTypeApp tycon tys)) + Just (FamInstMatch { fim_instance = famInst + , fim_tys = tys }) + -> let tycon' = dataFamInstRepTyCon famInst + in return (tycon', tys) } \end{code} +Note [Looking up family instances for deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcLookupFamInstExact is an auxiliary lookup wrapper which requires +that looked-up family instances exist. If called with a vanilla +tycon, the old type application is simply returned. + +If we have + data instance F () = ... deriving Eq + data instance F () = ... deriving Eq +then tcLookupFamInstExact will be confused by the two matches; +but that can't happen because tcInstDecls1 doesn't call tcDeriving +if there are any overlaps. + +There are two other things that might go wrong with the lookup. +First, we might see a standalone deriving clause + deriving Eq (F ()) +when there is no data instance F () in scope. + +Note that it's OK to have + data instance F [a] = ... + deriving Eq (F [(a,b)]) +where the match is not exact; the same holds for ordinary data types +with standalone deriving declarations. + +Note [Deriving, type families, and partial applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When there are no type families, it's quite easy: + + newtype S a = MkS [a] + -- :CoS :: S ~ [] -- Eta-reduced + + instance Eq [a] => Eq (S a) -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a) + instance Monad [] => Monad S -- by coercion sym (Monad :CoS) : Monad [] ~ Monad S + +When type familes are involved it's trickier: + + data family T a b + newtype instance T Int a = MkT [a] deriving( Eq, Monad ) + -- :RT is the representation type for (T Int a) + -- :Co:RT :: :RT ~ [] -- Eta-reduced! + -- :CoF:RT a :: T Int a ~ :RT a -- Also eta-reduced! + + instance Eq [a] => Eq (T Int a) -- easy by coercion + -- d1 :: Eq [a] + -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a)) + + instance Monad [] => Monad (T Int) -- only if we can eta reduce??? + -- d1 :: Monad [] + -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT)) + +Note the need for the eta-reduced rule axioms. After all, we can +write it out + instance Monad [] => Monad (T Int) -- only if we can eta reduce??? + return x = MkT [x] + ... etc ... + +See Note [Eta reduction for data family axioms] in TcInstDcls. + %************************************************************************ %* * @@ -839,7 +912,7 @@ mkPolyKindedTypeableEqn orig tvs cls _cls_tys tycon tc_args mtheta , ds_tc = tycon, ds_tc_args = tc_args , ds_theta = mtheta `orElse` [] -- Context is empty for polykinded Typeable , ds_newtype = False }) } - where + where is_kind_var tc_arg = case tcGetTyVar_maybe tc_arg of Just v -> isKindVar v Nothing -> False @@ -856,7 +929,7 @@ inferConstraints cls inst_tys rep_tc rep_tc_args = return [] | cls `hasKey` gen1ClassKey -- Gen1 needs Functor - = ASSERT (length rep_tc_tvs > 0) -- See Note [Getting base classes] + = ASSERT(length rep_tc_tvs > 0) -- See Note [Getting base classes] do { functorClass <- tcLookupClass functorClassName ; return (con_arg_constraints functorClass (get_gen1_constrained_tys last_tv)) } @@ -929,16 +1002,10 @@ ghc-prim does not use Functor or Typeable implicitly via these lookups. Note [Deriving and unboxed types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We have some special hacks to support things like - data T = MkT Int# deriving( Ord, Show ) - -Specifically - * For Show we use TcGenDeriv.box_if_necy to box the Int# into an Int - (which we know how to show) + data T = MkT Int# deriving ( Show ) - * For Eq, Ord, we ust TcGenDeriv.primOrdOps to give Ord operations - on some primitive types - -It's all a bit ad hoc. +Specifically, we use TcGenDeriv.box_if_necy to box the Int# into an Int +(which we know how to show). It's a bit ad hoc. \begin{code} @@ -970,7 +1037,7 @@ checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class") checkTypeableConditions, checkOldTypeableConditions :: Condition -checkTypeableConditions = checkFlag Opt_DeriveDataTypeable +checkTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_TypeableOK checkOldTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_oldTypeableOK nonStdErr :: Class -> SDoc @@ -1115,6 +1182,20 @@ cond_oldTypeableOK (_, tc, _) bad_kind = quotes (pprSourceTyCon tc) <+> ptext (sLit "must only have arguments of kind `*'") +cond_TypeableOK :: Condition +-- Only not ok if it's a data instance +cond_TypeableOK (_, tc, tc_args) + | isDataFamilyTyCon tc && not (null tc_args) + = Just no_families + + | otherwise + = Nothing + where + no_families = sep [ ptext (sLit "Deriving Typeable is not allowed for family instances;") + , ptext (sLit "derive Typeable for") + <+> quotes (pprSourceTyCon tc) + <+> ptext (sLit "alone") ] + functorLikeClassKeys :: [Unique] functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey] @@ -1357,6 +1438,7 @@ mkNewTypeEqn orig dflags tvs && arity_ok && eta_ok && ats_ok + && roles_ok -- && not (isRecursiveTyCon tycon) -- Note [Recursive newtypes] arity_ok = length cls_tys + 1 == classArity cls @@ -1377,13 +1459,26 @@ mkNewTypeEqn orig dflags tvs -- currently generate type 'instance' decls; and cannot do -- so for 'data' instance decls + roles_ok = let cls_roles = tyConRoles (classTyCon cls) in + not (null cls_roles) && last cls_roles /= Nominal + -- We must make sure that the class definition (and all its + -- members) never pattern-match on the last parameter. + -- See Trac #1496 and Note [Roles] in Coercion + cant_derive_err = vcat [ ppUnless arity_ok arity_msg , ppUnless eta_ok eta_msg - , ppUnless ats_ok ats_msg ] + , ppUnless ats_ok ats_msg + , ppUnless roles_ok roles_msg ] arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1") eta_msg = ptext (sLit "cannot eta-reduce the representation type enough") ats_msg = ptext (sLit "the class has associated types") + roles_msg = ptext (sLit "it is not type-safe to use") <+> + ptext (sLit "GeneralizedNewtypeDeriving on this class;") $$ + ptext (sLit "the last parameter of") <+> + quotes (ppr (className cls)) <+> + ptext (sLit "is at role N") + \end{code} Note [Recursive newtypes] @@ -1509,7 +1604,7 @@ extendLocalInstEnv dfuns thing_inside *********************************************************************************** -* * +* * * Simplify derived constraints * * *********************************************************************************** @@ -1517,16 +1612,16 @@ extendLocalInstEnv dfuns thing_inside \begin{code} simplifyDeriv :: CtOrigin -> PredType - -> [TyVar] + -> [TyVar] -> ThetaType -- Wanted -> TcM ThetaType -- Needed --- Given instance (wanted) => C inst_ty +-- Given instance (wanted) => C inst_ty -- Simplify 'wanted' as much as possibles -- Fail if not possible -simplifyDeriv orig pred tvs theta +simplifyDeriv orig pred tvs theta = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize - -- The constraint solving machinery - -- expects *TcTyVars* not TyVars. + -- The constraint solving machinery + -- expects *TcTyVars* not TyVars. -- We use *non-overlappable* (vanilla) skolems -- See Note [Overlap and deriving] @@ -1536,7 +1631,7 @@ simplifyDeriv orig pred tvs theta ; wanted <- newFlatWanteds orig (substTheta skol_subst theta) - ; traceTc "simplifyDeriv" $ + ; traceTc "simplifyDeriv" $ vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ] ; (residual_wanted, _ev_binds1) <- solveWantedsTcM (mkFlatWC wanted) @@ -1545,8 +1640,8 @@ simplifyDeriv orig pred tvs theta ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted) -- See Note [Exotic derived instance contexts] get_good :: Ct -> Either PredType Ct - get_good ct | validDerivPred skol_set p - , isWantedCt ct = Left p + get_good ct | validDerivPred skol_set p + , isWantedCt ct = Left p -- NB: residual_wanted may contain unsolved -- Derived and we stick them into the bad set -- so that reportUnsolved may decide what to do with them @@ -1583,7 +1678,7 @@ and we want to infer f :: Show [a] => a -> String BOTTOM LINE: use vanilla, non-overlappable skolems when inferring - the context for the derived instance. + the context for the derived instance. Hence tcInstSkolTyVars not tcInstSuperSkolTyVars Note [Exotic derived instance contexts] @@ -1598,13 +1693,13 @@ One could go further: consider data T a b c = MkT (Foo a b c) deriving( Eq ) instance (C Int a, Eq b, Eq c) => Eq (Foo a b c) -Notice that this instance (just) satisfies the Paterson termination +Notice that this instance (just) satisfies the Paterson termination conditions. Then we *could* derive an instance decl like this: - instance (C Int a, Eq b, Eq c) => Eq (T a b c) + instance (C Int a, Eq b, Eq c) => Eq (T a b c) even though there is no instance for (C Int a), because there just *might* be an instance for, say, (C Int Bool) at a site where we -need the equality instance for T's. +need the equality instance for T's. However, this seems pretty exotic, and it's quite tricky to allow this, and yet give sensible error messages in the (much more common) @@ -1799,6 +1894,9 @@ genDerivStuff loc fix_env clas name tycon comaux_maybe %************************************************************************ \begin{code} +derivingNullaryErr :: MsgDoc +derivingNullaryErr = ptext (sLit "Cannot derive instances for nullary classes") + derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> MsgDoc derivingKindErr tc cls cls_tys cls_kind = hang (ptext (sLit "Cannot derive well-kinded instance of form") @@ -1812,11 +1910,6 @@ derivingEtaErr cls cls_tys inst_ty nest 2 (ptext (sLit "instance (...) =>") <+> pprClassPred cls (cls_tys ++ [inst_ty]))] -typeFamilyPapErr :: TyCon -> Class -> [Type] -> Type -> MsgDoc -typeFamilyPapErr tc cls cls_tys inst_ty - = hang (ptext (sLit "Derived instance") <+> quotes (pprClassPred cls (cls_tys ++ [inst_ty]))) - 2 (ptext (sLit "requires illegal partial application of data type family") <+> ppr tc) - derivingThingErr :: Bool -> Class -> [Type] -> Type -> MsgDoc -> MsgDoc derivingThingErr newtype_deriving clas tys ty why = sep [(hang (ptext (sLit "Can't make a derived instance of")) diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 528c06cbd5..058e84a22e 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -734,8 +734,9 @@ newGlobalBinder. newFamInstTyConName :: Located Name -> [Type] -> TcM Name newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys] -newFamInstAxiomName :: SrcSpan -> Name -> [[Type]] -> TcM Name -newFamInstAxiomName = mk_fam_inst_name mkInstTyCoOcc +newFamInstAxiomName :: SrcSpan -> Name -> [CoAxBranch] -> TcM Name +newFamInstAxiomName loc name branches + = mk_fam_inst_name mkInstTyCoOcc loc name (map coAxBranchLHS branches) mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name mk_fam_inst_name adaptOcc loc tc_name tyss diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 8bb6de1cc2..4023311d3a 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -92,11 +92,6 @@ in TcErrors. TcErrors.reportTidyWanteds does not print the errors and does not fail if -fdefer-type-errors is on, so that we can continue compilation. The errors are turned into warnings in `reportUnsolved`. -Note [Suppressing error messages] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If there are any insolubles, like (Int~Bool), then we suppress all less-drastic -errors (like (Eq a)). Often the latter are a knock-on effect of the former. - \begin{code} reportUnsolved :: WantedConstraints -> TcM (Bag EvBind) reportUnsolved wanted @@ -131,8 +126,7 @@ report_unsolved mb_binds_var defer wanted err_ctxt = CEC { cec_encl = [] , cec_tidy = tidy_env , cec_defer = defer - , cec_suppress = insolubleWC wanted - -- See Note [Suppressing error messages] + , cec_suppress = False -- See Note [Suppressing error messages] , cec_binds = mb_binds_var } ; traceTc "reportUnsolved (after unflattening):" $ @@ -161,8 +155,23 @@ data ReportErrCtxt , cec_suppress :: Bool -- True <=> More important errors have occurred, -- so create bindings if need be, but -- don't issue any more errors/warnings + -- See Note [Suppressing error messages] } +\end{code} + +Note [Suppressing error messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The cec_suppress flag says "don't report any errors. Instead, just create +evidence bindings (as usual). It's used when more important errors have occurred. +Specifically (see reportWanteds) + * If there are insoluble Givens, then we are in unreachable code and all bets + are off. So don't report any further errors. + * If there are any insolubles (eg Int~Bool), here or in a nested implication, + then suppress errors from the flat constraints here. Sometimes the + flat-constraint errors are a knock-on effect of the insolubles. + +\begin{code} reportImplic :: ReportErrCtxt -> Implication -> TcM () reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given , ic_wanted = wanted, ic_binds = evb @@ -188,20 +197,33 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given Just {} -> Just evb } reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM () -reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics }) - = do { reportFlats (ctxt { cec_suppress = False }) (mapBag (tidyCt env) insols) - ; reportFlats ctxt (mapBag (tidyCt env) flats) +reportWanteds ctxt wanted@(WC { wc_flat = flats, wc_insol = insols, wc_impl = implics }) + = do { reportFlats ctxt (mapBag (tidyCt env) insol_given) + ; reportFlats ctxt1 (mapBag (tidyCt env) insol_wanted) + ; reportFlats ctxt2 (mapBag (tidyCt env) flats) -- All the Derived ones have been filtered out of flats -- by the constraint solver. This is ok; we don't want -- to report unsolved Derived goals as errors -- See Note [Do not report derived but soluble errors] - ; mapBagM_ (reportImplic ctxt) implics } - where + ; mapBagM_ (reportImplic ctxt1) implics } + -- NB ctxt1: don't suppress inner insolubles if there's only a + -- wanted insoluble here; but do suppress inner insolubles + -- if there's a given insoluble here (= inaccessible code) + where + (insol_given, insol_wanted) = partitionBag isGivenCt insols env = cec_tidy ctxt + -- See Note [Suppressing error messages] + suppress0 = cec_suppress ctxt + suppress1 = suppress0 || not (isEmptyBag insol_given) + suppress2 = suppress0 || insolubleWC wanted + ctxt1 = ctxt { cec_suppress = suppress1 } + ctxt2 = ctxt { cec_suppress = suppress2 } + reportFlats :: ReportErrCtxt -> Cts -> TcM () reportFlats ctxt flats -- Here 'flats' includes insolble goals - = traceTc "reportFlats" (ppr flats) >> + = traceTc "reportFlats" (vcat [ ptext (sLit "Flats =") <+> ppr flats + , ptext (sLit "Suppress =") <+> ppr (cec_suppress ctxt)]) >> tryReporters [ -- First deal with things that are utterly wrong -- Like Int ~ Bool (incl nullary TyCons) @@ -301,6 +323,7 @@ mkGroupReporter mk_err ctxt (ct1 : rest) ; maybeReportError ctxt err ; mapM_ (maybeAddDeferredBinding ctxt err) first_group -- Add deferred bindings for all + -- But see Note [Always warn with -fdefer-type-errors] ; mkGroupReporter mk_err ctxt others } where loc = cc_loc ct1 @@ -314,8 +337,7 @@ mkGroupReporter mk_err ctxt (ct1 : rest) maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM () -- Report the error and/or make a deferred binding for it maybeReportError ctxt err - | cec_defer ctxt -- We have -fdefer-type-errors - -- so warn about all, even if cec_suppress is on + | cec_defer ctxt -- See Note [Always warn with -fdefer-type-errors] = reportWarning (makeIntoWarning err) | cec_suppress ctxt = return () @@ -403,6 +425,22 @@ getUserGivens (CEC {cec_encl = ctxt}) , not (null givens) ] \end{code} +Note [Always warn with -fdefer-type-errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When -fdefer-type-errors is on we warn about *all* type errors, even +if cec_suppress is on. This can lead to a lot more warnings than you +would get errors without -fdefer-type-errors, but if we suppress any of +them you might get a runtime error that wasn't warned about at compile +time. + +This is an easy design choice to change; just flip the order of the +first two equations for maybeReportError + +To be consistent, we should also report multiple warnings from a single +location in mkGroupReporter, when -fdefer-type-errors is on. But that +is perhaps a bit *over*-consistent! Again, an easy choice to change. + + Note [Do not report derived but soluble errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The wc_flats include Derived constraints that have not been solved, but are @@ -1164,7 +1202,7 @@ relevantBindings ctxt ct | otherwise = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id) ; let id_tvs = tyVarsOfType tidy_ty - doc = sep [ ppr id <+> dcolon <+> ppr tidy_ty + doc = sep [ pprPrefixOcc id <+> dcolon <+> ppr tidy_ty , nest 2 (parens (ptext (sLit "bound at") <+> ppr (getSrcLoc id)))] ; if id_tvs `intersectsVarSet` ct_tvs diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs index 1d3d619a5f..a18dc21438 100644 --- a/compiler/typecheck/TcEvidence.lhs +++ b/compiler/typecheck/TcEvidence.lhs @@ -79,6 +79,12 @@ differences * The kind of a TcCoercion is t1 ~ t2 of a Coercion is t1 ~# t2 + * TcCoercions are essentially all at role Nominal -- the type-checker + reasons only about nominal equality, not representational. + --> Exception: there can be newtype axioms wrapped up in TcCoercions. + These, of course, are only used in casts, so the desugarer + will still produce the right 'Coercion's. + * TcAxiomInstCo takes Types, not Coecions as arguments; the generality is required only in the Simplifier @@ -96,7 +102,7 @@ data TcCoercion | TcAppCo TcCoercion TcCoercion | TcForAllCo TyVar TcCoercion | TcInstCo TcCoercion TcType - | TcCoVarCo EqVar + | TcCoVarCo EqVar -- variable always at role N | TcAxiomInstCo (CoAxiom Branched) Int [TcType] -- Int specifies branch number -- See [CoAxiom Index] in Coercion.lhs | TcSymCo TcCoercion @@ -233,7 +239,7 @@ tcCoercionKind co = go co eqVarKind :: EqVar -> Pair Type eqVarKind cv | Just (tc, [_kind,ty1,ty2]) <- tcSplitTyConApp_maybe (varType cv) - = ASSERT (tc `hasKey` eqTyConKey) + = ASSERT(tc `hasKey` eqTyConKey) Pair ty1 ty2 | otherwise = pprPanic "eqVarKind, non coercion variable" (ppr cv <+> dcolon <+> ppr (varType cv)) diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 7766dd721d..b353a52bdf 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -5,22 +5,15 @@ \section[TcExpr]{Typecheck an expression} \begin{code} -{-# 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 TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, - tcInferRho, tcInferRhoNC, +module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, + tcInferRho, tcInferRhoNC, tcSyntaxOp, tcCheckId, addExprErrCtxt) where - + #include "HsVersions.h" -#ifdef GHCI /* Only if bootstrapped */ -import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) +#ifdef GHCI /* Only if bootstrapped */ +import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) import qualified DsMeta #endif @@ -65,40 +58,43 @@ import Outputable import FastString import Control.Monad import Class(classTyCon) +import Data.Function +import Data.List +import qualified Data.Set as Set \end{code} %************************************************************************ -%* * +%* * \subsection{Main wrappers} -%* * +%* * %************************************************************************ \begin{code} tcPolyExpr, tcPolyExprNC - :: LHsExpr Name -- Expression to type check - -> TcSigmaType -- Expected type (could be a polytpye) - -> TcM (LHsExpr TcId) -- Generalised expr with expected type + :: LHsExpr Name -- Expression to type check + -> TcSigmaType -- Expected type (could be a polytpye) + -> TcM (LHsExpr TcId) -- Generalised expr with expected type -- tcPolyExpr is a convenient place (frequent but not too frequent) -- place to add context information. -- The NC version does not do so, usually because the caller wants -- to do so himself. -tcPolyExpr expr res_ty +tcPolyExpr expr res_ty = addExprErrCtxt expr $ do { traceTc "tcPolyExpr" (ppr res_ty); tcPolyExprNC expr res_ty } tcPolyExprNC expr res_ty = do { traceTc "tcPolyExprNC" (ppr res_ty) ; (gen_fn, expr') <- tcGen GenSigCtxt res_ty $ \ _ rho -> - tcMonoExprNC expr rho + tcMonoExprNC expr rho ; return (mkLHsWrap gen_fn expr') } --------------- -tcMonoExpr, tcMonoExprNC +tcMonoExpr, tcMonoExprNC :: LHsExpr Name -- Expression to type check -> TcRhoType -- Expected type (could be a type variable) - -- Definitely no foralls at the top + -- Definitely no foralls at the top -> TcM (LHsExpr TcId) tcMonoExpr expr res_ty @@ -108,8 +104,8 @@ tcMonoExpr expr res_ty tcMonoExprNC (L loc expr) res_ty = ASSERT( not (isSigmaTy res_ty) ) setSrcSpan loc $ - do { expr' <- tcExpr expr res_ty - ; return (L loc expr') } + do { expr' <- tcExpr expr res_ty + ; return (L loc expr') } --------------- tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) @@ -118,7 +114,7 @@ tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) -- f :: Int -> (forall a. a -> a) -> Int -- then we can infer -- f 3 :: (forall a. a -> a) -> Int --- And that in turn is useful +-- And that in turn is useful -- (a) for the function part of any application (see tcApp) -- (b) for the special rule for '$' tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr) @@ -129,14 +125,14 @@ tcInferRhoNC (L loc expr) ; return (L loc expr', rho) } tcInfExpr :: HsExpr Name -> TcM (HsExpr TcId, TcRhoType) -tcInfExpr (HsVar f) = tcInferId f -tcInfExpr (HsPar e) = do { (e', ty) <- tcInferRhoNC e +tcInfExpr (HsVar f) = tcInferId f +tcInfExpr (HsPar e) = do { (e', ty) <- tcInferRhoNC e ; return (HsPar e', ty) } -tcInfExpr (HsApp e1 e2) = tcInferApp e1 [e2] +tcInfExpr (HsApp e1 e2) = tcInferApp e1 [e2] tcInfExpr e = tcInfer (tcExpr e) tcHole :: OccName -> TcRhoType -> TcM (HsExpr TcId) -tcHole occ res_ty +tcHole occ res_ty = do { ty <- newFlexiTyVarTy liftedTypeKind ; name <- newSysName occ ; let ev = mkLocalId name ty @@ -148,47 +144,47 @@ tcHole occ res_ty %************************************************************************ -%* * - tcExpr: the main expression typechecker -%* * +%* * + tcExpr: the main expression typechecker +%* * %************************************************************************ \begin{code} tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId) tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check - = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e) + = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e) tcExpr (HsVar name) res_ty = tcCheckId name res_ty tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit - ; tcWrapResult (HsLit lit) lit_ty res_ty } + ; tcWrapResult (HsLit lit) lit_ty res_ty } tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty - ; return (HsPar expr') } + ; return (HsPar expr') } -tcExpr (HsSCC lbl expr) res_ty +tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty ; return (HsSCC lbl expr') } -tcExpr (HsTickPragma info expr) res_ty +tcExpr (HsTickPragma info expr) res_ty = do { expr' <- tcMonoExpr expr res_ty ; return (HsTickPragma info expr') } tcExpr (HsCoreAnn lbl expr) res_ty - = do { expr' <- tcMonoExpr expr res_ty - ; return (HsCoreAnn lbl expr') } + = do { expr' <- tcMonoExpr expr res_ty + ; return (HsCoreAnn lbl expr') } -tcExpr (HsOverLit lit) res_ty - = do { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty - ; return (HsOverLit lit') } +tcExpr (HsOverLit lit) res_ty + = do { lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty + ; return (HsOverLit lit') } tcExpr (NegApp expr neg_expr) res_ty - = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr - (mkFunTy res_ty res_ty) - ; expr' <- tcMonoExpr expr res_ty - ; return (NegApp expr' neg_expr') } + = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr + (mkFunTy res_ty res_ty) + ; expr' <- tcMonoExpr expr res_ty + ; return (NegApp expr' neg_expr') } tcExpr (HsIPVar x) res_ty = do { let origin = IPOccOrigin x @@ -209,13 +205,13 @@ tcExpr (HsIPVar x) res_ty Nothing -> panic "The dictionary for `IP` is not a newtype?" tcExpr (HsLam match) res_ty - = do { (co_fn, match') <- tcMatchLambda match res_ty - ; return (mkHsWrap co_fn (HsLam match')) } + = do { (co_fn, match') <- tcMatchLambda match res_ty + ; return (mkHsWrap co_fn (HsLam match')) } tcExpr e@(HsLamCase _ matches) res_ty - = do { (co_fn, [arg_ty], body_ty) <- matchExpectedFunTys msg 1 res_ty - ; matches' <- tcMatchesCase match_ctxt arg_ty matches body_ty - ; return $ mkHsWrapCo co_fn $ HsLamCase arg_ty matches' } + = do { (co_fn, [arg_ty], body_ty) <- matchExpectedFunTys msg 1 res_ty + ; matches' <- tcMatchesCase match_ctxt arg_ty matches body_ty + ; return $ mkHsWrapCo co_fn $ HsLamCase arg_ty matches' } where msg = sep [ ptext (sLit "The function") <+> quotes (ppr e) , ptext (sLit "requires")] match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } @@ -224,11 +220,11 @@ tcExpr (ExprWithTySig expr sig_ty) res_ty = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty -- Remember to extend the lexical type-variable environment - ; (gen_fn, expr') + ; (gen_fn, expr') <- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty -> - tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` skol_tvs) $ - -- See Note [More instantiated than scoped] in TcBinds - tcMonoExprNC expr res_ty + tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` skol_tvs) $ + -- See Note [More instantiated than scoped] in TcBinds + tcMonoExprNC expr res_ty ; let inner_expr = ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty @@ -237,28 +233,28 @@ tcExpr (ExprWithTySig expr sig_ty) res_ty tcExpr (HsType ty) _ = failWithTc (text "Can't handle type argument:" <+> ppr ty) - -- This is the syntax for type applications that I was planning - -- but there are difficulties (e.g. what order for type args) - -- so it's not enabled yet. - -- Can't eliminate it altogether from the parser, because the - -- same parser parses *patterns*. + -- This is the syntax for type applications that I was planning + -- but there are difficulties (e.g. what order for type args) + -- so it's not enabled yet. + -- Can't eliminate it altogether from the parser, because the + -- same parser parses *patterns*. tcExpr (HsUnboundVar v) res_ty = tcHole (rdrNameOcc v) res_ty \end{code} %************************************************************************ -%* * - Infix operators and sections -%* * +%* * + Infix operators and sections +%* * %************************************************************************ Note [Left sections] ~~~~~~~~~~~~~~~~~~~~ Left sections, like (4 *), are equivalent to - \ x -> (*) 4 x, + \ x -> (*) 4 x, or, if PostfixOperators is enabled, just - (*) 4 + (*) 4 With PostfixOperators we don't actually require the function to take two arguments at all. For example, (x `not`) means (not x); you get postfix operators! Not Haskell 98, but it's less work and kind of @@ -266,14 +262,14 @@ useful. Note [Typing rule for ($)] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -People write +People write runST $ blah -so much, where +so much, where runST :: (forall s. ST s a) -> a that I have finally given in and written a special type-checking -rule just for saturated appliations of ($). +rule just for saturated appliations of ($). * Infer the type of the first argument - * Decompose it; should be of form (arg2_ty -> res_ty), + * Decompose it; should be of form (arg2_ty -> res_ty), where arg2_ty might be a polytype * Use arg2_ty to typecheck arg2 @@ -282,26 +278,26 @@ Note [Typing rule for seq] We want to allow x `seq` (# p,q #) which suggests this type for seq: - seq :: forall (a:*) (b:??). a -> b -> b, + seq :: forall (a:*) (b:??). a -> b -> b, with (b:??) meaning that be can be instantiated with an unboxed tuple. But that's ill-kinded! Function arguments can't be unboxed tuples. And indeed, you could not expect to do this with a partially-applied 'seq'; it's only going to work when it's fully applied. so it turns -into +into case x of _ -> (# p,q #) For a while I slid by by giving 'seq' an ill-kinded type, but then -the simplifier eta-reduced an application of seq and Lint blew up +the simplifier eta-reduced an application of seq and Lint blew up with a kind error. It seems more uniform to treat 'seq' as it it -was a language construct. +was a language construct. -See Note [seqId magic] in MkId, and +See Note [seqId magic] in MkId, and \begin{code} tcExpr (OpApp arg1 op fix arg2) res_ty | (L loc (HsVar op_name)) <- op - , op_name `hasKey` seqIdKey -- Note [Typing rule for seq] + , op_name `hasKey` seqIdKey -- Note [Typing rule for seq] = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind ; let arg2_ty = res_ty ; arg1' <- tcArg op (arg1, arg1_ty, 1) @@ -311,14 +307,14 @@ tcExpr (OpApp arg1 op fix arg2) res_ty ; return $ OpApp arg1' op' fix arg2' } | (L loc (HsVar op_name)) <- op - , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] + , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] = do { traceTc "Application rule" (ppr op) ; (arg1', arg1_ty) <- tcInferRho arg1 ; let doc = ptext (sLit "The first argument of ($) takes") ; (co_arg1, [arg2_ty], op_res_ty) <- matchExpectedFunTys doc 1 arg1_ty -- arg1_ty = arg2_ty -> op_res_ty - -- And arg2_ty maybe polymorphic; that's the point + -- And arg2_ty maybe polymorphic; that's the point -- Make sure that the argument and result types have kind '*' -- Eg we do not want to allow (D# $ 4.0#) Trac #5570 @@ -339,8 +335,8 @@ tcExpr (OpApp arg1 op fix arg2) res_ty ; let op' = L loc (HsWrap (mkWpTyApps [a_ty, b_ty]) (HsVar op_id)) ; return $ mkHsWrapCo (co_res) $ OpApp (mkLHsWrapCo (mkTcFunCo co_a co_b) $ - mkLHsWrapCo co_arg1 arg1') - op' fix + mkLHsWrapCo co_arg1 arg1') + op' fix (mkLHsWrapCo co_a arg2') } | otherwise @@ -353,19 +349,19 @@ tcExpr (OpApp arg1 op fix arg2) res_ty OpApp arg1' (mkLHsWrapCo co_fn op') fix arg2' } -- Right sections, equivalent to \ x -> x `op` expr, or --- \ x -> op x expr - +-- \ x -> op x expr + tcExpr (SectionR op arg2) res_ty = do { (op', op_ty) <- tcInferFun op ; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTysWrap op 2 op_ty ; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty ; arg2' <- tcArg op (arg2, arg2_ty, 2) ; return $ mkHsWrapCo co_res $ - SectionR (mkLHsWrapCo co_fn op') arg2' } + SectionR (mkLHsWrapCo co_fn op') arg2' } tcExpr (SectionL arg1 op) res_ty = do { (op', op_ty) <- tcInferFun op - ; dflags <- getDynFlags -- Note [Left sections] + ; dflags <- getDynFlags -- Note [Left sections] ; let n_reqd_args | xopt Opt_PostfixOperators dflags = 1 | otherwise = 2 @@ -381,12 +377,12 @@ tcExpr (ExplicitTuple tup_args boxity) res_ty ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty ; tup_args1 <- tcTupArgs tup_args arg_tys ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } - + | otherwise = -- The tup_args are a mixture of Present and Missing (for tuple sections) do { let kind = case boxity of { Boxed -> liftedTypeKind ; Unboxed -> openTypeKind } - arity = length tup_args + arity = length tup_args tup_tc = tupleTyCon (boxityNormalTupleSort boxity) arity ; arg_tys <- newFlexiTyVarTys (tyConArity tup_tc) kind @@ -398,13 +394,13 @@ tcExpr (ExplicitTuple tup_args boxity) res_ty -- Handle tuple sections where ; tup_args1 <- tcTupArgs tup_args arg_tys - + ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } -tcExpr (ExplicitList _ witness exprs) res_ty +tcExpr (ExplicitList _ witness exprs) res_ty = case witness of Nothing -> do { (coi, elt_ty) <- matchExpectedListTy res_ty - ; exprs' <- mapM (tc_elt elt_ty) exprs + ; exprs' <- mapM (tc_elt elt_ty) exprs ; return $ mkHsWrapCo coi (ExplicitList elt_ty Nothing exprs') } Just fln -> do { list_ty <- newFlexiTyVarTy liftedTypeKind @@ -412,48 +408,48 @@ tcExpr (ExplicitList _ witness exprs) res_ty ; (coi, elt_ty) <- matchExpectedListTy list_ty ; exprs' <- mapM (tc_elt elt_ty) exprs ; return $ mkHsWrapCo coi (ExplicitList elt_ty (Just fln') exprs') } - where tc_elt elt_ty expr = tcPolyExpr expr elt_ty + where tc_elt elt_ty expr = tcPolyExpr expr elt_ty -tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty - = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty - ; exprs' <- mapM (tc_elt elt_ty) exprs - ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') } +tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty + = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty + ; exprs' <- mapM (tc_elt elt_ty) exprs + ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') } where tc_elt elt_ty expr = tcPolyExpr expr elt_ty \end{code} %************************************************************************ -%* * - Let, case, if, do -%* * +%* * + Let, case, if, do +%* * %************************************************************************ \begin{code} tcExpr (HsLet binds expr) res_ty - = do { (binds', expr') <- tcLocalBinds binds $ - tcMonoExpr expr res_ty - ; return (HsLet binds' expr') } + = do { (binds', expr') <- tcLocalBinds binds $ + tcMonoExpr expr res_ty + ; return (HsLet binds' expr') } tcExpr (HsCase scrut matches) exp_ty - = do { -- We used to typecheck the case alternatives first. - -- The case patterns tend to give good type info to use - -- when typechecking the scrutinee. For example - -- case (map f) of - -- (x:xs) -> ... - -- will report that map is applied to too few arguments - -- - -- But now, in the GADT world, we need to typecheck the scrutinee - -- first, to get type info that may be refined in the case alternatives - (scrut', scrut_ty) <- tcInferRho scrut - - ; traceTc "HsCase" (ppr scrut_ty) - ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty - ; return (HsCase scrut' matches') } + = do { -- We used to typecheck the case alternatives first. + -- The case patterns tend to give good type info to use + -- when typechecking the scrutinee. For example + -- case (map f) of + -- (x:xs) -> ... + -- will report that map is applied to too few arguments + -- + -- But now, in the GADT world, we need to typecheck the scrutinee + -- first, to get type info that may be refined in the case alternatives + (scrut', scrut_ty) <- tcInferRho scrut + + ; traceTc "HsCase" (ppr scrut_ty) + ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty + ; return (HsCase scrut' matches') } where match_ctxt = MC { mc_what = CaseAlt, - mc_body = tcBody } + mc_body = tcBody } -tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if' +tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if' = do { pred' <- tcMonoExpr pred boolTy ; b1' <- tcMonoExpr b1 res_ty ; b2' <- tcMonoExpr b2 res_ty @@ -484,8 +480,8 @@ tcExpr (HsDo do_or_lc stmts _) res_ty = tcDoStmts do_or_lc stmts res_ty tcExpr (HsProc pat cmd) res_ty - = do { (pat', cmd', coi) <- tcProc pat cmd res_ty - ; return $ mkHsWrapCo coi (HsProc pat' cmd') } + = do { (pat', cmd', coi) <- tcProc pat cmd res_ty + ; return $ mkHsWrapCo coi (HsProc pat' cmd') } \end{code} Note [Rebindable syntax for if] @@ -505,27 +501,27 @@ to support expressions like this: %************************************************************************ -%* * - Record construction and update -%* * +%* * + Record construction and update +%* * %************************************************************************ \begin{code} tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty - = do { data_con <- tcLookupDataCon con_name + = do { data_con <- tcLookupDataCon con_name - -- Check for missing fields - ; checkMissingFields data_con rbinds + -- Check for missing fields + ; checkMissingFields data_con rbinds - ; (con_expr, con_tau) <- tcInferId con_name - ; let arity = dataConSourceArity data_con - (arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity - con_id = dataConWrapId data_con + ; (con_expr, con_tau) <- tcInferId con_name + ; let arity = dataConSourceArity data_con + (arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity + con_id = dataConWrapId data_con ; co_res <- unifyType actual_res_ty res_ty ; rbinds' <- tcRecordBinds data_con arg_tys rbinds - ; return $ mkHsWrapCo co_res $ - RecordCon (L loc con_id) con_expr rbinds' } + ; return $ mkHsWrapCo co_res $ + RecordCon (L loc con_id) con_expr rbinds' } \end{code} Note [Type of a record update] @@ -533,12 +529,12 @@ Note [Type of a record update] The main complication with RecordUpd is that we need to explicitly handle the *non-updated* fields. Consider: - data T a b c = MkT1 { fa :: a, fb :: (b,c) } - | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c } - | MkT3 { fd :: a } - - upd :: T a b c -> (b',c) -> T a b' c - upd t x = t { fb = x} + data T a b c = MkT1 { fa :: a, fb :: (b,c) } + | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c } + | MkT3 { fd :: a } + + upd :: T a b c -> (b',c) -> T a b' c + upd t x = t { fb = x} The result type should be (T a b' c) not (T a b c), because 'b' *is not* mentioned in a non-updated field @@ -547,10 +543,10 @@ NB that it's not good enough to look at just one constructor; we must look at them all; cf Trac #3219 After all, upd should be equivalent to: - upd t x = case t of - MkT1 p q -> MkT1 p x - MkT2 a b -> MkT2 p b - MkT3 d -> error ... + upd t x = case t of + MkT1 p q -> MkT1 p x + MkT2 a b -> MkT2 p b + MkT3 d -> error ... So we need to give a completely fresh type to the result record, and then constrain it by the fields that are *not* updated ("p" above). @@ -563,17 +559,17 @@ Hence the use of 'relevant_cont'. Note [Implict type sharing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ We also take into account any "implicit" non-update fields. For example - data T a b where { MkT { f::a } :: T a a; ... } + data T a b where { MkT { f::a } :: T a a; ... } So the "real" type of MkT is: forall ab. (a~b) => a -> T a b Then consider - upd t x = t { f=x } + upd t x = t { f=x } We infer the type - upd :: T a b -> a -> T a b - upd (t::T a b) (x::a) - = case t of { MkT (co:a~b) (_:a) -> MkT co x } + upd :: T a b -> a -> T a b + upd (t::T a b) (x::a) + = case t of { MkT (co:a~b) (_:a) -> MkT co x } We can't give it the more general type - upd :: T a b -> c -> T c b + upd :: T a b -> c -> T c b Note [Criteria for update] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -590,7 +586,7 @@ The criterion we use is this: of the data constructor NB: this is not (quite) the same as being a "naughty" record selector -(See Note [Naughty record selectors]) in TcTyClsDecls), at least +(See Note [Naughty record selectors]) in TcTyClsDecls), at least in the case of GADTs. Consider data T a where { MkT :: { f :: a } :: T [a] } Then f is not "naughty" because it has a well-typed record selector. @@ -614,9 +610,9 @@ Suppose r :: T (t1,t2), e :: t3 Then r { x=e } :: T (t3,t1) ---> case r |> co1 of - MkT x y -> MkT e y |> co2 + MkT x y -> MkT e y |> co2 where co1 :: T (t1,t2) ~ :TP t1 t2 - co2 :: :TP t3 t2 ~ T (t3,t2) + co2 :: :TP t3 t2 ~ T (t3,t2) The wrapping with co2 is done by the constructor wrapper for MkT Outgoing invariants @@ -626,111 +622,111 @@ In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys): * cons are the data constructors to be updated * in_inst_tys, out_inst_tys have same length, and instantiate the - *representation* tycon of the data cons. In Note [Data - family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2] - + *representation* tycon of the data cons. In Note [Data + family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2] + \begin{code} tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty = ASSERT( notNull upd_fld_names ) - do { - -- STEP 0 - -- Check that the field names are really field names - ; sel_ids <- mapM tcLookupField upd_fld_names - -- The renamer has already checked that - -- selectors are all in scope - ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name) - | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids, - not (isRecordSelector sel_id), -- Excludes class ops - let L loc fld_name = hsRecFieldId fld ] - ; unless (null bad_guys) (sequence bad_guys >> failM) - - -- STEP 1 - -- Figure out the tycon and data cons from the first field name - ; let -- It's OK to use the non-tc splitters here (for a selector) - sel_id : _ = sel_ids - (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if - data_cons = tyConDataCons tycon -- it's not a field label - -- NB: for a data type family, the tycon is the instance tycon - - relevant_cons = filter is_relevant data_cons - is_relevant con = all (`elem` dataConFieldLabels con) upd_fld_names - -- A constructor is only relevant to this process if - -- it contains *all* the fields that are being updated - -- Other ones will cause a runtime error if they occur - - -- Take apart a representative constructor - con1 = ASSERT( not (null relevant_cons) ) head relevant_cons - (con1_tvs, _, _, _, con1_arg_tys, _) = dataConFullSig con1 - con1_flds = dataConFieldLabels con1 - con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs) - - -- Step 2 - -- Check that at least one constructor has all the named fields - -- i.e. has an empty set of bad fields returned by badFields - ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds) - - -- STEP 3 Note [Criteria for update] - -- Check that each updated field is polymorphic; that is, its type - -- mentions only the universally-quantified variables of the data con - ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys - upd_flds1_w_tys = filter is_updated flds1_w_tys - is_updated (fld,_) = fld `elem` upd_fld_names - - bad_upd_flds = filter bad_fld upd_flds1_w_tys - con1_tv_set = mkVarSet con1_tvs - bad_fld (fld, ty) = fld `elem` upd_fld_names && - not (tyVarsOfType ty `subVarSet` con1_tv_set) - ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds) - - -- STEP 4 Note [Type of a record update] - -- Figure out types for the scrutinee and result - -- Both are of form (T a b c), with fresh type variables, but with - -- common variables where the scrutinee and result must have the same type - -- These are variables that appear in *any* arg of *any* of the - -- relevant constructors *except* in the updated fields - -- - ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons - is_fixed_tv tv = tv `elemVarSet` fixed_tvs + do { + -- STEP 0 + -- Check that the field names are really field names + ; sel_ids <- mapM tcLookupField upd_fld_names + -- The renamer has already checked that + -- selectors are all in scope + ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name) + | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids, + not (isRecordSelector sel_id), -- Excludes class ops + let L loc fld_name = hsRecFieldId fld ] + ; unless (null bad_guys) (sequence bad_guys >> failM) + + -- STEP 1 + -- Figure out the tycon and data cons from the first field name + ; let -- It's OK to use the non-tc splitters here (for a selector) + sel_id : _ = sel_ids + (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if + data_cons = tyConDataCons tycon -- it's not a field label + -- NB: for a data type family, the tycon is the instance tycon + + relevant_cons = filter is_relevant data_cons + is_relevant con = all (`elem` dataConFieldLabels con) upd_fld_names + -- A constructor is only relevant to this process if + -- it contains *all* the fields that are being updated + -- Other ones will cause a runtime error if they occur + + -- Take apart a representative constructor + con1 = ASSERT( not (null relevant_cons) ) head relevant_cons + (con1_tvs, _, _, _, con1_arg_tys, _) = dataConFullSig con1 + con1_flds = dataConFieldLabels con1 + con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs) + + -- Step 2 + -- Check that at least one constructor has all the named fields + -- i.e. has an empty set of bad fields returned by badFields + ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds data_cons) + + -- STEP 3 Note [Criteria for update] + -- Check that each updated field is polymorphic; that is, its type + -- mentions only the universally-quantified variables of the data con + ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys + upd_flds1_w_tys = filter is_updated flds1_w_tys + is_updated (fld,_) = fld `elem` upd_fld_names + + bad_upd_flds = filter bad_fld upd_flds1_w_tys + con1_tv_set = mkVarSet con1_tvs + bad_fld (fld, ty) = fld `elem` upd_fld_names && + not (tyVarsOfType ty `subVarSet` con1_tv_set) + ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds) + + -- STEP 4 Note [Type of a record update] + -- Figure out types for the scrutinee and result + -- Both are of form (T a b c), with fresh type variables, but with + -- common variables where the scrutinee and result must have the same type + -- These are variables that appear in *any* arg of *any* of the + -- relevant constructors *except* in the updated fields + -- + ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons + is_fixed_tv tv = tv `elemVarSet` fixed_tvs mk_inst_ty :: TvSubst -> (TKVar, TcType) -> TcM (TvSubst, TcType) -- Deals with instantiation of kind variables -- c.f. TcMType.tcInstTyVarsX - mk_inst_ty subst (tv, result_inst_ty) - | is_fixed_tv tv -- Same as result type + mk_inst_ty subst (tv, result_inst_ty) + | is_fixed_tv tv -- Same as result type = return (extendTvSubst subst tv result_inst_ty, result_inst_ty) - | otherwise -- Fresh type, of correct kind + | otherwise -- Fresh type, of correct kind = do { new_ty <- newFlexiTyVarTy (TcType.substTy subst (tyVarKind tv)) ; return (extendTvSubst subst tv new_ty, new_ty) } - ; (_, result_inst_tys, result_subst) <- tcInstTyVars con1_tvs + ; (_, result_inst_tys, result_subst) <- tcInstTyVars con1_tvs - ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty emptyTvSubst - (con1_tvs `zip` result_inst_tys) + ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty emptyTvSubst + (con1_tvs `zip` result_inst_tys) - ; let rec_res_ty = TcType.substTy result_subst con1_res_ty - scrut_ty = TcType.substTy scrut_subst con1_res_ty - con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys + ; let rec_res_ty = TcType.substTy result_subst con1_res_ty + scrut_ty = TcType.substTy scrut_subst con1_res_ty + con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys ; co_res <- unifyType rec_res_ty res_ty - -- STEP 5 - -- Typecheck the thing to be updated, and the bindings - ; record_expr' <- tcMonoExpr record_expr scrut_ty - ; rbinds' <- tcRecordBinds con1 con1_arg_tys' rbinds - - -- STEP 6: Deal with the stupid theta - ; let theta' = substTheta scrut_subst (dataConStupidTheta con1) - ; instStupidTheta RecordUpdOrigin theta' - - -- Step 7: make a cast for the scrutinee, in the case that it's from a type family - ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon - = WpCast (mkTcUnbranchedAxInstCo co_con scrut_inst_tys) - | otherwise - = idHsWrapper - -- Phew! + -- STEP 5 + -- Typecheck the thing to be updated, and the bindings + ; record_expr' <- tcMonoExpr record_expr scrut_ty + ; rbinds' <- tcRecordBinds con1 con1_arg_tys' rbinds + + -- STEP 6: Deal with the stupid theta + ; let theta' = substTheta scrut_subst (dataConStupidTheta con1) + ; instStupidTheta RecordUpdOrigin theta' + + -- Step 7: make a cast for the scrutinee, in the case that it's from a type family + ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon + = WpCast (mkTcUnbranchedAxInstCo co_con scrut_inst_tys) + | otherwise + = idHsWrapper + -- Phew! ; return $ mkHsWrapCo co_res $ RecordUpd (mkLHsWrap scrut_co record_expr') rbinds' - relevant_cons scrut_inst_tys result_inst_tys } + relevant_cons scrut_inst_tys result_inst_tys } where upd_fld_names = hsRecFields rbinds @@ -738,28 +734,28 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty -- These tyvars must not change across the updates getFixedTyVars tvs1 cons = mkVarSet [tv1 | con <- cons - , let (tvs, theta, arg_tys, _) = dataConSig con - flds = dataConFieldLabels con - fixed_tvs = exactTyVarsOfTypes fixed_tys - -- fixed_tys: See Note [Type of a record update] - `unionVarSet` tyVarsOfTypes theta - -- Universally-quantified tyvars that - -- appear in any of the *implicit* - -- arguments to the constructor are fixed - -- See Note [Implict type sharing] - - fixed_tys = [ty | (fld,ty) <- zip flds arg_tys + , let (tvs, theta, arg_tys, _) = dataConSig con + flds = dataConFieldLabels con + fixed_tvs = exactTyVarsOfTypes fixed_tys + -- fixed_tys: See Note [Type of a record update] + `unionVarSet` tyVarsOfTypes theta + -- Universally-quantified tyvars that + -- appear in any of the *implicit* + -- arguments to the constructor are fixed + -- See Note [Implict type sharing] + + fixed_tys = [ty | (fld,ty) <- zip flds arg_tys , not (fld `elem` upd_fld_names)] - , (tv1,tv) <- tvs1 `zip` tvs -- Discards existentials in tvs - , tv `elemVarSet` fixed_tvs ] + , (tv1,tv) <- tvs1 `zip` tvs -- Discards existentials in tvs + , tv `elemVarSet` fixed_tvs ] \end{code} %************************************************************************ -%* * - Arithmetic sequences e.g. [a,b..] - and their parallel-array counterparts e.g. [: a,b.. :] - -%* * +%* * + Arithmetic sequences e.g. [a,b..] + and their parallel-array counterparts e.g. [: a,b.. :] + +%* * %************************************************************************ \begin{code} @@ -767,27 +763,27 @@ tcExpr (ArithSeq _ witness seq) res_ty = tcArithSeq witness seq res_ty tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty - = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; enumFromToP <- initDsTc $ dsDPHBuiltin enumFromToPVar - ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq) - (idName enumFromToP) elt_ty - ; return $ mkHsWrapCo coi + = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty + ; expr1' <- tcPolyExpr expr1 elt_ty + ; expr2' <- tcPolyExpr expr2 elt_ty + ; enumFromToP <- initDsTc $ dsDPHBuiltin enumFromToPVar + ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq) + (idName enumFromToP) elt_ty + ; return $ mkHsWrapCo coi (PArrSeq enum_from_to (FromTo expr1' expr2')) } tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty - = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty - ; expr1' <- tcPolyExpr expr1 elt_ty - ; expr2' <- tcPolyExpr expr2 elt_ty - ; expr3' <- tcPolyExpr expr3 elt_ty - ; enumFromThenToP <- initDsTc $ dsDPHBuiltin enumFromThenToPVar - ; eft <- newMethodFromName (PArrSeqOrigin seq) - (idName enumFromThenToP) elt_ty -- !!!FIXME: chak - ; return $ mkHsWrapCo coi + = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty + ; expr1' <- tcPolyExpr expr1 elt_ty + ; expr2' <- tcPolyExpr expr2 elt_ty + ; expr3' <- tcPolyExpr expr3 elt_ty + ; enumFromThenToP <- initDsTc $ dsDPHBuiltin enumFromThenToPVar + ; eft <- newMethodFromName (PArrSeqOrigin seq) + (idName enumFromThenToP) elt_ty -- !!!FIXME: chak + ; return $ mkHsWrapCo coi (PArrSeq eft (FromThenTo expr1' expr2' expr3')) } -tcExpr (PArrSeq _ _) _ +tcExpr (PArrSeq _ _) _ = panic "TcExpr.tcExpr: Infinite parallel array!" -- the parser shouldn't have generated it and the renamer shouldn't have -- let it through @@ -795,14 +791,14 @@ tcExpr (PArrSeq _ _) _ %************************************************************************ -%* * - Template Haskell -%* * +%* * + Template Haskell +%* * %************************************************************************ \begin{code} -#ifdef GHCI /* Only if bootstrapped */ - -- Rename excludes these cases otherwise +#ifdef GHCI /* Only if bootstrapped */ + -- Rename excludes these cases otherwise tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty tcExpr (HsBracket brack) res_ty = tcBracket brack res_ty tcExpr e@(HsQuasiQuoteE _) _ = @@ -812,9 +808,9 @@ tcExpr e@(HsQuasiQuoteE _) _ = %************************************************************************ -%* * - Catch-all -%* * +%* * + Catch-all +%* * %************************************************************************ \begin{code} @@ -824,9 +820,9 @@ tcExpr other _ = pprPanic "tcMonoExpr" (ppr other) %************************************************************************ -%* * - Arithmetic sequences [a..b] etc -%* * +%* * + Arithmetic sequences [a..b] etc +%* * %************************************************************************ \begin{code} @@ -836,24 +832,24 @@ tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> TcRhoType tcArithSeq witness seq@(From expr) res_ty = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty ; expr' <- tcPolyExpr expr elt_ty - ; enum_from <- newMethodFromName (ArithSeqOrigin seq) - enumFromName elt_ty + ; enum_from <- newMethodFromName (ArithSeqOrigin seq) + enumFromName elt_ty ; return $ mkHsWrapCo coi (ArithSeq enum_from wit' (From expr')) } - + tcArithSeq witness seq@(FromThen expr1 expr2) res_ty = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty - ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) - enumFromThenName elt_ty + ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) + enumFromThenName elt_ty ; return $ mkHsWrapCo coi (ArithSeq enum_from_then wit' (FromThen expr1' expr2')) } - + tcArithSeq witness seq@(FromTo expr1 expr2) res_ty = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty - ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) - enumFromToName elt_ty + ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) + enumFromToName elt_ty ; return $ mkHsWrapCo coi (ArithSeq enum_from_to wit' (FromTo expr1' expr2')) } tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty @@ -861,12 +857,12 @@ tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; expr3' <- tcPolyExpr expr3 elt_ty - ; eft <- newMethodFromName (ArithSeqOrigin seq) - enumFromThenToName elt_ty + ; eft <- newMethodFromName (ArithSeqOrigin seq) + enumFromThenToName elt_ty ; return $ mkHsWrapCo coi (ArithSeq eft wit' (FromThenTo expr1' expr2' expr3')) } ----------------- -arithSeqEltType :: Maybe (SyntaxExpr Name) -> TcRhoType +arithSeqEltType :: Maybe (SyntaxExpr Name) -> TcRhoType -> TcM (TcCoercion, TcType, Maybe (SyntaxExpr Id)) arithSeqEltType Nothing res_ty = do { (coi, elt_ty) <- matchExpectedListTy res_ty @@ -879,9 +875,9 @@ arithSeqEltType (Just fl) res_ty \end{code} %************************************************************************ -%* * - Applications -%* * +%* * + Applications +%* * %************************************************************************ \begin{code} @@ -892,7 +888,7 @@ tcApp (L _ (HsPar e)) args res_ty = tcApp e args res_ty tcApp (L _ (HsApp e1 e2)) args res_ty - = tcApp e1 (e2:args) res_ty -- Accumulate the arguments + = tcApp e1 (e2:args) res_ty -- Accumulate the arguments tcApp (L loc (HsVar fun)) args res_ty | fun `hasKey` tagToEnumKey @@ -904,24 +900,24 @@ tcApp (L loc (HsVar fun)) args res_ty = tcSeq loc fun arg1 arg2 res_ty tcApp fun args res_ty - = do { -- Type-check the function - ; (fun1, fun_tau) <- tcInferFun fun + = do { -- Type-check the function + ; (fun1, fun_tau) <- tcInferFun fun - -- Extract its argument types - ; (co_fun, expected_arg_tys, actual_res_ty) - <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau + -- Extract its argument types + ; (co_fun, expected_arg_tys, actual_res_ty) + <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau - -- Typecheck the result, thereby propagating + -- Typecheck the result, thereby propagating -- info (if any) from result into the argument types -- Both actual_res_ty and res_ty are deeply skolemised - ; co_res <- addErrCtxtM (funResCtxt fun actual_res_ty res_ty) $ + ; co_res <- addErrCtxtM (funResCtxt True (unLoc fun) actual_res_ty res_ty) $ unifyType actual_res_ty res_ty - -- Typecheck the arguments - ; args1 <- tcArgs fun args expected_arg_tys + -- Typecheck the arguments + ; args1 <- tcArgs fun args expected_arg_tys -- Assemble the result - ; let fun2 = mkLHsWrapCo co_fun fun1 + ; let fun2 = mkLHsWrapCo co_fun fun1 app = mkLHsWrapCo co_res (foldl mkHsApp fun2 args1) ; return (unLoc app) } @@ -940,60 +936,60 @@ tcInferApp (L _ (HsApp e1 e2)) args = tcInferApp e1 (e2:args) tcInferApp fun args = -- Very like the tcApp version, except that there is -- no expected result type passed in - do { (fun1, fun_tau) <- tcInferFun fun - ; (co_fun, expected_arg_tys, actual_res_ty) - <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau - ; args1 <- tcArgs fun args expected_arg_tys - ; let fun2 = mkLHsWrapCo co_fun fun1 + do { (fun1, fun_tau) <- tcInferFun fun + ; (co_fun, expected_arg_tys, actual_res_ty) + <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau + ; args1 <- tcArgs fun args expected_arg_tys + ; let fun2 = mkLHsWrapCo co_fun fun1 app = foldl mkHsApp fun2 args1 ; return (unLoc app, actual_res_ty) } ---------------- tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) -- Infer and instantiate the type of a function -tcInferFun (L loc (HsVar name)) +tcInferFun (L loc (HsVar name)) = do { (fun, ty) <- setSrcSpan loc (tcInferId name) - -- Don't wrap a context around a plain Id + -- Don't wrap a context around a plain Id ; return (L loc fun, ty) } tcInferFun fun = do { (fun, fun_ty) <- tcInfer (tcMonoExpr fun) -- Zonk the function type carefully, to expose any polymorphism - -- E.g. (( \(x::forall a. a->a). blah ) e) - -- We can see the rank-2 type of the lambda in time to genrealise e + -- E.g. (( \(x::forall a. a->a). blah ) e) + -- We can see the rank-2 type of the lambda in time to genrealise e ; fun_ty' <- zonkTcType fun_ty ; (wrap, rho) <- deeplyInstantiate AppOrigin fun_ty' ; return (mkLHsWrap wrap fun, rho) } ---------------- -tcArgs :: LHsExpr Name -- The function (for error messages) - -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types - -> TcM [LHsExpr TcId] -- Resulting args +tcArgs :: LHsExpr Name -- The function (for error messages) + -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types + -> TcM [LHsExpr TcId] -- Resulting args tcArgs fun args expected_arg_tys = mapM (tcArg fun) (zip3 args expected_arg_tys [1..]) ---------------- -tcArg :: LHsExpr Name -- The function (for error messages) - -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type - -> TcM (LHsExpr TcId) -- Resulting argument +tcArg :: LHsExpr Name -- The function (for error messages) + -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type + -> TcM (LHsExpr TcId) -- Resulting argument tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) - (tcPolyExprNC arg ty) + (tcPolyExprNC arg ty) ---------------- tcTupArgs :: [HsTupArg Name] -> [TcSigmaType] -> TcM [HsTupArg TcId] -tcTupArgs args tys +tcTupArgs args tys = ASSERT( equalLength args tys ) mapM go (args `zip` tys) where go (Missing {}, arg_ty) = return (Missing arg_ty) go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty - ; return (Present expr') } + ; return (Present expr') } ---------------- unifyOpFunTysWrap :: LHsExpr Name -> Arity -> TcRhoType - -> TcM (TcCoercion, [TcSigmaType], TcRhoType) + -> TcM (TcCoercion, [TcSigmaType], TcRhoType) -- A wrapper for matchExpectedFunTys unifyOpFunTysWrap op arity ty = matchExpectedFunTys herald arity ty where @@ -1006,7 +1002,7 @@ tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId) -- This version assumes res_ty is a monotype tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig op ; tcWrapResult expr rho res_ty } -tcSyntaxOp _ other _ = pprPanic "tcSyntaxOp" (ppr other) +tcSyntaxOp _ other _ = pprPanic "tcSyntaxOp" (ppr other) \end{code} @@ -1015,8 +1011,8 @@ Note [Push result type in] Unify with expected result before type-checking the args so that the info from res_ty percolates to args. This is when we might detect a too-few args situation. (One can think of cases when the opposite -order would give a better error message.) -experimenting with putting this first. +order would give a better error message.) +experimenting with putting this first. Here's an example where it actually makes a real difference @@ -1036,15 +1032,17 @@ in the other order, the extra signature in f2 is reqd. %************************************************************************ -%* * +%* * tcInferId -%* * +%* * %************************************************************************ \begin{code} tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId) -tcCheckId name res_ty = do { (expr, rho) <- tcInferId name - ; tcWrapResult expr rho res_ty } +tcCheckId name res_ty + = do { (expr, actual_res_ty) <- tcInferId name + ; addErrCtxtM (funResCtxt False (HsVar name) actual_res_ty res_ty) $ + tcWrapResult expr actual_res_ty res_ty } ------------------------ tcInferId :: Name -> TcM (HsExpr TcId, TcRhoType) @@ -1062,29 +1060,29 @@ tcInferIdWithOrig orig id_name ; return (mkHsWrap wrap id_expr, rho) } where lookup_id :: TcM TcId - lookup_id + lookup_id = do { thing <- tcLookup id_name - ; case thing of - ATcId { tct_id = id, tct_level = lvl } - -> do { check_naughty id -- Note [Local record selectors] + ; case thing of + ATcId { tct_id = id, tct_level = lvl } + -> do { check_naughty id -- Note [Local record selectors] ; checkThLocalId id lvl ; return id } - AGlobal (AnId id) + AGlobal (AnId id) -> do { check_naughty id; return id } - -- A global cannot possibly be ill-staged - -- nor does it need the 'lifting' treatment + -- A global cannot possibly be ill-staged + -- nor does it need the 'lifting' treatment -- hence no checkTh stuff here - AGlobal (ADataCon con) -> return (dataConWrapId con) + AGlobal (ADataCon con) -> return (dataConWrapId con) - other -> failWithTc (bad_lookup other) } + other -> failWithTc (bad_lookup other) } bad_lookup thing = ppr thing <+> ptext (sLit "used where a value identifer was expected") - check_naughty id + check_naughty id | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id) - | otherwise = return () + | otherwise = return () ------------------------ instantiateOuter :: CtOrigin -> TcId -> TcM (HsExpr TcId, TcSigmaType) @@ -1113,20 +1111,20 @@ Note [Multiple instantiation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We are careful never to make a MethodInst that has, as its meth_id, another MethodInst. For example, consider - f :: forall a. Eq a => forall b. Ord b => a -> b -At a call to f, at say [Int, Bool], it's tempting to translate the call to + f :: forall a. Eq a => forall b. Ord b => a -> b +At a call to f, at say [Int, Bool], it's tempting to translate the call to - f_m1 + f_m1 where - f_m1 :: forall b. Ord b => Int -> b - f_m1 = f Int dEqInt + f_m1 :: forall b. Ord b => Int -> b + f_m1 = f Int dEqInt - f_m2 :: Int -> Bool - f_m2 = f_m1 Bool dOrdBool + f_m2 :: Int -> Bool + f_m2 = f_m1 Bool dOrdBool But notice that f_m2 has f_m1 as its meth_id. Now the danger is that if we do a tcSimplCheck with a Given f_mx :: f Int dEqInt, we may make a binding - f_m1 = f_mx + f_m1 = f_mx But it's entirely possible that f_m2 will continue to float out, because it mentions no type variables. Result, f_m1 isn't in scope. @@ -1144,8 +1142,8 @@ application, not for the iterated ones. A horribly subtle point. \begin{code} doStupidChecks :: TcId - -> [TcType] - -> TcM () + -> [TcType] + -> TcM () -- Check two tiresome and ad-hoc cases -- (a) the "stupid theta" for a data con; add the constraints -- from the "stupid theta" of a data constructor (sigh) @@ -1156,7 +1154,7 @@ doStupidChecks fun_id tys | fun_id `hasKey` tagToEnumKey -- (b) = failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument")) - + | otherwise = return () -- The common case \end{code} @@ -1168,33 +1166,33 @@ enumeration TyCon. Unification may refine the type later, but this check won't see that, alas. It's crude, because it relies on our knowing *now* that the type is ok, which in turn relies on the eager-unification part of the type checker pushing enough information -here. In theory the Right Thing to do is to have a new form of +here. In theory the Right Thing to do is to have a new form of constraint but I definitely cannot face that! And it works ok as-is. Here's are two cases that should fail - f :: forall a. a - f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable + f :: forall a. a + f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable - g :: Int - g = tagToEnum# 0 -- Int is not an enumeration + g :: Int + g = tagToEnum# 0 -- Int is not an enumeration When data type families are involved it's a bit more complicated. data family F a data instance F [Int] = A | B | C Then we want to generate something like tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int] -Usually that coercion is hidden inside the wrappers for +Usually that coercion is hidden inside the wrappers for constructors of F [Int] but here we have to do it explicitly. It's all grotesquely complicated. \begin{code} -tcSeq :: SrcSpan -> Name -> LHsExpr Name -> LHsExpr Name +tcSeq :: SrcSpan -> Name -> LHsExpr Name -> LHsExpr Name -> TcRhoType -> TcM (HsExpr TcId) -- (seq e1 e2) :: res_ty -- We need a special typing rule because res_ty can be unboxed tcSeq loc fun_name arg1 arg2 res_ty - = do { fun <- tcLookupId fun_name + = do { fun <- tcLookupId fun_name ; (arg1', arg1_ty) <- tcInfer (tcMonoExpr arg1) ; arg2' <- tcMonoExpr arg2 res_ty ; let fun' = L loc (HsWrap ty_args (HsVar fun)) @@ -1205,47 +1203,46 @@ tcTagToEnum :: SrcSpan -> Name -> LHsExpr Name -> TcRhoType -> TcM (HsExpr TcId) -- tagToEnum# :: forall a. Int# -> a -- See Note [tagToEnum#] Urgh! tcTagToEnum loc fun_name arg res_ty - = do { fun <- tcLookupId fun_name + = do { fun <- tcLookupId fun_name ; ty' <- zonkTcType res_ty - -- Check that the type is algebraic + -- Check that the type is algebraic ; let mb_tc_app = tcSplitTyConApp_maybe ty' Just (tc, tc_args) = mb_tc_app - ; checkTc (isJust mb_tc_app) + ; checkTc (isJust mb_tc_app) (tagToEnumError ty' doc1) - -- Look through any type family + -- Look through any type family ; (coi, rep_tc, rep_args) <- get_rep_ty ty' tc tc_args - ; checkTc (isEnumerationTyCon rep_tc) + ; checkTc (isEnumerationTyCon rep_tc) (tagToEnumError ty' doc2) ; arg' <- tcMonoExpr arg intPrimTy ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun)) rep_ty = mkTyConApp rep_tc rep_args - ; return (mkHsWrapCo coi $ HsApp fun' arg') } + ; return (mkHsWrapCo coi $ HsApp fun' arg') } where doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature") - , ptext (sLit "e.g. (tagToEnum# x) :: Bool") ] + , ptext (sLit "e.g. (tagToEnum# x) :: Bool") ] doc2 = ptext (sLit "Result type must be an enumeration type") doc3 = ptext (sLit "No family instance for this type") get_rep_ty :: TcType -> TyCon -> [TcType] -> TcM (TcCoercion, TyCon, [TcType]) - -- Converts a family type (eg F [a]) to its rep type (eg FList a) - -- and returns a coercion between the two + -- Converts a family type (eg F [a]) to its rep type (eg FList a) + -- and returns a coercion between the two get_rep_ty ty tc tc_args - | not (isFamilyTyCon tc) + | not (isFamilyTyCon tc) = return (mkTcReflCo ty, tc, tc_args) - | otherwise + | otherwise = do { mb_fam <- tcLookupFamInst tc tc_args - ; case mb_fam of - Nothing -> failWithTc (tagToEnumError ty doc3) + ; case mb_fam of + Nothing -> failWithTc (tagToEnumError ty doc3) Just (FamInstMatch { fim_instance = rep_fam - , fim_index = index , fim_tys = rep_args }) - -> return ( mkTcSymCo (mkTcAxInstCo co_tc index rep_args) + -> return ( mkTcSymCo (mkTcUnbranchedAxInstCo co_tc rep_args) , rep_tc, rep_args ) where co_tc = famInstAxiom rep_fam @@ -1253,16 +1250,16 @@ tcTagToEnum loc fun_name arg res_ty tagToEnumError :: TcType -> SDoc -> SDoc tagToEnumError ty what - = hang (ptext (sLit "Bad call to tagToEnum#") - <+> ptext (sLit "at type") <+> ppr ty) - 2 what + = hang (ptext (sLit "Bad call to tagToEnum#") + <+> ptext (sLit "at type") <+> ppr ty) + 2 what \end{code} %************************************************************************ -%* * +%* * Template Haskell checks -%* * +%* * %************************************************************************ \begin{code} @@ -1273,73 +1270,73 @@ checkThLocalId :: Id -> ThLevel -> TcM () checkThLocalId _id _bind_lvl = return () -#else /* GHCI and TH is on */ -checkThLocalId id bind_lvl - = do { use_stage <- getStage -- TH case - ; let use_lvl = thLevel use_stage - ; checkWellStaged (quotes (ppr id)) bind_lvl use_lvl - ; traceTc "thLocalId" (ppr id <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl) - ; when (use_lvl > bind_lvl) $ +#else /* GHCI and TH is on */ +checkThLocalId id bind_lvl + = do { use_stage <- getStage -- TH case + ; let use_lvl = thLevel use_stage + ; checkWellStaged (quotes (ppr id)) bind_lvl use_lvl + ; traceTc "thLocalId" (ppr id <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl) + ; when (use_lvl > bind_lvl) $ checkCrossStageLifting id bind_lvl use_stage } -------------------------------------- checkCrossStageLifting :: Id -> ThLevel -> ThStage -> TcM () -- We are inside brackets, and (use_lvl > bind_lvl) -- Now we must check whether there's a cross-stage lift to do --- Examples \x -> [| x |] +-- Examples \x -> [| x |] -- [| map |] checkCrossStageLifting _ _ Comp = return () checkCrossStageLifting _ _ Splice = return () -checkCrossStageLifting id _ (Brack _ ps_var lie_var) +checkCrossStageLifting id _ (Brack _ ps_var lie_var) | thTopLevelId id - = -- Top-level identifiers in this module, - -- (which have External Names) - -- are just like the imported case: - -- no need for the 'lifting' treatment - -- E.g. this is fine: - -- f x = x - -- g y = [| f 3 |] - -- But we do need to put f into the keep-alive - -- set, because after desugaring the code will - -- only mention f's *name*, not f itself. + = -- Top-level identifiers in this module, + -- (which have External Names) + -- are just like the imported case: + -- no need for the 'lifting' treatment + -- E.g. this is fine: + -- f x = x + -- g y = [| f 3 |] + -- But we do need to put f into the keep-alive + -- set, because after desugaring the code will + -- only mention f's *name*, not f itself. keepAliveTc id - | otherwise -- bind_lvl = outerLevel presumably, - -- but the Id is not bound at top level - = -- Nested identifiers, such as 'x' in - -- E.g. \x -> [| h x |] - -- We must behave as if the reference to x was - -- h $(lift x) - -- We use 'x' itself as the splice proxy, used by - -- the desugarer to stitch it all back together. - -- If 'x' occurs many times we may get many identical - -- bindings of the same splice proxy, but that doesn't - -- matter, although it's a mite untidy. - do { let id_ty = idType id + | otherwise -- bind_lvl = outerLevel presumably, + -- but the Id is not bound at top level + = -- Nested identifiers, such as 'x' in + -- E.g. \x -> [| h x |] + -- We must behave as if the reference to x was + -- h $(lift x) + -- We use 'x' itself as the splice proxy, used by + -- the desugarer to stitch it all back together. + -- If 'x' occurs many times we may get many identical + -- bindings of the same splice proxy, but that doesn't + -- matter, although it's a mite untidy. + do { let id_ty = idType id ; checkTc (isTauTy id_ty) (polySpliceErr id) - -- If x is polymorphic, its occurrence sites might - -- have different instantiations, so we can't use plain - -- 'x' as the splice proxy name. I don't know how to - -- solve this, and it's probably unimportant, so I'm - -- just going to flag an error for now - - ; lift <- if isStringTy id_ty then - do { sid <- tcLookupId DsMeta.liftStringName - -- See Note [Lifting strings] + -- If x is polymorphic, its occurrence sites might + -- have different instantiations, so we can't use plain + -- 'x' as the splice proxy name. I don't know how to + -- solve this, and it's probably unimportant, so I'm + -- just going to flag an error for now + + ; lift <- if isStringTy id_ty then + do { sid <- tcLookupId DsMeta.liftStringName + -- See Note [Lifting strings] ; return (HsVar sid) } - else - setConstraintVar lie_var $ do - -- Put the 'lift' constraint into the right LIE - newMethodFromName (OccurrenceOf (idName id)) + else + setConstraintVar lie_var $ do + -- Put the 'lift' constraint into the right LIE + newMethodFromName (OccurrenceOf (idName id)) DsMeta.liftName id_ty - - -- Update the pending splices - ; ps <- readMutVar ps_var - ; writeMutVar ps_var ((idName id, nlHsApp (noLoc lift) (nlHsVar id)) : ps) - ; return () } + -- Update the pending splices + ; ps <- readMutVar ps_var + ; writeMutVar ps_var ((idName id, nlHsApp (noLoc lift) (nlHsVar id)) : ps) + + ; return () } #endif /* GHCI */ \end{code} @@ -1350,10 +1347,10 @@ generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc. So this conditional short-circuits the lifting mechanism to generate (liftString "xy") in that case. I didn't want to use overlapping instances for the Lift class in TH.Syntax, because that can lead to overlapping-instance -errors in a polymorphic situation. +errors in a polymorphic situation. If this check fails (which isn't impossible) we get another chance; see -Note [Converting strings] in Convert.lhs +Note [Converting strings] in Convert.lhs Local record selectors ~~~~~~~~~~~~~~~~~~~~~~ @@ -1363,9 +1360,9 @@ naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds. %************************************************************************ -%* * +%* * \subsection{Record bindings} -%* * +%* * %************************************************************************ Game plan for record bindings @@ -1379,84 +1376,84 @@ For each binding field = value 3. Instantiate the field type (from the field label) using the type envt from step 2. -4 Type check the value using tcArg, passing the field type as +4 Type check the value using tcArg, passing the field type as the expected argument type. This extends OK when the field types are universally quantified. - + \begin{code} tcRecordBinds - :: DataCon - -> [TcType] -- Expected type for each field - -> HsRecordBinds Name - -> TcM (HsRecordBinds TcId) + :: DataCon + -> [TcType] -- Expected type for each field + -> HsRecordBinds Name + -> TcM (HsRecordBinds TcId) tcRecordBinds data_con arg_tys (HsRecFields rbinds dd) - = do { mb_binds <- mapM do_bind rbinds - ; return (HsRecFields (catMaybes mb_binds) dd) } + = do { mb_binds <- mapM do_bind rbinds + ; return (HsRecFields (catMaybes mb_binds) dd) } where flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs }) | Just field_ty <- assocMaybe flds_w_tys field_lbl - = addErrCtxt (fieldCtxt field_lbl) $ - do { rhs' <- tcPolyExprNC rhs field_ty - ; let field_id = mkUserLocal (nameOccName field_lbl) - (nameUnique field_lbl) - field_ty loc - -- Yuk: the field_id has the *unique* of the selector Id - -- (so we can find it easily) - -- but is a LocalId with the appropriate type of the RHS - -- (so the desugarer knows the type of local binder to make) - ; return (Just (fld { hsRecFieldId = L loc field_id, hsRecFieldArg = rhs' })) } + = addErrCtxt (fieldCtxt field_lbl) $ + do { rhs' <- tcPolyExprNC rhs field_ty + ; let field_id = mkUserLocal (nameOccName field_lbl) + (nameUnique field_lbl) + field_ty loc + -- Yuk: the field_id has the *unique* of the selector Id + -- (so we can find it easily) + -- but is a LocalId with the appropriate type of the RHS + -- (so the desugarer knows the type of local binder to make) + ; return (Just (fld { hsRecFieldId = L loc field_id, hsRecFieldArg = rhs' })) } | otherwise = do { addErrTc (badFieldCon data_con field_lbl) - ; return Nothing } + ; return Nothing } checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM () checkMissingFields data_con rbinds - | null field_labels -- Not declared as a record; - -- But C{} is still valid if no strict fields + | null field_labels -- Not declared as a record; + -- But C{} is still valid if no strict fields = if any isBanged field_strs then - -- Illegal if any arg is strict - addErrTc (missingStrictFields data_con []) + -- Illegal if any arg is strict + addErrTc (missingStrictFields data_con []) else - return () - - | otherwise = do -- A record + return () + + | otherwise = do -- A record unless (null missing_s_fields) - (addErrTc (missingStrictFields data_con missing_s_fields)) + (addErrTc (missingStrictFields data_con missing_s_fields)) warn <- woptM Opt_WarnMissingFields unless (not (warn && notNull missing_ns_fields)) - (warnTc True (missingFields data_con missing_ns_fields)) + (warnTc True (missingFields data_con missing_ns_fields)) where missing_s_fields - = [ fl | (fl, str) <- field_info, - isBanged str, - not (fl `elem` field_names_used) - ] + = [ fl | (fl, str) <- field_info, + isBanged str, + not (fl `elem` field_names_used) + ] missing_ns_fields - = [ fl | (fl, str) <- field_info, - not (isBanged str), - not (fl `elem` field_names_used) - ] + = [ fl | (fl, str) <- field_info, + not (isBanged str), + not (fl `elem` field_names_used) + ] field_names_used = hsRecFields rbinds field_labels = dataConFieldLabels data_con field_info = zipEqual "missingFields" - field_labels - field_strs + field_labels + field_strs field_strs = dataConStrictMarks data_con \end{code} %************************************************************************ -%* * +%* * \subsection{Errors and contexts} -%* * +%* * %************************************************************************ Boring and alphabetical: @@ -1474,43 +1471,126 @@ fieldCtxt field_name funAppCtxt :: LHsExpr Name -> LHsExpr Name -> Int -> SDoc funAppCtxt fun arg arg_no - = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"), - quotes (ppr fun) <> text ", namely"]) + = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"), + quotes (ppr fun) <> text ", namely"]) 2 (quotes (ppr arg)) -funResCtxt :: LHsExpr Name -> TcType -> TcType +funResCtxt :: Bool -- There is at least one argument + -> HsExpr Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) -- When we have a mis-match in the return type of a function -- try to give a helpful message about too many/few arguments -funResCtxt fun fun_res_ty res_ty env0 +-- +-- Used for naked variables too; but with has_args = False +funResCtxt has_args fun fun_res_ty env_ty tidy_env = do { fun_res' <- zonkTcType fun_res_ty - ; res' <- zonkTcType res_ty - ; let n_fun = length (fst (tcSplitFunTys fun_res')) - n_res = length (fst (tcSplitFunTys res')) - what | n_fun > n_res = ptext (sLit "few") - | otherwise = ptext (sLit "many") - extra | n_fun == n_res = empty - | otherwise = ptext (sLit "Probable cause:") <+> quotes (ppr fun) - <+> ptext (sLit "is applied to too") <+> what - <+> ptext (sLit "arguments") - msg = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun) - ; return (env0, msg $$ extra) } + ; env' <- zonkTcType env_ty + ; let (args_fun, res_fun) = tcSplitFunTys fun_res' + (args_env, res_env) = tcSplitFunTys env' + n_fun = length args_fun + n_env = length args_env + info | n_fun == n_env = empty + | n_fun > n_env + , not_fun res_env = ptext (sLit "Probable cause:") <+> quotes (ppr fun) + <+> ptext (sLit "is applied to too few arguments") + | has_args + , not_fun res_fun = ptext (sLit "Possible cause:") <+> quotes (ppr fun) + <+> ptext (sLit "is applied to too many arguments") + | otherwise = empty -- Never suggest that a naked variable is + -- applied to too many args! + ; return (tidy_env, info) } + where + not_fun ty -- ty is definitely not an arrow type, + -- and cannot conceivably become one + = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> isAlgTyCon tc + Nothing -> False badFieldTypes :: [(Name,TcType)] -> SDoc badFieldTypes prs = hang (ptext (sLit "Record update for insufficiently polymorphic field") - <> plural prs <> colon) + <> plural prs <> colon) 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) -badFieldsUpd :: HsRecFields Name a -> SDoc -badFieldsUpd rbinds +badFieldsUpd + :: HsRecFields Name a -- Field names that don't belong to a single datacon + -> [DataCon] -- Data cons of the type which the first field name belongs to + -> SDoc +badFieldsUpd rbinds data_cons = hang (ptext (sLit "No constructor has all these fields:")) - 2 (pprQuotedList (hsRecFields rbinds)) + 2 (pprQuotedList conflictingFields) + -- See Note [Finding the conflicting fields] + where + -- A (preferably small) set of fields such that no constructor contains + -- all of them. See Note [Finding the conflicting fields] + conflictingFields = case nonMembers of + -- nonMember belongs to a different type. + (nonMember, _) : _ -> [aMember, nonMember] + [] -> let + -- All of rbinds belong to one type. In this case, repeatedly add + -- a field to the set until no constructor contains the set. + + -- Each field, together with a list indicating which constructors + -- have all the fields so far. + growingSets :: [(Name, [Bool])] + growingSets = scanl1 combine membership + combine (_, setMem) (field, fldMem) + = (field, zipWith (&&) setMem fldMem) + in + -- Fields that don't change the membership status of the set + -- are redundant and can be dropped. + map (fst . head) $ groupBy ((==) `on` snd) growingSets + + aMember = ASSERT( not (null members) ) fst (head members) + (members, nonMembers) = partition (or . snd) membership + + -- For each field, which constructors contain the field? + membership :: [(Name, [Bool])] + membership = sortMembership $ + map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $ + hsRecFields rbinds + + fieldLabelSets :: [Set.Set Name] + fieldLabelSets = map (Set.fromList . dataConFieldLabels) data_cons + + -- Sort in order of increasing number of True, so that a smaller + -- conflicting set can be found. + sortMembership = + map snd . + sortBy (compare `on` fst) . + map (\ item@(_, membershipRow) -> (countTrue membershipRow, item)) + + countTrue = length . filter id +\end{code} +Note [Finding the conflicting fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + data A = A {a0, a1 :: Int} + | B {b0, b1 :: Int} +and we see a record update + x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 } +Then we'd like to find the smallest subset of fields that no +constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc. +We don't really want to report that no constructor has all of +{a0,a1,b0,b1}, because when there are hundreds of fields it's +hard to see what was really wrong. + +We may need more than two fields, though; eg + data T = A { x,y :: Int, v::Int } + | B { y,z :: Int, v::Int } + | C { z,x :: Int, v::Int } +with update + r { x=e1, y=e2, z=e3 }, we + +Finding the smallest subset is hard, so the code here makes +a decent stab, no more. See Trac #7989. + +\begin{code} naughtyRecordSel :: TcId -> SDoc naughtyRecordSel sel_id - = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+> - ptext (sLit "as a function due to escaped type variables") $$ + = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+> + ptext (sLit "as a function due to escaped type variables") $$ ptext (sLit "Probable fix: use pattern-matching syntax instead") notSelector :: Name -> SDoc @@ -1521,17 +1601,17 @@ missingStrictFields :: DataCon -> [FieldLabel] -> SDoc missingStrictFields con fields = header <> rest where - rest | null fields = empty -- Happens for non-record constructors - -- with strict fields - | otherwise = colon <+> pprWithCommas ppr fields + rest | null fields = empty -- Happens for non-record constructors + -- with strict fields + | otherwise = colon <+> pprWithCommas ppr fields + + header = ptext (sLit "Constructor") <+> quotes (ppr con) <+> + ptext (sLit "does not have the required strict field(s)") - header = ptext (sLit "Constructor") <+> quotes (ppr con) <+> - ptext (sLit "does not have the required strict field(s)") - missingFields :: DataCon -> [FieldLabel] -> SDoc missingFields con fields - = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:") - <+> pprWithCommas ppr fields + = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:") + <+> pprWithCommas ppr fields -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args)) diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 630157ee79..9914f94c5f 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -63,84 +63,99 @@ isForeignExport (L _ (ForeignExport _ _ _ _)) = True isForeignExport _ = False \end{code} +Note [Don't recur in normaliseFfiType'] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +normaliseFfiType' is the workhorse for normalising a type used in a foreign +declaration. If we have + +newtype Age = MkAge Int + +we want to see that Age -> IO () is the same as Int -> IO (). But, we don't +need to recur on any type parameters, because no paramaterized types (with +interesting parameters) are marshalable! The full list of marshalable types +is in the body of boxedMarshalableTyCon in TcType. The only members of that +list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled +the same way regardless of type parameter. So, no need to recur into +parameters. + +Similarly, we don't need to look in AppTy's, because nothing headed by +an AppTy will be marshalable. + \begin{code} -- normaliseFfiType takes the type from an FFI declaration, and -- evaluates any type synonyms, type functions, and newtypes. However, -- we are only allowed to look through newtypes if the constructor is -- in scope. We return a bag of all the newtype constructors thus found. +-- Always returns a Representational coercion normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt) normaliseFfiType ty = do fam_envs <- tcGetFamInstEnvs normaliseFfiType' fam_envs ty normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) -normaliseFfiType' env ty0 = go [] ty0 +normaliseFfiType' env ty0 = go initRecTc ty0 where - go :: [TyCon] -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) + go :: RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt) go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms = go rec_nts ty' - go rec_nts (TyConApp tc tys) + go rec_nts ty@(TyConApp tc tys) -- We don't want to look through the IO newtype, even if it is -- in scope, so we have a special case for it: | tc_key `elem` [ioTyConKey, funPtrTyConKey] + -- Those *must* have R roles on their parameters! = children_only | isNewTyCon tc -- Expand newtypes + , Just rec_nts' <- checkRecTc rec_nts tc + -- See Note [Expanding newtypes] in TyCon.lhs + -- We can't just use isRecursiveTyCon; sometimes recursion is ok: + -- newtype T = T (Ptr T) + -- Here, we don't reject the type for being recursive. + -- If this is a recursive newtype then it will normally + -- be rejected later as not being a valid FFI type. = do { rdr_env <- getGlobalRdrEnv - ; case checkNewtypeFFI rdr_env rec_nts tc of - Nothing -> children_only + ; case checkNewtypeFFI rdr_env tc of + Nothing -> nothing Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs ; return (mkTransCo nt_co co', ty', gre `consBag` gres) } } | isFamilyTyCon tc -- Expand open tycons - , (co, ty) <- normaliseTcApp env tc tys + , (co, ty) <- normaliseTcApp env Representational tc tys , not (isReflCo co) = do (co', ty', gres) <- go rec_nts ty return (mkTransCo co co', ty', gres) | otherwise - = children_only + = nothing -- see Note [Don't recur in normaliseFfiType'] where tc_key = getUnique tc children_only = do xs <- mapM (go rec_nts) tys let (cos, tys', gres) = unzip3 xs - return (mkTyConAppCo tc cos, mkTyConApp tc tys', unionManyBags gres) - nt_co = mkUnbranchedAxInstCo (newTyConCo tc) tys + return ( mkTyConAppCo Representational tc cos + , mkTyConApp tc tys', unionManyBags gres) + nt_co = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys nt_rhs = newTyConInstRhs tc tys - - rec_nts' | isRecursiveTyCon tc = tc:rec_nts - | otherwise = rec_nts - - go rec_nts (AppTy ty1 ty2) - = do (coi1, nty1, gres1) <- go rec_nts ty1 - (coi2, nty2, gres2) <- go rec_nts ty2 - return (mkAppCo coi1 coi2, mkAppTy nty1 nty2, gres1 `unionBags` gres2) + nothing = return (Refl Representational ty, ty, emptyBag) go rec_nts (FunTy ty1 ty2) = do (coi1,nty1,gres1) <- go rec_nts ty1 (coi2,nty2,gres2) <- go rec_nts ty2 - return (mkFunCo coi1 coi2, mkFunTy nty1 nty2, gres1 `unionBags` gres2) + return (mkFunCo Representational coi1 coi2, mkFunTy nty1 nty2, gres1 `unionBags` gres2) go rec_nts (ForAllTy tyvar ty1) = do (coi,nty1,gres1) <- go rec_nts ty1 return (mkForAllCo tyvar coi, ForAllTy tyvar nty1, gres1) - go _ ty@(TyVarTy {}) = return (Refl ty, ty, emptyBag) - go _ ty@(LitTy {}) = return (Refl ty, ty, emptyBag) - + go _ ty@(TyVarTy {}) = return (Refl Representational ty, ty, emptyBag) + go _ ty@(LitTy {}) = return (Refl Representational ty, ty, emptyBag) + go _ ty@(AppTy {}) = return (Refl Representational ty, ty, emptyBag) + -- See Note [Don't recur in normaliseFfiType'] -checkNewtypeFFI :: GlobalRdrEnv -> [TyCon] -> TyCon -> Maybe GlobalRdrElt -checkNewtypeFFI rdr_env rec_nts tc - | not (tc `elem` rec_nts) - -- See Note [Expanding newtypes] in Type.lhs - -- We can't just use isRecursiveTyCon; sometimes recursion is ok: - -- newtype T = T (Ptr T) - -- Here, we don't reject the type for being recursive. - -- If this is a recursive newtype then it will normally - -- be rejected later as not being a valid FFI type. - , Just con <- tyConSingleDataCon_maybe tc +checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt +checkNewtypeFFI rdr_env tc + | Just con <- tyConSingleDataCon_maybe tc , [gre] <- lookupGRE_Name rdr_env (dataConName con) = Just gre -- See Note [Newtype constructor usage in foreign declarations] | otherwise diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 5726031493..045978ffb9 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -1,4 +1,4 @@ -% + % % (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % @@ -51,7 +51,6 @@ import PrelNames hiding (error_RDR) import PrimOp import SrcLoc import TyCon -import CoAxiom import TcType import TysPrim import TysWiredIn @@ -87,7 +86,7 @@ data DerivStuff -- Please add this auxiliary stuff -- Generics | DerivTyCon TyCon -- New data types - | DerivFamInst (FamInst Unbranched) -- New type family instances + | DerivFamInst (FamInst) -- New type family instances -- New top-level auxiliary bindings | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB @@ -478,21 +477,21 @@ unliftedOrdOp tycon ty op a b OrdGT -> wrap gt_op where (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty - wrap prim_op = genOpApp a_expr (primOpRdrName prim_op) b_expr + wrap prim_op = genOpApp a_expr prim_op b_expr a_expr = nlHsVar a b_expr = nlHsVar b -unliftedCompare :: PrimOp -> PrimOp +unliftedCompare :: RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName -- What to cmpare -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName -- Three results -> LHsExpr RdrName -- Return (if a < b then lt else if a == b then eq else gt) unliftedCompare lt_op eq_op a_expr b_expr lt eq gt - = nlHsIf (genOpApp a_expr (primOpRdrName lt_op) b_expr) lt $ + = nlHsIf (genOpApp a_expr lt_op b_expr) lt $ -- Test (<) first, not (==), because the latter -- is true less often, so putting it first would -- mean more tests (dynamically) - nlHsIf (genOpApp a_expr (primOpRdrName eq_op) b_expr) eq gt + nlHsIf (genOpApp a_expr eq_op b_expr) eq gt nlConWildPat :: DataCon -> LPat RdrName -- The pattern (K {}) @@ -873,7 +872,7 @@ instance Read T where Note [Use expectP] ~~~~~~~~~~~~~~~~~~ -Note that we use +Note that we use expectP (Ident "T1") rather than Ident "T1" <- lexP @@ -881,7 +880,25 @@ The latter desugares to inline code for matching the Ident and the string, and this can be very voluminous. The former is much more compact. Cf Trac #7258, although that also concerned non-linearity in the occurrence analyser, a separate issue. - + +Note [Read for empty data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should we get for this? (Trac #7931) + data Emp deriving( Read ) -- No data constructors + +Here we want + read "[]" :: [Emp] to succeed, returning [] +So we do NOT want + instance Read Emp where + readPrec = error "urk" +Rather we want + instance Read Emp where + readPred = pfail -- Same as choose [] + +Because 'pfail' allows the parser to backtrack, but 'error' doesn't. +These instances are also useful for Read (Either Int Emp), where +we want to be able to parse (Left 3) just fine. + \begin{code} gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) @@ -902,7 +919,8 @@ gen_Read_binds get_fixity loc tycon read_prec = mkHsVarBind loc readPrec_RDR (nlHsApp (nlHsVar parens_RDR) read_cons) - read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons) + read_cons | null data_cons = nlHsVar pfail_RDR -- See Note [Read for empty data types] + | otherwise = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons) read_non_nullary_cons = map read_non_nullary_con non_nullary_cons read_nullary_cons @@ -1424,7 +1442,13 @@ kind2 = liftedTypeKind `mkArrowKind` kind1 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR, dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR, - constr_RDR, dataType_RDR :: RdrName + constr_RDR, dataType_RDR, + eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR , + eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR , + eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR , + eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR , + eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR , + eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") @@ -1440,6 +1464,42 @@ dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType") conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex") prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix") infix_RDR = dataQual_RDR gENERICS (fsLit "Infix") + +eqChar_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "eqChar#") +ltChar_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "ltChar#") +leChar_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "leChar#") +gtChar_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "gtChar#") +geChar_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "geChar#") + +eqInt_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "==#") +ltInt_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "<#" ) +leInt_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "<=#") +gtInt_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit ">#" ) +geInt_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit ">=#") + +eqWord_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "eqWord#") +ltWord_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "ltWord#") +leWord_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "leWord#") +gtWord_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "gtWord#") +geWord_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "geWord#") + +eqAddr_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "eqAddr#") +ltAddr_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "ltAddr#") +leAddr_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "leAddr#") +gtAddr_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "gtAddr#") +geAddr_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "geAddr#") + +eqFloat_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "eqFloat#") +ltFloat_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "ltFloat#") +leFloat_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "leFloat#") +gtFloat_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "gtFloat#") +geFloat_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "geFloat#") + +eqDouble_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "==##") +ltDouble_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "<##" ) +leDouble_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit "<=##") +gtDouble_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit ">##" ) +geDouble_RDR = varQual_RDR gHC_PRIMWRAPPERS (fsLit ">=##") \end{code} @@ -1551,7 +1611,7 @@ gen_Functor_binds loc tycon , ft_fun = \g h -> do -- fmap f = \x b -> h (x (g b)) gg <- g hh <- h - mkSimpleLam2 $ \x b -> return $ nlHsApp hh (nlHsApp x (nlHsApp gg b)) + mkSimpleLam2 $ \x b -> return $ nlHsApp hh (nlHsApp x (nlHsApp gg b)) , ft_tup = \t gs -> do -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..) gg <- sequence gs mkSimpleLam $ mkSimpleTupleCase match_for_con t gg @@ -1759,7 +1819,7 @@ gen_Foldable_binds loc tycon , ft_co_var = panic "contravariant" , ft_fun = panic "function" , ft_bad_app = panic "in other argument" } - + match_foldMap = mkSimpleConMatch $ \_con_name xs -> return $ case xs of [] -> mempty_Expr @@ -1897,7 +1957,7 @@ type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings ( Bag (LHsBind RdrName, LSig RdrName) -- Extra bindings (used by Generic only) , Bag TyCon -- Extra top-level datatypes - , Bag (FamInst Unbranched) -- Extra family instances + , Bag (FamInst) -- Extra family instances , Bag (InstInfo RdrName)) -- Extra instances genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff @@ -1985,26 +2045,26 @@ box_if_necy cls_str tycon arg arg_ty primOrdOps :: String -- The class involved -> TyCon -- The tycon involved -> Type -- The type - -> (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp) -- (lt,le,eq,ge,gt) + -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt) -- See Note [Deriving and unboxed types] primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty -ordOpTbl :: [(Type, (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp))] +ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))] ordOpTbl - = [(charPrimTy, (CharLtOp, CharLeOp, CharEqOp, CharGeOp, CharGtOp)) - ,(intPrimTy, (IntLtOp, IntLeOp, IntEqOp, IntGeOp, IntGtOp)) - ,(wordPrimTy, (WordLtOp, WordLeOp, WordEqOp, WordGeOp, WordGtOp)) - ,(addrPrimTy, (AddrLtOp, AddrLeOp, AddrEqOp, AddrGeOp, AddrGtOp)) - ,(floatPrimTy, (FloatLtOp, FloatLeOp, FloatEqOp, FloatGeOp, FloatGtOp)) - ,(doublePrimTy, (DoubleLtOp, DoubleLeOp, DoubleEqOp, DoubleGeOp, DoubleGtOp)) ] + = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR )) + ,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR )) + ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR )) + ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR )) + ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR )) + ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ] boxConTbl :: [(Type, RdrName)] boxConTbl - = [(charPrimTy, getRdrName charDataCon) - ,(intPrimTy, getRdrName intDataCon) - ,(wordPrimTy, wordDataCon_RDR) - ,(floatPrimTy, getRdrName floatDataCon) - ,(doublePrimTy, getRdrName doubleDataCon) + = [(charPrimTy , getRdrName charDataCon ) + ,(intPrimTy , getRdrName intDataCon ) + ,(wordPrimTy , getRdrName wordDataCon ) + ,(floatPrimTy , getRdrName floatDataCon ) + ,(doublePrimTy, getRdrName doubleDataCon) ] assoc_ty_id :: String -- The class involved @@ -2027,10 +2087,10 @@ and_Expr a b = genOpApp a and_RDR b ----------------------------------------------------------------------- eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName -eq_Expr tycon ty a b = genOpApp a eq_op b +eq_Expr tycon ty a b + | not (isUnLiftedType ty) = genOpApp a eq_RDR b + | otherwise = genOpApp a prim_eq b where - eq_op | not (isUnLiftedType ty) = eq_RDR - | otherwise = primOpRdrName prim_eq (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty \end{code} @@ -2166,25 +2226,9 @@ mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent)) -- Was: mkDerivedRdrName name occ_fun, which made an original name -- But: (a) that does not work well for standalone-deriving -- (b) an unqualified name is just fine, provided it can't clash with user code -\end{code} -s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports -PrelNames, so PrelNames can't import PrimOp. - -\begin{code} -primOpRdrName :: PrimOp -> RdrName -primOpRdrName op = getRdrName (primOpId op) - -minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, gtInt_RDR, leInt_RDR, - tagToEnum_RDR :: RdrName -minusInt_RDR = primOpRdrName IntSubOp -eqInt_RDR = primOpRdrName IntEqOp -ltInt_RDR = primOpRdrName IntLtOp -geInt_RDR = primOpRdrName IntGeOp -gtInt_RDR = primOpRdrName IntGtOp -leInt_RDR = primOpRdrName IntLeOp -tagToEnum_RDR = primOpRdrName TagToEnumOp - -error_RDR :: RdrName -error_RDR = getRdrName eRROR_ID +minusInt_RDR, tagToEnum_RDR, error_RDR :: RdrName +minusInt_RDR = getRdrName (primOpId IntSubOp ) +tagToEnum_RDR = getRdrName (primOpId TagToEnumOp) +error_RDR = getRdrName eRROR_ID \end{code} diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index b058c283d7..7e2b0147ea 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -27,9 +27,7 @@ import TcType import TcGenDeriv import DataCon import TyCon -import CoAxiom -import Coercion ( mkSingleCoAxiom ) -import FamInstEnv ( FamInst, FamFlavor(..) ) +import FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) import FamInst import Module ( Module, moduleName, moduleNameString ) import IfaceEnv ( newGlobalBinder ) @@ -49,10 +47,9 @@ import Bag import VarSet (elemVarSet) import Outputable import FastString -import UniqSupply import Util -import Control.Monad (mplus) +import Control.Monad (mplus,forM) import qualified State as S #include "HsVersions.h" @@ -73,49 +70,40 @@ For the generic representation we need to generate: \begin{code} gen_Generic_binds :: GenericKind -> TyCon -> MetaTyCons -> Module - -> TcM (LHsBinds RdrName, FamInst Unbranched) + -> TcM (LHsBinds RdrName, FamInst) gen_Generic_binds gk tc metaTyCons mod = do repTyInsts <- tc_mkRepFamInsts gk tc metaTyCons mod return (mkBindsRep gk tc, repTyInsts) genGenericMetaTyCons :: TyCon -> Module -> TcM (MetaTyCons, BagDerivStuff) genGenericMetaTyCons tc mod = - do uniqS <- newUniqueSupply + do loc <- getSrcSpanM let - -- Uniques for everyone - (uniqD:uniqs) = uniqsFromSupply uniqS - (uniqsC,us) = splitAt (length tc_cons) uniqs - uniqsS :: [[Unique]] -- Unique supply for the S datatypes - uniqsS = mkUniqsS tc_arits us - mkUniqsS [] _ = [] - mkUniqsS (n:t) us = case splitAt n us of - (us1,us2) -> us1 : mkUniqsS t us2 - tc_name = tyConName tc tc_cons = tyConDataCons tc tc_arits = map dataConSourceArity tc_cons - + tc_occ = nameOccName tc_name d_occ = mkGenD tc_occ c_occ m = mkGenC tc_occ m s_occ m n = mkGenS tc_occ m n - d_name = mkExternalName uniqD mod d_occ wiredInSrcSpan - c_names = [ mkExternalName u mod (c_occ m) wiredInSrcSpan - | (u,m) <- zip uniqsC [0..] ] - s_names = [ [ mkExternalName u mod (s_occ m n) wiredInSrcSpan - | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ] - + mkTyCon name = ASSERT( isExternalName name ) - buildAlgTyCon name [] Nothing [] distinctAbstractTyConRhs + buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs NonRecursive False -- Not promotable False -- Not GADT syntax NoParentTyCon + d_name <- newGlobalBinder mod d_occ loc + c_names <- forM (zip [0..] tc_cons) $ \(m,_) -> + newGlobalBinder mod (c_occ m) loc + s_names <- forM (zip [0..] tc_arits) $ \(m,a) -> forM [0..a-1] $ \n -> + newGlobalBinder mod (s_occ m n) loc + let metaDTyCon = mkTyCon d_name metaCTyCons = map mkTyCon c_names - metaSTyCons = [ [ mkTyCon s_name | s_name <- s_namesC ] - | s_namesC <- s_names ] + metaSTyCons = map (map mkTyCon) s_names metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons @@ -172,11 +160,11 @@ metaTyConsToDerivStuff tc metaDts = (myZip2 s_insts s_binds) myZip1 :: [a] -> [b] -> [(a,b)] - myZip1 l1 l2 = ASSERT (length l1 == length l2) zip l1 l2 + myZip1 l1 l2 = ASSERT(length l1 == length l2) zip l1 l2 myZip2 :: [[a]] -> [[b]] -> [[(a,b)]] myZip2 l1 l2 = - ASSERT (and (zipWith (>=) (map length l1) (map length l2))) + ASSERT(and (zipWith (>=) (map length l1) (map length l2))) [ zip x1 x2 | (x1,x2) <- zip l1 l2 ] return $ mapBag DerivTyCon (metaTyCons2TyCons metaDts) @@ -213,10 +201,10 @@ canDoGenerics tc tc_args (if (not (null (tyConStupidTheta tc))) then (Just (tc_name <+> text "must not have a datatype context")) else Nothing) : - -- The type should not be instantiated (see #5939) + -- The type arguments should not be instantiated (see #5939) -- Data family indices can be instantiated; the `tc_args` here are the -- representation tycon args - (if (all isTyVarTy tc_args) + (if (all isTyVarTy (filterOut isKindTy tc_args)) then Nothing else Just (tc_name <+> text "must not be instantiated;" <+> text "try deriving `" <> tc_name <+> tc_tys <> @@ -400,7 +388,7 @@ mkBindsRep gk tycon = (from_alts, to_alts) = mkSum gk_ (1 :: US) tycon datacons where gk_ = case gk of Gen0 -> Gen0_ - Gen1 -> ASSERT (length tyvars >= 1) + Gen1 -> ASSERT(length tyvars >= 1) Gen1_ (last tyvars) where tyvars = tyConTyVars tycon @@ -414,7 +402,7 @@ tc_mkRepFamInsts :: GenericKind -- Gen0 or Gen1 -> TyCon -- The type to generate representation for -> MetaTyCons -- Metadata datatypes to refer to -> Module -- Used as the location of the new RepTy - -> TcM (FamInst Unbranched) -- Generated representation0 coercion + -> TcM (FamInst) -- Generated representation0 coercion tc_mkRepFamInsts gk tycon metaDts mod = -- Consider the example input tycon `D`, where data D a b = D_ a -- Also consider `R:DInt`, where { data family D x y :: * -> * @@ -427,7 +415,7 @@ tc_mkRepFamInsts gk tycon metaDts mod = ; let -- `tyvars` = [a,b] (tyvars, gk_) = case gk of Gen0 -> (all_tyvars, Gen0_) - Gen1 -> ASSERT (not $ null all_tyvars) + Gen1 -> ASSERT(not $ null all_tyvars) (init all_tyvars, Gen1_ $ last all_tyvars) where all_tyvars = tyConTyVars tycon @@ -455,7 +443,7 @@ tc_mkRepFamInsts gk tycon metaDts mod = (nameSrcSpan (tyConName tycon)) ; let axiom = mkSingleCoAxiom rep_name tyvars fam_tc appT repTy - ; newFamInst SynFamilyInst False axiom } + ; newFamInst SynFamilyInst axiom } -------------------------------------------------------------------------------- -- Type representation @@ -565,16 +553,16 @@ tc_mkRepTy gk_ tycon metaDts = -- Sums and products are done in the same way for both Rep and Rep1 sumP [] = mkTyConTy v1 - sumP l = ASSERT (length metaCTyCons == length l) + sumP l = ASSERT(length metaCTyCons == length l) foldBal mkSum' [ mkC i d a | (d,(a,i)) <- zip metaCTyCons (zip l [0..])] -- The Bool is True if this constructor has labelled fields prod :: Int -> [Type] -> Bool -> Type - prod i [] _ = ASSERT (length metaSTyCons > i) - ASSERT (length (metaSTyCons !! i) == 0) + prod i [] _ = ASSERT(length metaSTyCons > i) + ASSERT(length (metaSTyCons !! i) == 0) mkTyConTy u1 - prod i l b = ASSERT (length metaSTyCons > i) - ASSERT (length l == length (metaSTyCons !! i)) + prod i l b = ASSERT(length metaSTyCons > i) + ASSERT(length l == length (metaSTyCons !! i)) foldBal mkProd [ arg d t b | (d,t) <- zip (metaSTyCons !! i) l ] diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 1e2961258d..8e10303869 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -9,26 +9,19 @@ This module is an extension of @HsSyn@ syntax, for use in the type checker. \begin{code} -{-# 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 TcHsSyn ( - mkHsConApp, mkHsDictLet, mkHsApp, - hsLitType, hsLPatType, hsPatType, - mkHsAppTy, mkSimpleHsAlt, - nlHsIntLit, - shortCutLit, hsOverLitName, - - -- re-exported from TcMonad - TcId, TcIdSet, - - zonkTopDecls, zonkTopExpr, zonkTopLExpr, - zonkTopBndrs, zonkTyBndrsX, - emptyZonkEnv, mkEmptyZonkEnv, mkTyVarZonkEnv, + mkHsConApp, mkHsDictLet, mkHsApp, + hsLitType, hsLPatType, hsPatType, + mkHsAppTy, mkSimpleHsAlt, + nlHsIntLit, + shortCutLit, hsOverLitName, + + -- re-exported from TcMonad + TcId, TcIdSet, + + zonkTopDecls, zonkTopExpr, zonkTopLExpr, + zonkTopBndrs, zonkTyBndrsX, + emptyZonkEnv, mkEmptyZonkEnv, mkTyVarZonkEnv, zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc, ) where @@ -60,26 +53,12 @@ import Bag import FastString import Outputable import Util --- import Data.Traversable( traverse ) -\end{code} - -\begin{code} --- XXX -thenM :: Monad a => a b -> (b -> a c) -> a c -thenM = (>>=) - -returnM :: Monad m => a -> m a -returnM = return - -mappM :: (Monad m) => (a -> m b) -> [a] -> m [b] -mappM = mapM \end{code} - %************************************************************************ -%* * +%* * \subsection[mkFailurePair]{Code for pattern-matching and other failures} -%* * +%* * %************************************************************************ Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@, @@ -133,11 +112,11 @@ shortCutLit dflags (HsIntegral i) ty | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim i)) | isIntegerTy ty = Just (HsLit (HsInteger i ty)) | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit i)) ty - -- The 'otherwise' case is important - -- Consider (3 :: Float). Syntactically it looks like an IntLit, - -- so we'll call shortCutIntLit, but of course it's a float - -- This can make a big difference for programs with a lot of - -- literals, compiled without -O + -- The 'otherwise' case is important + -- Consider (3 :: Float). Syntactically it looks like an IntLit, + -- so we'll call shortCutIntLit, but of course it's a float + -- This can make a big difference for programs with a lot of + -- literals, compiled without -O shortCutLit _ (HsFractional f) ty | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim f)) @@ -160,9 +139,9 @@ hsOverLitName (HsIsString {}) = fromStringName \end{code} %************************************************************************ -%* * +%* * \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} -%* * +%* * %************************************************************************ The rest of the zonking is done *after* typechecking. @@ -179,26 +158,26 @@ The Ids are converted by binding them in the normal Tc envt; that way we maintain sharing; eg an Id is zonked at its binding site and they all occurrences of that Id point to the common zonked copy -It's all pretty boring stuff, because HsSyn is such a large type, and +It's all pretty boring stuff, because HsSyn is such a large type, and the environment manipulation is tiresome. \begin{code} -type UnboundTyVarZonker = TcTyVar-> TcM Type - -- How to zonk an unbound type variable +type UnboundTyVarZonker = TcTyVar-> TcM Type + -- How to zonk an unbound type variable -- Note [Zonking the LHS of a RULE] -data ZonkEnv - = ZonkEnv +data ZonkEnv + = ZonkEnv UnboundTyVarZonker - (TyVarEnv TyVar) -- - (IdEnv Var) -- What variables are in scope - -- Maps an Id or EvVar to its zonked version; both have the same Name - -- Note that all evidence (coercion variables as well as dictionaries) - -- are kept in the ZonkEnv - -- Only *type* abstraction is done by side effect - -- Is only consulted lazily; hence knot-tying - -instance Outputable ZonkEnv where + (TyVarEnv TyVar) -- + (IdEnv Var) -- What variables are in scope + -- Maps an Id or EvVar to its zonked version; both have the same Name + -- Note that all evidence (coercion variables as well as dictionaries) + -- are kept in the ZonkEnv + -- Only *type* abstraction is done by side effect + -- Is only consulted lazily; hence knot-tying + +instance Outputable ZonkEnv where ppr (ZonkEnv _ _ty_env var_env) = vcat (map ppr (varEnvElts var_env)) @@ -209,11 +188,11 @@ mkEmptyZonkEnv :: UnboundTyVarZonker -> ZonkEnv mkEmptyZonkEnv zonker = ZonkEnv zonker emptyVarEnv emptyVarEnv extendIdZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv -extendIdZonkEnv (ZonkEnv zonk_ty ty_env id_env) ids +extendIdZonkEnv (ZonkEnv zonk_ty ty_env id_env) ids = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids]) extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv -extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id +extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id) extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv @@ -230,43 +209,43 @@ zonkEnvIds :: ZonkEnv -> [Id] zonkEnvIds (ZonkEnv _ _ id_env) = varEnvElts id_env zonkIdOcc :: ZonkEnv -> TcId -> Id --- Ids defined in this module should be in the envt; +-- Ids defined in this module should be in the envt; -- ignore others. (Actually, data constructors are also -- not LocalVars, even when locally defined, but that is fine.) -- (Also foreign-imported things aren't currently in the ZonkEnv; -- that's ok because they don't need zonking.) -- -- Actually, Template Haskell works in 'chunks' of declarations, and --- an earlier chunk won't be in the 'env' that the zonking phase +-- an earlier chunk won't be in the 'env' that the zonking phase -- carries around. Instead it'll be in the tcg_gbl_env, already fully --- zonked. There's no point in looking it up there (except for error +-- zonked. There's no point in looking it up there (except for error -- checking), and it's not conveniently to hand; hence the simple -- 'orElse' case in the LocalVar branch. -- -- Even without template splices, in module Main, the checking of -- 'main' is done as a separate chunk. -zonkIdOcc (ZonkEnv _zonk_ty _ty_env env) id +zonkIdOcc (ZonkEnv _zonk_ty _ty_env env) id | isLocalVar id = lookupVarEnv env id `orElse` id - | otherwise = id + | otherwise = id zonkIdOccs :: ZonkEnv -> [TcId] -> [Id] zonkIdOccs env ids = map (zonkIdOcc env) ids -- zonkIdBndr is used *after* typechecking to get the Id's type --- to its final form. The TyVarEnv give +-- to its final form. The TyVarEnv give zonkIdBndr :: ZonkEnv -> TcId -> TcM Id zonkIdBndr env id - = zonkTcTypeToType env (idType id) `thenM` \ ty' -> - returnM (Id.setIdType id ty') + = do ty' <- zonkTcTypeToType env (idType id) + return (Id.setIdType id ty') zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id] -zonkIdBndrs env ids = mappM (zonkIdBndr env) ids +zonkIdBndrs env ids = mapM (zonkIdBndr env) ids zonkTopBndrs :: [TcId] -> TcM [Id] zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var]) -zonkEvBndrsX = mapAccumLM zonkEvBndrX +zonkEvBndrsX = mapAccumLM zonkEvBndrX zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar) -- Works for dictionaries and coercions @@ -277,9 +256,9 @@ zonkEvBndrX env var zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar -- Works for dictionaries and coercions -- Does not extend the ZonkEnv -zonkEvBndr env var +zonkEvBndr env var = do { let var_ty = varType var - ; ty <- + ; ty <- {-# SCC "zonkEvBndr_zonkTcTypeToType" #-} zonkTcTypeToType env var_ty ; return (setVarType var ty) } @@ -288,7 +267,7 @@ zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar zonkEvVarOcc env v = zonkIdOcc env v zonkTyBndrsX :: ZonkEnv -> [TyVar] -> TcM (ZonkEnv, [TyVar]) -zonkTyBndrsX = mapAccumLM zonkTyBndrX +zonkTyBndrsX = mapAccumLM zonkTyBndrX zonkTyBndrX :: ZonkEnv -> TyVar -> TcM (ZonkEnv, TyVar) -- This guarantees to return a TyVar (not a TcTyVar) @@ -307,10 +286,10 @@ zonkTopExpr e = zonkExpr emptyZonkEnv e zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id) zonkTopLExpr e = zonkLExpr emptyZonkEnv e -zonkTopDecls :: Bag EvBind +zonkTopDecls :: Bag EvBind -> LHsBinds TcId -> NameSet -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId] - -> TcM ([Id], + -> TcM ([Id], Bag EvBind, Bag (LHsBind Id), [LForeignDecl Id], @@ -320,8 +299,8 @@ zonkTopDecls :: Bag EvBind zonkTopDecls ev_binds binds sig_ns rules vects imp_specs fords = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds - -- Warn about missing signatures - -- Do this only when we we have a type to offer + -- Warn about missing signatures + -- Do this only when we we have a type to offer ; warn_missing_sigs <- woptM Opt_WarnMissingSigs ; let sig_warn | warn_missing_sigs = topSigWarn sig_ns | otherwise = noSigWarn @@ -343,43 +322,42 @@ zonkLocalBinds _ (HsValBinds (ValBindsIn {})) = panic "zonkLocalBinds" -- Not in typechecker output zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs)) - = do { warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs + = do { warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs ; let sig_warn | not warn_missing_sigs = noSigWarn | otherwise = localSigWarn sig_ns sig_ns = getTypeSigNames vb - ; (env1, new_binds) <- go env sig_warn binds + ; (env1, new_binds) <- go env sig_warn binds ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) } where go env _ [] = return (env, []) - go env sig_warn ((r,b):bs) + go env sig_warn ((r,b):bs) = do { (env1, b') <- zonkRecMonoBinds env sig_warn b - ; (env2, bs') <- go env1 sig_warn bs - ; return (env2, (r,b'):bs') } + ; (env2, bs') <- go env1 sig_warn bs + ; return (env2, (r,b'):bs') } -zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) - = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds -> +zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do + new_binds <- mapM (wrapLocM zonk_ip_bind) binds let - env1 = extendIdZonkEnv env [ n | L _ (IPBind (Right n) _) <- new_binds] - in - zonkTcEvBinds env1 dict_binds `thenM` \ (env2, new_dict_binds) -> - returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds)) + env1 = extendIdZonkEnv env [ n | L _ (IPBind (Right n) _) <- new_binds] + (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds + return (env2, HsIPBinds (IPBinds new_binds new_dict_binds)) where zonk_ip_bind (IPBind n e) - = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' -> - zonkLExpr env e `thenM` \ e' -> - returnM (IPBind n' e') + = do n' <- mapIPNameTc (zonkIdBndr env) n + e' <- zonkLExpr env e + return (IPBind n' e') --------------------------------------------- zonkRecMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id) -zonkRecMonoBinds env sig_warn binds - = fixM (\ ~(_, new_binds) -> do - { let env1 = extendIdZonkEnv env (collectHsBindsBinders new_binds) +zonkRecMonoBinds env sig_warn binds + = fixM (\ ~(_, new_binds) -> do + { let env1 = extendIdZonkEnv env (collectHsBindsBinders new_binds) ; binds' <- zonkMonoBinds env1 sig_warn binds ; return (env1, binds') }) --------------------------------------------- -type SigWarn = Bool -> [Id] -> TcM () +type SigWarn = Bool -> [Id] -> TcM () -- Missing-signature warning -- The Bool is True for an AbsBinds, False otherwise @@ -428,11 +406,11 @@ zonkMonoBinds env sig_warn binds = mapBagM (wrapLocM (zonk_bind env sig_warn)) b zonk_bind :: ZonkEnv -> SigWarn -> HsBind TcId -> TcM (HsBind Id) zonk_bind env sig_warn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty}) - = do { (_env, new_pat) <- zonkPat env pat -- Env already extended + = do { (_env, new_pat) <- zonkPat env pat -- Env already extended ; sig_warn False (collectPatBinders new_pat) - ; new_grhss <- zonkGRHSs env zonkLExpr grhss - ; new_ty <- zonkTcTypeToType env ty - ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) } + ; new_grhss <- zonkGRHSs env zonkLExpr grhss + ; new_ty <- zonkTcTypeToType env ty + ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) } zonk_bind env sig_warn (VarBind { var_id = var, var_rhs = expr, var_inline = inl }) = do { new_var <- zonkIdBndr env var @@ -451,7 +429,7 @@ zonk_bind env sig_warn bind@(FunBind { fun_id = L loc var, fun_matches = ms zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs , abs_ev_binds = ev_binds - , abs_exports = exports + , abs_exports = exports , abs_binds = val_binds }) = ASSERT( all isImmutableTyVar tyvars ) do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars @@ -459,21 +437,22 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) -> do { let env3 = extendIdZonkEnv env2 (collectHsBindsBinders new_val_binds) - ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds - ; new_exports <- mapM (zonkExport env3) exports - ; return (new_val_binds, new_exports) } + ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds + ; new_exports <- mapM (zonkExport env3) exports + ; return (new_val_binds, new_exports) } ; sig_warn True (map abe_poly new_exports) ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs , abs_ev_binds = new_ev_binds - , abs_exports = new_exports, abs_binds = new_val_bind }) } + , abs_exports = new_exports, abs_binds = new_val_bind }) } where zonkExport env (ABE{ abe_wrap = wrap, abe_poly = poly_id , abe_mono = mono_id, abe_prags = prags }) - = zonkIdBndr env poly_id `thenM` \ new_poly_id -> - zonkCoFn env wrap `thenM` \ (_, new_wrap) -> - zonkSpecPrags env prags `thenM` \ new_prags -> - returnM (ABE{ abe_wrap = new_wrap, abe_poly = new_poly_id - , abe_mono = zonkIdOcc env mono_id, abe_prags = new_prags }) + = do new_poly_id <- zonkIdBndr env poly_id + (_, new_wrap) <- zonkCoFn env wrap + new_prags <- zonkSpecPrags env prags + return (ABE{ abe_wrap = new_wrap, abe_poly = new_poly_id + , abe_mono = zonkIdOcc env mono_id + , abe_prags = new_prags }) zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod @@ -485,55 +464,54 @@ zonkLTcSpecPrags env ps = mapM zonk_prag ps where zonk_prag (L loc (SpecPrag id co_fn inl)) - = do { (_, co_fn') <- zonkCoFn env co_fn - ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } + = do { (_, co_fn') <- zonkCoFn env co_fn + ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } \end{code} %************************************************************************ -%* * +%* * \subsection[BackSubst-Match-GRHSs]{Match and GRHSs} -%* * +%* * %************************************************************************ \begin{code} -zonkMatchGroup :: ZonkEnv +zonkMatchGroup :: ZonkEnv -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id))) -zonkMatchGroup env zBody (MG { mg_alts = ms, mg_arg_tys = arg_tys, mg_res_ty = res_ty }) - = do { ms' <- mapM (zonkMatch env zBody) ms - ; arg_tys' <- zonkTcTypeToTypes env arg_tys - ; res_ty' <- zonkTcTypeToType env res_ty - ; return (MG { mg_alts = ms', mg_arg_tys = arg_tys', mg_res_ty = res_ty' }) } +zonkMatchGroup env zBody (MG { mg_alts = ms, mg_arg_tys = arg_tys, mg_res_ty = res_ty }) + = do { ms' <- mapM (zonkMatch env zBody) ms + ; arg_tys' <- zonkTcTypeToTypes env arg_tys + ; res_ty' <- zonkTcTypeToType env res_ty + ; return (MG { mg_alts = ms', mg_arg_tys = arg_tys', mg_res_ty = res_ty' }) } -zonkMatch :: ZonkEnv +zonkMatch :: ZonkEnv -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) -> LMatch TcId (Located (body TcId)) -> TcM (LMatch Id (Located (body Id))) zonkMatch env zBody (L loc (Match pats _ grhss)) - = do { (env1, new_pats) <- zonkPats env pats - ; new_grhss <- zonkGRHSs env1 zBody grhss - ; return (L loc (Match new_pats Nothing new_grhss)) } + = do { (env1, new_pats) <- zonkPats env pats + ; new_grhss <- zonkGRHSs env1 zBody grhss + ; return (L loc (Match new_pats Nothing new_grhss)) } ------------------------------------------------------------------------- -zonkGRHSs :: ZonkEnv +zonkGRHSs :: ZonkEnv -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id))) -zonkGRHSs env zBody (GRHSs grhss binds) - = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) -> +zonkGRHSs env zBody (GRHSs grhss binds) = do + (new_env, new_binds) <- zonkLocalBinds env binds let zonk_grhs (GRHS guarded rhs) - = zonkStmts new_env zonkLExpr guarded `thenM` \ (env2, new_guarded) -> - zBody env2 rhs `thenM` \ new_rhs -> - returnM (GRHS new_guarded new_rhs) - in - mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss -> - returnM (GRHSs new_grhss new_binds) + = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded + new_rhs <- zBody env2 rhs + return (GRHS new_guarded new_rhs) + new_grhss <- mapM (wrapLocM zonk_grhs) grhss + return (GRHSs new_grhss new_binds) \end{code} %************************************************************************ -%* * +%* * \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr} -%* * +%* * %************************************************************************ \begin{code} @@ -541,74 +519,74 @@ zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id] zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id) zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id) -zonkLExprs env exprs = mappM (zonkLExpr env) exprs +zonkLExprs env exprs = mapM (zonkLExpr env) exprs zonkLExpr env expr = wrapLocM (zonkExpr env) expr zonkExpr env (HsVar id) - = returnM (HsVar (zonkIdOcc env id)) + = return (HsVar (zonkIdOcc env id)) zonkExpr _ (HsIPVar id) - = returnM (HsIPVar id) + = return (HsIPVar id) zonkExpr env (HsLit (HsRat f ty)) - = zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (HsLit (HsRat f new_ty)) + = do new_ty <- zonkTcTypeToType env ty + return (HsLit (HsRat f new_ty)) zonkExpr _ (HsLit lit) - = returnM (HsLit lit) + = return (HsLit lit) zonkExpr env (HsOverLit lit) - = do { lit' <- zonkOverLit env lit - ; return (HsOverLit lit') } + = do { lit' <- zonkOverLit env lit + ; return (HsOverLit lit') } zonkExpr env (HsLam matches) - = zonkMatchGroup env zonkLExpr matches `thenM` \ new_matches -> - returnM (HsLam new_matches) + = do new_matches <- zonkMatchGroup env zonkLExpr matches + return (HsLam new_matches) zonkExpr env (HsLamCase arg matches) - = zonkTcTypeToType env arg `thenM` \ new_arg -> - zonkMatchGroup env zonkLExpr matches `thenM` \ new_matches -> - returnM (HsLamCase new_arg new_matches) + = do new_arg <- zonkTcTypeToType env arg + new_matches <- zonkMatchGroup env zonkLExpr matches + return (HsLamCase new_arg new_matches) zonkExpr env (HsApp e1 e2) - = zonkLExpr env e1 `thenM` \ new_e1 -> - zonkLExpr env e2 `thenM` \ new_e2 -> - returnM (HsApp new_e1 new_e2) + = do new_e1 <- zonkLExpr env e1 + new_e2 <- zonkLExpr env e2 + return (HsApp new_e1 new_e2) -zonkExpr env (HsBracketOut body bs) - = mappM zonk_b bs `thenM` \ bs' -> - returnM (HsBracketOut body bs') +zonkExpr env (HsBracketOut body bs) + = do bs' <- mapM zonk_b bs + return (HsBracketOut body bs') where - zonk_b (n,e) = zonkLExpr env e `thenM` \ e' -> - returnM (n,e') + zonk_b (n,e) = do e' <- zonkLExpr env e + return (n,e') zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen - returnM (HsSpliceE s) + return (HsSpliceE s) zonkExpr env (OpApp e1 op fixity e2) - = zonkLExpr env e1 `thenM` \ new_e1 -> - zonkLExpr env op `thenM` \ new_op -> - zonkLExpr env e2 `thenM` \ new_e2 -> - returnM (OpApp new_e1 new_op fixity new_e2) + = do new_e1 <- zonkLExpr env e1 + new_op <- zonkLExpr env op + new_e2 <- zonkLExpr env e2 + return (OpApp new_e1 new_op fixity new_e2) zonkExpr env (NegApp expr op) - = zonkLExpr env expr `thenM` \ new_expr -> - zonkExpr env op `thenM` \ new_op -> - returnM (NegApp new_expr new_op) + = do new_expr <- zonkLExpr env expr + new_op <- zonkExpr env op + return (NegApp new_expr new_op) -zonkExpr env (HsPar e) - = zonkLExpr env e `thenM` \new_e -> - returnM (HsPar new_e) +zonkExpr env (HsPar e) + = do new_e <- zonkLExpr env e + return (HsPar new_e) zonkExpr env (SectionL expr op) - = zonkLExpr env expr `thenM` \ new_expr -> - zonkLExpr env op `thenM` \ new_op -> - returnM (SectionL new_expr new_op) + = do new_expr <- zonkLExpr env expr + new_op <- zonkLExpr env op + return (SectionL new_expr new_op) zonkExpr env (SectionR op expr) - = zonkLExpr env op `thenM` \ new_op -> - zonkLExpr env expr `thenM` \ new_expr -> - returnM (SectionR new_op new_expr) + = do new_op <- zonkLExpr env op + new_expr <- zonkLExpr env expr + return (SectionR new_op new_expr) zonkExpr env (ExplicitTuple tup_args boxed) = do { new_tup_args <- mapM zonk_tup_arg tup_args @@ -618,105 +596,105 @@ zonkExpr env (ExplicitTuple tup_args boxed) zonk_tup_arg (Missing t) = do { t' <- zonkTcTypeToType env t; return (Missing t') } zonkExpr env (HsCase expr ms) - = zonkLExpr env expr `thenM` \ new_expr -> - zonkMatchGroup env zonkLExpr ms `thenM` \ new_ms -> - returnM (HsCase new_expr new_ms) + = do new_expr <- zonkLExpr env expr + new_ms <- zonkMatchGroup env zonkLExpr ms + return (HsCase new_expr new_ms) zonkExpr env (HsIf e0 e1 e2 e3) = do { new_e0 <- fmapMaybeM (zonkExpr env) e0 ; new_e1 <- zonkLExpr env e1 ; new_e2 <- zonkLExpr env e2 ; new_e3 <- zonkLExpr env e3 - ; returnM (HsIf new_e0 new_e1 new_e2 new_e3) } + ; return (HsIf new_e0 new_e1 new_e2 new_e3) } zonkExpr env (HsMultiIf ty alts) = do { alts' <- mapM (wrapLocM zonk_alt) alts ; ty' <- zonkTcTypeToType env ty - ; returnM $ HsMultiIf ty' alts' } + ; return $ HsMultiIf ty' alts' } where zonk_alt (GRHS guard expr) = do { (env', guard') <- zonkStmts env zonkLExpr guard ; expr' <- zonkLExpr env' expr - ; returnM $ GRHS guard' expr' } + ; return $ GRHS guard' expr' } zonkExpr env (HsLet binds expr) - = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) -> - zonkLExpr new_env expr `thenM` \ new_expr -> - returnM (HsLet new_binds new_expr) + = do (new_env, new_binds) <- zonkLocalBinds env binds + new_expr <- zonkLExpr new_env expr + return (HsLet new_binds new_expr) zonkExpr env (HsDo do_or_lc stmts ty) - = zonkStmts env zonkLExpr stmts `thenM` \ (_, new_stmts) -> - zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (HsDo do_or_lc new_stmts new_ty) + = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts + new_ty <- zonkTcTypeToType env ty + return (HsDo do_or_lc new_stmts new_ty) zonkExpr env (ExplicitList ty wit exprs) - = zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkWit env wit `thenM` \ new_wit -> - zonkLExprs env exprs `thenM` \ new_exprs -> - returnM (ExplicitList new_ty new_wit new_exprs) - where zonkWit _ Nothing = returnM Nothing - zonkWit env (Just fln) = zonkExpr env fln `thenM` \ new_fln -> - returnM (Just new_fln) + = do new_ty <- zonkTcTypeToType env ty + new_wit <- zonkWit env wit + new_exprs <- zonkLExprs env exprs + return (ExplicitList new_ty new_wit new_exprs) + where zonkWit _ Nothing = return Nothing + zonkWit env (Just fln) = do new_fln <- zonkExpr env fln + return (Just new_fln) zonkExpr env (ExplicitPArr ty exprs) - = zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkLExprs env exprs `thenM` \ new_exprs -> - returnM (ExplicitPArr new_ty new_exprs) + = do new_ty <- zonkTcTypeToType env ty + new_exprs <- zonkLExprs env exprs + return (ExplicitPArr new_ty new_exprs) zonkExpr env (RecordCon data_con con_expr rbinds) - = do { new_con_expr <- zonkExpr env con_expr - ; new_rbinds <- zonkRecFields env rbinds - ; return (RecordCon data_con new_con_expr new_rbinds) } + = do { new_con_expr <- zonkExpr env con_expr + ; new_rbinds <- zonkRecFields env rbinds + ; return (RecordCon data_con new_con_expr new_rbinds) } zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys) - = do { new_expr <- zonkLExpr env expr - ; new_in_tys <- mapM (zonkTcTypeToType env) in_tys - ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys - ; new_rbinds <- zonkRecFields env rbinds - ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) } + = do { new_expr <- zonkLExpr env expr + ; new_in_tys <- mapM (zonkTcTypeToType env) in_tys + ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys + ; new_rbinds <- zonkRecFields env rbinds + ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) } -zonkExpr env (ExprWithTySigOut e ty) +zonkExpr env (ExprWithTySigOut e ty) = do { e' <- zonkLExpr env e ; return (ExprWithTySigOut e' ty) } zonkExpr _ (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig" zonkExpr env (ArithSeq expr wit info) - = zonkExpr env expr `thenM` \ new_expr -> - zonkWit env wit `thenM` \ new_wit -> - zonkArithSeq env info `thenM` \ new_info -> - returnM (ArithSeq new_expr new_wit new_info) - where zonkWit _ Nothing = returnM Nothing - zonkWit env (Just fln) = zonkExpr env fln `thenM` \ new_fln -> - returnM (Just new_fln) + = do new_expr <- zonkExpr env expr + new_wit <- zonkWit env wit + new_info <- zonkArithSeq env info + return (ArithSeq new_expr new_wit new_info) + where zonkWit _ Nothing = return Nothing + zonkWit env (Just fln) = do new_fln <- zonkExpr env fln + return (Just new_fln) zonkExpr env (PArrSeq expr info) - = zonkExpr env expr `thenM` \ new_expr -> - zonkArithSeq env info `thenM` \ new_info -> - returnM (PArrSeq new_expr new_info) + = do new_expr <- zonkExpr env expr + new_info <- zonkArithSeq env info + return (PArrSeq new_expr new_info) zonkExpr env (HsSCC lbl expr) - = zonkLExpr env expr `thenM` \ new_expr -> - returnM (HsSCC lbl new_expr) + = do new_expr <- zonkLExpr env expr + return (HsSCC lbl new_expr) zonkExpr env (HsTickPragma info expr) - = zonkLExpr env expr `thenM` \ new_expr -> - returnM (HsTickPragma info new_expr) + = do new_expr <- zonkLExpr env expr + return (HsTickPragma info new_expr) -- hdaume: core annotations zonkExpr env (HsCoreAnn lbl expr) - = zonkLExpr env expr `thenM` \ new_expr -> - returnM (HsCoreAnn lbl new_expr) + = do new_expr <- zonkLExpr env expr + return (HsCoreAnn lbl new_expr) -- arrow notation extensions zonkExpr env (HsProc pat body) - = do { (env1, new_pat) <- zonkPat env pat - ; new_body <- zonkCmdTop env1 body - ; return (HsProc new_pat new_body) } + = do { (env1, new_pat) <- zonkPat env pat + ; new_body <- zonkCmdTop env1 body + ; return (HsProc new_pat new_body) } zonkExpr env (HsWrap co_fn expr) - = zonkCoFn env co_fn `thenM` \ (env1, new_co_fn) -> - zonkExpr env1 expr `thenM` \ new_expr -> - return (HsWrap new_co_fn new_expr) + = do (env1, new_co_fn) <- zonkCoFn env co_fn + new_expr <- zonkExpr env1 expr + return (HsWrap new_co_fn new_expr) zonkExpr _ (HsUnboundVar v) = return (HsUnboundVar v) @@ -732,53 +710,53 @@ zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd zonkCmd env (HsCmdCast co cmd) = do { co' <- zonkTcLCoToLCo env co - ; cmd' <- zonkCmd env cmd + ; cmd' <- zonkCmd env cmd ; return (HsCmdCast co' cmd') } zonkCmd env (HsCmdArrApp e1 e2 ty ho rl) - = zonkLExpr env e1 `thenM` \ new_e1 -> - zonkLExpr env e2 `thenM` \ new_e2 -> - zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (HsCmdArrApp new_e1 new_e2 new_ty ho rl) + = do new_e1 <- zonkLExpr env e1 + new_e2 <- zonkLExpr env e2 + new_ty <- zonkTcTypeToType env ty + return (HsCmdArrApp new_e1 new_e2 new_ty ho rl) zonkCmd env (HsCmdArrForm op fixity args) - = zonkLExpr env op `thenM` \ new_op -> - mappM (zonkCmdTop env) args `thenM` \ new_args -> - returnM (HsCmdArrForm new_op fixity new_args) + = do new_op <- zonkLExpr env op + new_args <- mapM (zonkCmdTop env) args + return (HsCmdArrForm new_op fixity new_args) zonkCmd env (HsCmdApp c e) - = zonkLCmd env c `thenM` \ new_c -> - zonkLExpr env e `thenM` \ new_e -> - returnM (HsCmdApp new_c new_e) + = do new_c <- zonkLCmd env c + new_e <- zonkLExpr env e + return (HsCmdApp new_c new_e) zonkCmd env (HsCmdLam matches) - = zonkMatchGroup env zonkLCmd matches `thenM` \ new_matches -> - returnM (HsCmdLam new_matches) + = do new_matches <- zonkMatchGroup env zonkLCmd matches + return (HsCmdLam new_matches) -zonkCmd env (HsCmdPar c) - = zonkLCmd env c `thenM` \new_c -> - returnM (HsCmdPar new_c) +zonkCmd env (HsCmdPar c) + = do new_c <- zonkLCmd env c + return (HsCmdPar new_c) zonkCmd env (HsCmdCase expr ms) - = zonkLExpr env expr `thenM` \ new_expr -> - zonkMatchGroup env zonkLCmd ms `thenM` \ new_ms -> - returnM (HsCmdCase new_expr new_ms) + = do new_expr <- zonkLExpr env expr + new_ms <- zonkMatchGroup env zonkLCmd ms + return (HsCmdCase new_expr new_ms) zonkCmd env (HsCmdIf eCond ePred cThen cElse) = do { new_eCond <- fmapMaybeM (zonkExpr env) eCond ; new_ePred <- zonkLExpr env ePred ; new_cThen <- zonkLCmd env cThen ; new_cElse <- zonkLCmd env cElse - ; returnM (HsCmdIf new_eCond new_ePred new_cThen new_cElse) } + ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) } zonkCmd env (HsCmdLet binds cmd) - = zonkLocalBinds env binds `thenM` \ (new_env, new_binds) -> - zonkLCmd new_env cmd `thenM` \ new_cmd -> - returnM (HsCmdLet new_binds new_cmd) + = do (new_env, new_binds) <- zonkLocalBinds env binds + new_cmd <- zonkLCmd new_env cmd + return (HsCmdLet new_binds new_cmd) zonkCmd env (HsCmdDo stmts ty) - = zonkStmts env zonkLCmd stmts `thenM` \ (_, new_stmts) -> - zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (HsCmdDo new_stmts new_ty) + = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts + new_ty <- zonkTcTypeToType env ty + return (HsCmdDo new_stmts new_ty) @@ -789,65 +767,65 @@ zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id) zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) - = zonkLCmd env cmd `thenM` \ new_cmd -> - zonkTcTypeToType env stack_tys `thenM` \ new_stack_tys -> - zonkTcTypeToType env ty `thenM` \ new_ty -> - mapSndM (zonkExpr env) ids `thenM` \ new_ids -> - returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids) + = do new_cmd <- zonkLCmd env cmd + new_stack_tys <- zonkTcTypeToType env stack_tys + new_ty <- zonkTcTypeToType env ty + new_ids <- mapSndM (zonkExpr env) ids + return (HsCmdTop new_cmd new_stack_tys new_ty new_ids) ------------------------------------------------------------------------- zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) zonkCoFn env WpHole = return (env, WpHole) zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 - ; (env2, c2') <- zonkCoFn env1 c2 - ; return (env2, WpCompose c1' c2') } + ; (env2, c2') <- zonkCoFn env1 c2 + ; return (env2, WpCompose c1' c2') } zonkCoFn env (WpCast co) = do { co' <- zonkTcLCoToLCo env co - ; return (env, WpCast co') } + ; return (env, WpCast co') } zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev - ; return (env', WpEvLam ev') } -zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg + ; return (env', WpEvLam ev') } +zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg ; return (env, WpEvApp arg') } zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv ) do { (env', tv') <- zonkTyBndrX env tv - ; return (env', WpTyLam tv') } + ; return (env', WpTyLam tv') } zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty - ; return (env, WpTyApp ty') } + ; return (env, WpTyApp ty') } zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs - ; return (env1, WpLet bs') } + ; return (env1, WpLet bs') } ------------------------------------------------------------------------- zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id) zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty }) - = do { ty' <- zonkTcTypeToType env ty - ; e' <- zonkExpr env e - ; return (lit { ol_witness = e', ol_type = ty' }) } + = do { ty' <- zonkTcTypeToType env ty + ; e' <- zonkExpr env e + ; return (lit { ol_witness = e', ol_type = ty' }) } ------------------------------------------------------------------------- zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id) zonkArithSeq env (From e) - = zonkLExpr env e `thenM` \ new_e -> - returnM (From new_e) + = do new_e <- zonkLExpr env e + return (From new_e) zonkArithSeq env (FromThen e1 e2) - = zonkLExpr env e1 `thenM` \ new_e1 -> - zonkLExpr env e2 `thenM` \ new_e2 -> - returnM (FromThen new_e1 new_e2) + = do new_e1 <- zonkLExpr env e1 + new_e2 <- zonkLExpr env e2 + return (FromThen new_e1 new_e2) zonkArithSeq env (FromTo e1 e2) - = zonkLExpr env e1 `thenM` \ new_e1 -> - zonkLExpr env e2 `thenM` \ new_e2 -> - returnM (FromTo new_e1 new_e2) + = do new_e1 <- zonkLExpr env e1 + new_e2 <- zonkLExpr env e2 + return (FromTo new_e1 new_e2) zonkArithSeq env (FromThenTo e1 e2 e3) - = zonkLExpr env e1 `thenM` \ new_e1 -> - zonkLExpr env e2 `thenM` \ new_e2 -> - zonkLExpr env e3 `thenM` \ new_e3 -> - returnM (FromThenTo new_e1 new_e2 new_e3) + = do new_e1 <- zonkLExpr env e1 + new_e2 <- zonkLExpr env e2 + new_e3 <- zonkLExpr env e3 + return (FromThenTo new_e1 new_e2 new_e3) ------------------------------------------------------------------------- -zonkStmts :: ZonkEnv +zonkStmts :: ZonkEnv -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) -> [LStmt TcId (Located (body TcId))] -> TcM (ZonkEnv, [LStmt Id (Located (body Id))]) zonkStmts env _ [] = return (env, []) @@ -855,21 +833,21 @@ zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody ; (env2, ss') <- zonkStmts env1 zBody ss ; return (env2, s' : ss') } -zonkStmt :: ZonkEnv +zonkStmt :: ZonkEnv -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id))) -> Stmt TcId (Located (body TcId)) -> TcM (ZonkEnv, Stmt Id (Located (body Id))) zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op) = do { new_stmts_w_bndrs <- mapM zonk_branch stmts_w_bndrs ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs] - env1 = extendIdZonkEnv env new_binders + env1 = extendIdZonkEnv env new_binders ; new_mzip <- zonkExpr env1 mzip_op ; new_bind <- zonkExpr env1 bind_op ; return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind) } where - zonk_branch (ParStmtBlock stmts bndrs return_op) + zonk_branch (ParStmtBlock stmts bndrs return_op) = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts ; new_return <- zonkExpr env1 return_op - ; return (ParStmtBlock new_stmts (zonkIdOccs env1 bndrs) new_return) } + ; return (ParStmtBlock new_stmts (zonkIdOccs env1 bndrs) new_return) } zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id @@ -883,8 +861,8 @@ zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_ ; new_bind_id <- zonkExpr env bind_id ; let env1 = extendIdZonkEnv env new_rvs ; (env2, new_segStmts) <- zonkStmts env1 zBody segStmts - -- Zonk the ret-expressions in an envt that - -- has the polymorphic bindings in the envt + -- Zonk the ret-expressions in an envt that + -- has the polymorphic bindings in the envt ; new_later_rets <- mapM (zonkExpr env2) later_rets ; new_rec_rets <- mapM (zonkExpr env2) rec_rets ; return (extendIdZonkEnv env new_lvs, -- Only the lvs are needed @@ -895,22 +873,22 @@ zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_ , recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) } zonkStmt env zBody (BodyStmt body then_op guard_op ty) - = zBody env body `thenM` \ new_body -> - zonkExpr env then_op `thenM` \ new_then -> - zonkExpr env guard_op `thenM` \ new_guard -> - zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (env, BodyStmt new_body new_then new_guard new_ty) + = do new_body <- zBody env body + new_then <- zonkExpr env then_op + new_guard <- zonkExpr env guard_op + new_ty <- zonkTcTypeToType env ty + return (env, BodyStmt new_body new_then new_guard new_ty) zonkStmt env zBody (LastStmt body ret_op) - = zBody env body `thenM` \ new_body -> - zonkExpr env ret_op `thenM` \ new_ret -> - returnM (env, LastStmt new_body new_ret) + = do new_body <- zBody env body + new_ret <- zonkExpr env ret_op + return (env, LastStmt new_body new_ret) zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap , trS_by = by, trS_form = form, trS_using = using , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op }) - = do { (env', stmts') <- zonkStmts env zonkLExpr stmts - ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap + = do { (env', stmts') <- zonkStmts env zonkLExpr stmts + ; binderMap' <- mapM (zonkBinderMapEntry env') binderMap ; by' <- fmapMaybeM (zonkLExpr env') by ; using' <- zonkLExpr env using ; return_op' <- zonkExpr env' return_op @@ -921,44 +899,45 @@ zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap , trS_by = by', trS_form = form, trS_using = using' , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) } where - zonkBinderMapEntry env (oldBinder, newBinder) = do + zonkBinderMapEntry env (oldBinder, newBinder) = do let oldBinder' = zonkIdOcc env oldBinder newBinder' <- zonkIdBndr env newBinder - return (oldBinder', newBinder') + return (oldBinder', newBinder') zonkStmt env _ (LetStmt binds) - = zonkLocalBinds env binds `thenM` \ (env1, new_binds) -> - returnM (env1, LetStmt new_binds) + = do (env1, new_binds) <- zonkLocalBinds env binds + return (env1, LetStmt new_binds) zonkStmt env zBody (BindStmt pat body bind_op fail_op) - = do { new_body <- zBody env body - ; (env1, new_pat) <- zonkPat env pat - ; new_bind <- zonkExpr env bind_op - ; new_fail <- zonkExpr env fail_op - ; return (env1, BindStmt new_pat new_body new_bind new_fail) } + = do { new_body <- zBody env body + ; (env1, new_pat) <- zonkPat env pat + ; new_bind <- zonkExpr env bind_op + ; new_fail <- zonkExpr env fail_op + ; return (env1, BindStmt new_pat new_body new_bind new_fail) } ------------------------------------------------------------------------- zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId) zonkRecFields env (HsRecFields flds dd) - = do { flds' <- mappM zonk_rbind flds - ; return (HsRecFields flds' dd) } + = do { flds' <- mapM zonk_rbind flds + ; return (HsRecFields flds' dd) } where zonk_rbind fld = do { new_id <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld) - ; new_expr <- zonkLExpr env (hsRecFieldArg fld) - ; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) } + ; new_expr <- zonkLExpr env (hsRecFieldArg fld) + ; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) } ------------------------------------------------------------------------- mapIPNameTc :: (a -> TcM b) -> Either HsIPName a -> TcM (Either HsIPName b) -mapIPNameTc _ (Left x) = returnM (Left x) -mapIPNameTc f (Right x) = f x `thenM` \ r -> returnM (Right r) +mapIPNameTc _ (Left x) = return (Left x) +mapIPNameTc f (Right x) = do r <- f x + return (Right r) \end{code} %************************************************************************ -%* * +%* * \subsection[BackSubst-Pats]{Patterns} -%* * +%* * %************************************************************************ \begin{code} @@ -970,97 +949,97 @@ zonkPat env pat = wrapLocSndM (zonk_pat env) pat zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id) zonk_pat env (ParPat p) - = do { (env', p') <- zonkPat env p - ; return (env', ParPat p') } + = do { (env', p') <- zonkPat env p + ; return (env', ParPat p') } zonk_pat env (WildPat ty) - = do { ty' <- zonkTcTypeToType env ty - ; return (env, WildPat ty') } + = do { ty' <- zonkTcTypeToType env ty + ; return (env, WildPat ty') } zonk_pat env (VarPat v) - = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnv1 env v', VarPat v') } + = do { v' <- zonkIdBndr env v + ; return (extendIdZonkEnv1 env v', VarPat v') } zonk_pat env (LazyPat pat) - = do { (env', pat') <- zonkPat env pat - ; return (env', LazyPat pat') } + = do { (env', pat') <- zonkPat env pat + ; return (env', LazyPat pat') } zonk_pat env (BangPat pat) - = do { (env', pat') <- zonkPat env pat - ; return (env', BangPat pat') } + = do { (env', pat') <- zonkPat env pat + ; return (env', BangPat pat') } zonk_pat env (AsPat (L loc v) pat) - = do { v' <- zonkIdBndr env v - ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat - ; return (env', AsPat (L loc v') pat') } + = do { v' <- zonkIdBndr env v + ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat + ; return (env', AsPat (L loc v') pat') } zonk_pat env (ViewPat expr pat ty) - = do { expr' <- zonkLExpr env expr - ; (env', pat') <- zonkPat env pat - ; ty' <- zonkTcTypeToType env ty - ; return (env', ViewPat expr' pat' ty') } + = do { expr' <- zonkLExpr env expr + ; (env', pat') <- zonkPat env pat + ; ty' <- zonkTcTypeToType env ty + ; return (env', ViewPat expr' pat' ty') } zonk_pat env (ListPat pats ty Nothing) - = do { ty' <- zonkTcTypeToType env ty - ; (env', pats') <- zonkPats env pats - ; return (env', ListPat pats' ty' Nothing) } - + = do { ty' <- zonkTcTypeToType env ty + ; (env', pats') <- zonkPats env pats + ; return (env', ListPat pats' ty' Nothing) } + zonk_pat env (ListPat pats ty (Just (ty2,wit))) - = do { wit' <- zonkExpr env wit + = do { wit' <- zonkExpr env wit ; ty2' <- zonkTcTypeToType env ty2 ; ty' <- zonkTcTypeToType env ty - ; (env', pats') <- zonkPats env pats - ; return (env', ListPat pats' ty' (Just (ty2',wit'))) } + ; (env', pats') <- zonkPats env pats + ; return (env', ListPat pats' ty' (Just (ty2',wit'))) } zonk_pat env (PArrPat pats ty) - = do { ty' <- zonkTcTypeToType env ty - ; (env', pats') <- zonkPats env pats - ; return (env', PArrPat pats' ty') } + = do { ty' <- zonkTcTypeToType env ty + ; (env', pats') <- zonkPats env pats + ; return (env', PArrPat pats' ty') } zonk_pat env (TuplePat pats boxed ty) - = do { ty' <- zonkTcTypeToType env ty - ; (env', pats') <- zonkPats env pats - ; return (env', TuplePat pats' boxed ty') } + = do { ty' <- zonkTcTypeToType env ty + ; (env', pats') <- zonkPats env pats + ; return (env', TuplePat pats' boxed ty') } zonk_pat env p@(ConPatOut { pat_ty = ty, pat_tvs = tyvars , pat_dicts = evs, pat_binds = binds , pat_args = args }) - = ASSERT( all isImmutableTyVar tyvars ) - do { new_ty <- zonkTcTypeToType env ty + = ASSERT( all isImmutableTyVar tyvars ) + do { new_ty <- zonkTcTypeToType env ty ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars -- Must zonk the existential variables, because their -- /kind/ need potential zonking. -- cf typecheck/should_compile/tc221.hs - ; (env1, new_evs) <- zonkEvBndrsX env0 evs - ; (env2, new_binds) <- zonkTcEvBinds env1 binds - ; (env', new_args) <- zonkConStuff env2 args - ; returnM (env', p { pat_ty = new_ty, - pat_tvs = new_tyvars, - pat_dicts = new_evs, - pat_binds = new_binds, - pat_args = new_args }) } + ; (env1, new_evs) <- zonkEvBndrsX env0 evs + ; (env2, new_binds) <- zonkTcEvBinds env1 binds + ; (env', new_args) <- zonkConStuff env2 args + ; return (env', p { pat_ty = new_ty, + pat_tvs = new_tyvars, + pat_dicts = new_evs, + pat_binds = new_binds, + pat_args = new_args }) } zonk_pat env (LitPat lit) = return (env, LitPat lit) zonk_pat env (SigPatOut pat ty) - = do { ty' <- zonkTcTypeToType env ty - ; (env', pat') <- zonkPat env pat - ; return (env', SigPatOut pat' ty') } + = do { ty' <- zonkTcTypeToType env ty + ; (env', pat') <- zonkPat env pat + ; return (env', SigPatOut pat' ty') } zonk_pat env (NPat lit mb_neg eq_expr) - = do { lit' <- zonkOverLit env lit - ; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg - ; eq_expr' <- zonkExpr env eq_expr - ; return (env, NPat lit' mb_neg' eq_expr') } + = do { lit' <- zonkOverLit env lit + ; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg + ; eq_expr' <- zonkExpr env eq_expr + ; return (env, NPat lit' mb_neg' eq_expr') } zonk_pat env (NPlusKPat (L loc n) lit e1 e2) - = do { n' <- zonkIdBndr env n - ; lit' <- zonkOverLit env lit - ; e1' <- zonkExpr env e1 - ; e2' <- zonkExpr env e2 - ; return (extendIdZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') } + = do { n' <- zonkIdBndr env n + ; lit' <- zonkOverLit env lit + ; e1' <- zonkExpr env e1 + ; e2' <- zonkExpr env e2 + ; return (extendIdZonkEnv1 env n', NPlusKPat (L loc n') lit' e1' e2') } -zonk_pat env (CoPat co_fn pat ty) +zonk_pat env (CoPat co_fn pat ty) = do { (env', co_fn') <- zonkCoFn env co_fn ; (env'', pat') <- zonkPat env' (noLoc pat) ; ty' <- zonkTcTypeToType env'' ty @@ -1074,49 +1053,49 @@ zonkConStuff :: ZonkEnv -> TcM (ZonkEnv, HsConDetails (OutPat Id) (HsRecFields id (OutPat Id))) zonkConStuff env (PrefixCon pats) - = do { (env', pats') <- zonkPats env pats - ; return (env', PrefixCon pats') } + = do { (env', pats') <- zonkPats env pats + ; return (env', PrefixCon pats') } zonkConStuff env (InfixCon p1 p2) - = do { (env1, p1') <- zonkPat env p1 - ; (env', p2') <- zonkPat env1 p2 - ; return (env', InfixCon p1' p2') } + = do { (env1, p1') <- zonkPat env p1 + ; (env', p2') <- zonkPat env1 p2 + ; return (env', InfixCon p1' p2') } zonkConStuff env (RecCon (HsRecFields rpats dd)) - = do { (env', pats') <- zonkPats env (map hsRecFieldArg rpats) - ; let rpats' = zipWith (\rp p' -> rp { hsRecFieldArg = p' }) rpats pats' - ; returnM (env', RecCon (HsRecFields rpats' dd)) } - -- Field selectors have declared types; hence no zonking + = do { (env', pats') <- zonkPats env (map hsRecFieldArg rpats) + ; let rpats' = zipWith (\rp p' -> rp { hsRecFieldArg = p' }) rpats pats' + ; return (env', RecCon (HsRecFields rpats' dd)) } + -- Field selectors have declared types; hence no zonking --------------------------- zonkPats :: ZonkEnv -> [OutPat TcId] -> TcM (ZonkEnv, [OutPat Id]) -zonkPats env [] = return (env, []) +zonkPats env [] = return (env, []) zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat - ; (env', pats') <- zonkPats env1 pats - ; return (env', pat':pats') } + ; (env', pats') <- zonkPats env1 pats + ; return (env', pat':pats') } \end{code} %************************************************************************ -%* * +%* * \subsection[BackSubst-Foreign]{Foreign exports} -%* * +%* * %************************************************************************ \begin{code} zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id] -zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls +zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id) zonkForeignExport env (ForeignExport i _hs_ty co spec) = - returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined co spec) -zonkForeignExport _ for_imp - = returnM for_imp -- Foreign imports don't need zonking + return (ForeignExport (fmap (zonkIdOcc env) i) undefined co spec) +zonkForeignExport _ for_imp + = return for_imp -- Foreign imports don't need zonking \end{code} \begin{code} zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id] -zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs +zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id) zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) @@ -1136,10 +1115,10 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) (varSetElemsKvsFirst unbound_tkvs) ++ new_bndrs - ; return $ + ; return $ HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs } where - zonk_bndr env (RuleBndr (L loc v)) + zonk_bndr env (RuleBndr (L loc v)) = do { (env', v') <- zonk_it env v ; return (env', RuleBndr (L loc v')) } zonk_bndr _ (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig" @@ -1149,14 +1128,14 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs) ; return (extendIdZonkEnv1 env v', v') } | otherwise = ASSERT( isImmutableTyVar v) zonkTyBndrX env v - -- DV: used to be return (env,v) but that is plain - -- wrong because we may need to go inside the kind + -- DV: used to be return (env,v) but that is plain + -- wrong because we may need to go inside the kind -- of v and zonk there! \end{code} \begin{code} zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id] -zonkVects env = mappM (wrapLocM (zonkVect env)) +zonkVects env = mapM (wrapLocM (zonkVect env)) zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id) zonkVect env (HsVect v e) @@ -1180,14 +1159,14 @@ zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn" \end{code} %************************************************************************ -%* * +%* * Constraints and evidence -%* * +%* * %************************************************************************ \begin{code} zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm -zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v ) +zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v ) return (EvId (zonkIdOcc env v)) zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcLCoToLCo env co ; return (EvCoercion co') } @@ -1211,9 +1190,9 @@ zonkEvTerm env (EvDelayedError ty msg) zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds) zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var - ; return (env', EvBinds bs') } + ; return (env', EvBinds bs') } zonkTcEvBinds env (EvBinds bs) = do { (env', bs') <- zonkEvBinds env bs - ; return (env', EvBinds bs') } + ; return (env', EvBinds bs') } zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind) zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref @@ -1223,12 +1202,12 @@ zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind) zonkEvBinds env binds = {-# SCC "zonkEvBinds" #-} fixM (\ ~( _, new_binds) -> do - { let env1 = extendIdZonkEnv env (collect_ev_bndrs new_binds) + { let env1 = extendIdZonkEnv env (collect_ev_bndrs new_binds) ; binds' <- mapBagM (zonkEvBind env1) binds ; return (env1, binds') }) where collect_ev_bndrs :: Bag EvBind -> [EvVar] - collect_ev_bndrs = foldrBag add [] + collect_ev_bndrs = foldrBag add [] add (EvBind var _) vars = var : vars zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind @@ -1240,21 +1219,21 @@ zonkEvBind env (EvBind var term) -- This has a very big effect on some programs (eg Trac #5030) ; let ty' = idType var' ; case getEqPredTys_maybe ty' of - Just (ty1, ty2) | ty1 `eqType` ty2 + Just (ty1, ty2) | ty1 `eqType` ty2 -> return (EvBind var' (EvCoercion (mkTcReflCo ty1))) - _other -> do { term' <- zonkEvTerm env term + _other -> do { term' <- zonkEvTerm env term ; return (EvBind var' term') } } \end{code} %************************************************************************ -%* * +%* * Zonking types -%* * +%* * %************************************************************************ Note [Zonking the LHS of a RULE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to gather the type variables mentioned on the LHS so we can +We need to gather the type variables mentioned on the LHS so we can quantify over them. Example: data T a = C @@ -1266,7 +1245,7 @@ quantify over them. Example: After type checking the LHS becomes (foo a (C a)) and we do not want to zap the unbound tyvar 'a' to (), because that limits the applicability of the rule. Instead, we -want to quantify over it! +want to quantify over it! It's easiest to get zonkTvCollecting to gather the free tyvars here. Attempts to do so earlier are tiresome, because (a) the data @@ -1300,11 +1279,11 @@ not the ill-kinded Any BOX). Note [Optimise coercion zonkind] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When optimising evidence binds we may come across situations where +When optimising evidence binds we may come across situations where a coercion looks like cv = ReflCo ty or cv1 = cv2 -where the type 'ty' is big. In such cases it is a waste of time to zonk both +where the type 'ty' is big. In such cases it is a waste of time to zonk both * The variable on the LHS * The coercion on the RHS Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just @@ -1321,13 +1300,13 @@ zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv SkolemTv {} -> lookup_in_env RuntimeUnk {} -> lookup_in_env FlatSkol ty -> zonkTcTypeToType env ty - MetaTv { mtv_ref = ref } + MetaTv { mtv_ref = ref } -> do { cts <- readMutVar ref - ; case cts of - Flexi -> do { kind <- {-# SCC "zonkKind1" #-} + ; case cts of + Flexi -> do { kind <- {-# SCC "zonkKind1" #-} zonkTcTypeToType env (tyVarKind tv) ; zonk_unbound_tyvar (setTyVarKind tv kind) } - Indirect ty -> do { zty <- zonkTcTypeToType env ty + Indirect ty -> do { zty <- zonkTcTypeToType env ty -- Small optimisation: shortern-out indirect steps -- so that the old type may be more easily collected. ; writeMutVar ref (Indirect zty) @@ -1345,7 +1324,9 @@ zonkTcTypeToType env ty = go ty where go (TyConApp tc tys) = do tys' <- mapM go tys - return (TyConApp tc tys') + return (mkTyConApp tc tys') + -- Establish Type invariants + -- See Note [Zonking inside the knot] in TcHsType go (LitTy n) = return (LitTy n) @@ -1356,11 +1337,11 @@ zonkTcTypeToType env ty go (AppTy fun arg) = do fun' <- go fun arg' <- go arg return (mkAppTy fun' arg') - -- NB the mkAppTy; we might have instantiated a - -- type variable to a type constructor, so we need - -- to pull the TyConApp to the top. + -- NB the mkAppTy; we might have instantiated a + -- type variable to a type constructor, so we need + -- to pull the TyConApp to the top. - -- The two interesting cases! + -- The two interesting cases! go (TyVarTy tv) = zonkTyVarOcc env tv go (ForAllTy tv ty) = ASSERT( isImmutableTyVar tv ) do diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index cde55a65fd..b0e7d7a789 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -18,13 +18,14 @@ module TcHsType ( UserTypeCtxt(..), -- Type checking type and class decls - kcTyClTyVars, tcTyClTyVars, + kcLookupKind, kcTyClTyVars, tcTyClTyVars, tcHsConArgType, tcDataKindSig, - tcClassSigType, + tcClassSigType, illegalRoleAnnot, -- Kind-checking types -- No kind generalisation, no checkValidType - kcHsTyVarBndrs, tcHsTyVarBndrs, + KindCheckingStrategy(..), kcStrategy, kcStrategyFamDecl, + kcHsTyVarBndrs, tcHsTyVarBndrs, tcHsLiftedType, tcHsOpenType, tcLHsType, tcCheckLHsType, tcHsContext, tcInferApps, tcHsArgTys, @@ -45,7 +46,6 @@ import {-# SOURCE #-} TcSplice( tcSpliceType ) #endif import HsSyn -import TcHsSyn ( zonkTcTypeToType, emptyZonkEnv ) import TcRnMonad import TcEvidence( HsWrapper ) import TcEnv @@ -55,8 +55,8 @@ import TcUnify import TcIface import TcType import Type +import TypeRep( Type(..) ) -- For the mkNakedXXX stuff import Kind -import TypeRep( mkNakedTyConApp ) import Var import VarSet import TyCon @@ -75,6 +75,7 @@ import UniqSupply import Outputable import FastString import Util +import Maybes import Control.Monad ( unless, when, zipWithM ) import PrelNames( ipClassName, funTyConKey ) @@ -185,18 +186,30 @@ tcHsSigTypeNC ctxt (L loc hs_ty) ; ty <- tcCheckHsTypeAndGen hs_ty kind -- Zonk to expose kind information to checkValidType - ; ty <- zonkTcType ty + ; ty <- zonkSigType ty ; checkValidType ctxt ty ; return ty } ----------------- tcHsInstHead :: UserTypeCtxt -> LHsType Name -> TcM ([TyVar], ThetaType, Class, [Type]) -- Like tcHsSigTypeNC, but for an instance head. -tcHsInstHead ctxt lhs_ty@(L loc hs_ty) +tcHsInstHead user_ctxt lhs_ty@(L loc hs_ty) = setSrcSpan loc $ -- The "In the type..." context comes from the caller - do { ty <- tcCheckHsTypeAndGen hs_ty constraintKind - ; ty <- zonkTcType ty - ; checkValidInstance ctxt lhs_ty ty } + do { inst_ty <- tc_inst_head hs_ty + ; kvs <- zonkTcTypeAndFV inst_ty + ; kvs <- kindGeneralize kvs + ; inst_ty <- zonkSigType (mkForAllTys kvs inst_ty) + ; checkValidInstance user_ctxt lhs_ty inst_ty } + +tc_inst_head :: HsType Name -> TcM TcType +tc_inst_head (HsForAllTy _ hs_tvs hs_ctxt hs_ty) + = tcHsTyVarBndrs hs_tvs $ \ tvs -> + do { ctxt <- tcHsContext hs_ctxt + ; ty <- tc_lhs_type hs_ty ekConstraint -- Body for forall has kind Constraint + ; return (mkSigmaTy tvs ctxt ty) } + +tc_inst_head hs_ty + = tc_hs_type hs_ty ekConstraint ----------------- tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type]) @@ -207,7 +220,7 @@ tcHsDeriv hs_ty -- Funny newtype deriving form -- forall a. C [a] -- where C has arity 2. Hence any-kinded result - ; ty <- zonkTcType ty + ; ty <- zonkSigType ty ; let (tvs, pred) = splitForAllTys ty ; case getClassPredTys_maybe pred of Just (cls, tys) -> return (tvs, cls, tys) @@ -243,7 +256,7 @@ tcClassSigType :: LHsType Name -> TcM Type tcClassSigType lhs_ty@(L _ hs_ty) = addTypeCtxt lhs_ty $ do { ty <- tcCheckHsTypeAndGen hs_ty liftedTypeKind - ; zonkTcTypeToType emptyZonkEnv ty } + ; zonkSigType ty } tcHsConArgType :: NewOrData -> LHsType Name -> TcM Type -- Permit a bang, but discard it @@ -293,7 +306,10 @@ tcCheckHsTypeAndGen :: HsType Name -> Kind -> TcM Type -- The result is not necessarily zonked, and has not been checked for validity tcCheckHsTypeAndGen hs_ty kind = do { ty <- tc_hs_type hs_ty (EK kind expectedKindMsg) - ; kvs <- kindGeneralize (tyVarsOfType ty) [] + ; traceTc "tcCheckHsTypeAndGen" (ppr hs_ty) + ; traceTc "tcCheckHsTypeAndGen" (ppr ty) + ; kvs <- zonkTcTypeAndFV ty + ; kvs <- kindGeneralize kvs ; return (mkForAllTys kvs ty) } \end{code} @@ -363,25 +379,34 @@ tc_hs_type hs_ty@(HsOpTy ty1 (_, l_op@(L _ op)) ty2) exp_kind -- mkNakedAppTys: see Note [Zonking inside the knot] tc_hs_type hs_ty@(HsAppTy ty1 ty2) exp_kind - | L _ (HsTyVar fun) <- fun_ty - , fun `hasKey` funTyConKey - , [fty1,fty2] <- arg_tys - = tc_fun_type hs_ty fty1 fty2 exp_kind - | otherwise +-- | L _ (HsTyVar fun) <- fun_ty +-- , fun `hasKey` funTyConKey +-- , [fty1,fty2] <- arg_tys +-- = tc_fun_type hs_ty fty1 fty2 exp_kind +-- | otherwise = do { (fun_ty', fun_kind) <- tc_infer_lhs_type fun_ty ; arg_tys' <- tcCheckApps hs_ty fun_ty fun_kind arg_tys exp_kind ; return (mkNakedAppTys fun_ty' arg_tys') } -- mkNakedAppTys: see Note [Zonking inside the knot] + -- This looks fragile; how do we *know* that fun_ty isn't + -- a TyConApp, say (which is never supposed to appear in the + -- function position of an AppTy)? where (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] --------- Foralls -tc_hs_type (HsForAllTy _ hs_tvs context ty) exp_kind +tc_hs_type hs_ty@(HsForAllTy _ hs_tvs context ty) exp_kind = tcHsTyVarBndrs hs_tvs $ \ tvs' -> -- Do not kind-generalise here! See Note [Kind generalisation] do { ctxt' <- tcHsContext context - ; ty' <- tc_lhs_type ty exp_kind - -- Why exp_kind? See Note [Body kind of forall] + ; ty' <- if null (unLoc context) then -- Plain forall, no context + tc_lhs_type ty exp_kind -- Why exp_kind? See Note [Body kind of forall] + else + -- If there is a context, then this forall is really a + -- _function_, so the kind of the result really is * + -- The body kind (result of the function can be * or #, hence ekOpen + do { checkExpectedKind hs_ty liftedTypeKind exp_kind + ; tc_lhs_type ty ekOpen } ; return (mkSigmaTy tvs' ctxt' ty') } --------- Lists, arrays, and tuples @@ -481,6 +506,9 @@ tc_hs_type (HsKindSig ty sig_k) exp_kind msg_fn pkind = ptext (sLit "The signature specified kind") <+> quotes (pprKind pkind) +tc_hs_type ty@(HsRoleAnnot {}) _ + = pprPanic "tc_hs_type HsRoleAnnot" (ppr ty) + tc_hs_type (HsCoreTy ty) exp_kind = do { checkExpectedKind ty (typeKind ty) exp_kind ; return ty } @@ -680,10 +708,76 @@ can't change it. So we must traverse the type. BUT the parent TyCon is knot-tied, so we can't look at it yet. So we must be careful not to use "smart constructors" for types that -look at the TyCon or Class involved. Hence the use of mkNakedXXX -functions. +look at the TyCon or Class involved. + + * Hence the use of mkNakedXXX functions. These do *not* enforce + the invariants (for example that we use (FunTy s t) rather + than (TyConApp (->) [s,t])). + + * Ditto in zonkTcType (which may be applied more than once, eg to + squeeze out kind meta-variables), we are careful not to look at + the TyCon. + + * We arrange to call zonkSigType *once* right at the end, and it + does establish the invariants. But in exchange we can't look + at the result (not even its structure) until we have emerged + from the "knot". -This is sadly delicate. + * TcHsSyn.zonkTcTypeToType also can safely check/establish + invariants. + +This is horribly delicate. I hate it. A good example of how +delicate it is can be seen in Trac #7903. + +\begin{code} +mkNakedTyConApp :: TyCon -> [Type] -> Type +-- Builds a TyConApp +-- * without being strict in TyCon, +-- * without satisfying the invariants of TyConApp +-- A subsequent zonking will establish the invariants +mkNakedTyConApp tc tys = TyConApp tc tys + +mkNakedAppTys :: Type -> [Type] -> Type +mkNakedAppTys ty1 [] = ty1 +mkNakedAppTys (TyConApp tc tys1) tys2 = mkNakedTyConApp tc (tys1 ++ tys2) +mkNakedAppTys ty1 tys2 = foldl AppTy ty1 tys2 + +zonkSigType :: TcType -> TcM TcType +-- Zonk the result of type-checking a user-written type signature +-- It may have kind varaibles in it, but no meta type variables +-- Because of knot-typing (see Note [Zonking inside the knot]) +-- it may need to establish the Type invariants; +-- hence the use of mkTyConApp and mkAppTy +zonkSigType ty + = go ty + where + go (TyConApp tc tys) = do tys' <- mapM go tys + return (mkTyConApp tc tys') + -- Key point: establish Type invariants! + -- See Note [Zonking inside the knot] + + go (LitTy n) = return (LitTy n) + + go (FunTy arg res) = do arg' <- go arg + res' <- go res + return (FunTy arg' res') + + go (AppTy fun arg) = do fun' <- go fun + arg' <- go arg + return (mkAppTy fun' arg') + -- NB the mkAppTy; we might have instantiated a + -- type variable to a type constructor, so we need + -- to pull the TyConApp to the top. + + -- The two interesting cases! + go (TyVarTy tyvar) | isTcTyVar tyvar = zonkTcTyVar tyvar + | otherwise = TyVarTy <$> updateTyVarKindM go tyvar + -- Ordinary (non Tc) tyvars occur inside quantified types + + go (ForAllTy tv ty) = do { tv' <- zonkTcTyVarBndr tv + ; ty' <- go ty + ; return (ForAllTy tv' ty') } +\end{code} Note [Body kind of a forall] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -818,22 +912,192 @@ addTypeCtxt (L _ ty) thing %* * %************************************************************************ -Note [Kind-checking kind-polymorphic types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - f :: forall (f::k -> *) a. f a -> Int +Note [Kind-checking strategies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are three main declarations that we have to kind check carefully in the +presence of -XPolyKinds: classes, datatypes, and data/type families. They each +have a different kind-checking strategy (labeled in the parentheses above each +section). This should potentially be cleaned up in the future, but this is how +it stands now (June 2013). -Here, the [LHsTyVarBndr Name] of the forall type will be [f,a], where - a is a UserTyVar -> type variable without kind annotation - f is a KindedTyVar -> type variable with kind annotation +Classes (ParametricKinds): + - kind-polymorphic by default + - each un-annotated type variable is given a fresh meta kind variable + - every explicit kind variable becomes a SigTv during inference + - no generalisation is done while kind-checking the recursive group + + Taken together, this means that classes cannot participate in polymorphic + recursion. Thus, the following is not definable: + + class Fugly (a :: k) where + foo :: forall (b :: k -> *). Fugly b => b a + + But, because explicit kind variables are SigTvs, it is OK for the kind to + be forced to be the same kind that is used in a separate declaration. See + test case polykinds/T7020.hs. + +Datatypes: + Here we have two cases, whether or not a Full Kind Signature is provided. + A Full Kind Signature means that there is a top-level :: in the definition + of the datatype. For example: + + data T1 :: k -> Bool -> * where ... -- YES + data T2 (a :: k) :: Bool -> * where ... -- YES + data T3 (a :: k) (b :: Bool) :: * where ... -- YES + data T4 (a :: k) (b :: Bool) where ... -- NO + + Kind signatures are not allowed on datatypes declared in the H98 style, + so those always have no Full Kind Signature. + + Full Kind Signature (FullKindSignature): + - each un-annotated type variable defaults to * + - every explicit kind variable becomes a skolem during type inference + - these kind variables are generalised *before* kind-checking the group + + With these rules, polymorphic recursion is possible. This is essentially + because of the generalisation step before kind-checking the group -- it + gives the kind-checker enough flexibility to supply the right kind arguments + to support polymorphic recursion. + + no Full Kind Signature (ParametricKinds): + - kind-polymorphic by default + - each un-annotated type variable is given a fresh meta kind variable + - every explicit kind variable becomes a SigTv during inference + - no generalisation is done while kind-checking the recursive group + + Thus, no polymorphic recursion in this case. See also Trac #6093 & #6049. + +Type families: + Here we have three cases: open top-level families, closed top-level families, + and open associated types. (There are no closed associated types, for good + reason.) + + Open top-level families (FullKindSignature): + - All open top-level families are considered to have a Full Kind Signature + - All arguments and the result default to * + - All kind variables are skolems + - All kind variables are generalised before kind-checking the group + + This behaviour supports kind-indexed type and data families, because we + need to have generalised before kind-checking for this to work. For example: + + type family F (a :: k) + type instance F Int = Bool + type instance F Maybe = Char + type instance F (x :: * -> * -> *) = Double + + Closed top-level families (NonParametricKinds): + - kind-monomorphic by default + - each un-annotated type variable is given a fresh meta kind variable + - every explicit kind variable becomes a skolem during inference + - all such skolems are generalised before kind-checking; other kind + variables are not generalised + - all unconstrained meta kind variables are defaulted to * at the + end of kind checking + + This behaviour is to allow kind inference to occur in closed families, but + without becoming too polymorphic. For example: + + type family F a where + F Int = Bool + F Bool = Char + + We would want F to have kind * -> * from this definition, although something + like k1 -> k2 would be perfectly sound. The reason we want this restriction is + that it is better to have (F Maybe) be a kind error than simply stuck. + + The kind inference gives us also + + type family Not b where + Not False = True + Not True = False + + With an open family, the above would need kind annotations in its header. + + The tricky case is + + type family G a (b :: k) where + G Int Int = False + G Bool Maybe = True + + We want this to work. But, we also want (G Maybe Maybe) to be a kind error + (in the first argument). So, we need to generalise the skolem "k" but not + the meta kind variable associated with "a". + + Associated families (FullKindSignature): + - Kind-monomorphic by default + - Result kind defaults to * + - Each type variable is either in the class header or not: + - Type variables in the class header are given the kind inherited from + the class header (and checked against an annotation, if any) + - Un-annotated type variables default to * + - Each kind variable mentioned in the class header becomes a SigTv during + kind inference. + - Each kind variable not mentioned in the class header becomes a skolem during + kind inference. + - Only the skolem kind variables are generalised before kind checking. + + Here are some examples: + + class Foo1 a b where + type Bar1 (a :: k) (b :: k) + + The kind of Foo1 will be k -> k -> Constraint. Kind annotations on associated + type declarations propagate to the header because the type variables in Bar1's + declaration inherit the (meta) kinds of the class header. -If were were to allow binding sites for kind variables, thus - f :: forall @k (f :: k -> *) a. f a -> Int -then we'd also need - k is a UserKiVar -> kind variable (they don't need annotation, - since we only have BOX for a super kind) + class Foo2 a where + type Bar2 a + + The kind of Bar2 will be k -> *. + + class Foo3 a where + type Bar3 a (b :: k) + meth :: Bar3 a Maybe -> () + + The kind of Bar3 will be k1 -> k2 -> *. This only kind-checks because the kind + of b is generalised before kind-checking. + + class Foo4 a where + type Bar4 a b + + Here, the kind of Bar4 will be k -> * -> *, because b is not mentioned in the + class header, so it defaults to *. \begin{code} +data KindCheckingStrategy -- See Note [Kind-checking strategies] + = ParametricKinds + | NonParametricKinds + | FullKindSignature + deriving (Eq) + +-- determine the appropriate strategy for a decl +kcStrategy :: TyClDecl Name -> KindCheckingStrategy +kcStrategy d@(ForeignType {}) = pprPanic "kcStrategy" (ppr d) +kcStrategy (FamDecl fam_decl) + = kcStrategyFamDecl fam_decl +kcStrategy (SynDecl {}) = ParametricKinds +kcStrategy (DataDecl { tcdDataDefn = HsDataDefn { dd_kindSig = m_ksig }}) + | Just _ <- m_ksig = FullKindSignature + | otherwise = ParametricKinds +kcStrategy (ClassDecl {}) = ParametricKinds + +-- if the ClosedTypeFamily has no equations, do the defaulting to *, etc. +kcStrategyFamDecl :: FamilyDecl Name -> KindCheckingStrategy +kcStrategyFamDecl (FamilyDecl { fdInfo = ClosedTypeFamily (_:_) }) = NonParametricKinds +kcStrategyFamDecl _ = FullKindSignature + +mkKindSigVar :: Name -> TcM KindVar +-- Use the specified name; don't clone it +mkKindSigVar n + = do { mb_thing <- tcLookupLcl_maybe n + ; case mb_thing of + Just (AThing k) + | Just kvar <- getTyVar_maybe k + -> return kvar + _ -> return $ mkTcTyVar n superKind (SkolemTv False) } + kcScopedKindVars :: [Name] -> TcM a -> TcM a -- Given some tyvar binders like [a (b :: k -> *) (c :: k)] -- bind each scoped kind variable (k in this case) to a fresh @@ -843,64 +1107,75 @@ kcScopedKindVars kv_ns thing_inside -- NB: use mutable signature variables ; tcExtendTyVarEnv2 (kv_ns `zip` kvs) thing_inside } -kcHsTyVarBndrs :: Bool -- True <=> full kind signature provided - -- Default UserTyVar to * - -- and use KindVars not meta kind vars +kcHsTyVarBndrs :: KindCheckingStrategy -> LHsTyVarBndrs Name - -> ([TcKind] -> TcM r) - -> TcM r + -> TcM (Kind, r) -- the result kind, possibly with other info + -> TcM (Kind, r, [Maybe Role]) +-- See Note [Role annotations] in TcTyClsDecls about the last return value -- Used in getInitialKind -kcHsTyVarBndrs full_kind_sig (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside - = do { kvs <- if full_kind_sig - then return (map mkKindSigVar kv_ns) +kcHsTyVarBndrs strat (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside + = do { kvs <- if skolem_kvs + then mapM mkKindSigVar kv_ns else mapM (\n -> newSigTyVar n superKind) kv_ns ; tcExtendTyVarEnv2 (kv_ns `zip` kvs) $ - do { nks <- mapM (kc_hs_tv . unLoc) hs_tvs - ; tcExtendKindEnv nks (thing_inside (map snd nks)) } } + do { (nks, mroles) <- mapAndUnzipM (kc_hs_tv . unLoc) hs_tvs + ; (res_kind, stuff) <- tcExtendKindEnv nks thing_inside + ; let full_kind = mkArrowKinds (map snd nks) res_kind + kvs = filter (not . isMetaTyVar) $ + varSetElems $ tyVarsOfType full_kind + gen_kind = if generalise + then mkForAllTys kvs full_kind + else full_kind + ; return (gen_kind, stuff, mroles) } } where - kc_hs_tv :: HsTyVarBndr Name -> TcM (Name, TcKind) - kc_hs_tv (UserTyVar n) + -- See Note [Kind-checking strategies] + (skolem_kvs, default_to_star, generalise) = case strat of + ParametricKinds -> (False, False, False) + NonParametricKinds -> (True, False, True) + FullKindSignature -> (True, True, True) + + kc_hs_tv :: HsTyVarBndr Name -> TcM ((Name, TcKind), Maybe Role) + kc_hs_tv (HsTyVarBndr n mk mr) = do { mb_thing <- tcLookupLcl_maybe n - ; kind <- case mb_thing of - Just (AThing k) -> return k - _ | full_kind_sig -> return liftedTypeKind - | otherwise -> newMetaKindVar - ; return (n, kind) } - kc_hs_tv (KindedTyVar n k) - = do { kind <- tcLHsKind k - -- In an associated type decl, the type variable may already - -- be in scope; in that case we want to make sure its kind - -- matches the one declared here - ; mb_thing <- tcLookupLcl_maybe n - ; case mb_thing of - Nothing -> return () - Just (AThing ks) -> checkKind kind ks - Just thing -> pprPanic "check_in_scope" (ppr thing) - ; return (n, kind) } - -tcScopedKindVars :: [Name] -> TcM a -> TcM a --- Given some tyvar binders like [a (b :: k -> *) (c :: k)] --- bind each scoped kind variable (k in this case) to a fresh --- kind skolem variable -tcScopedKindVars kv_ns thing_inside - = tcExtendTyVarEnv (map mkKindSigVar kv_ns) thing_inside + ; kind <- case (mb_thing, mk) of + (Just (AThing k1), Just k2) -> do { k2' <- tcLHsKind k2 + ; checkKind k1 k2' + ; return k1 } + (Just (AThing k), Nothing) -> return k + (Nothing, Just k) -> tcLHsKind k + (_, Nothing) + | default_to_star -> return liftedTypeKind + | otherwise -> newMetaKindVar + (Just thing, Just _) -> pprPanic "check_in_scope" (ppr thing) + ; is_boot <- tcIsHsBoot -- in boot files, roles default to R + ; let default_role = if is_boot then Just Representational else Nothing + ; return ((n, kind), firstJust mr default_role) } tcHsTyVarBndrs :: LHsTyVarBndrs Name -> ([TcTyVar] -> TcM r) -> TcM r --- Bind the type variables to skolems, each with a meta-kind variable kind -tcHsTyVarBndrs (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside - = tcScopedKindVars kvs $ - do { tvs <- mapM tcHsTyVarBndr hs_tvs - ; traceTc "tcHsTyVarBndrs" (ppr hs_tvs $$ ppr tvs) - ; tcExtendTyVarEnv tvs (thing_inside tvs) } +-- Bind the kind variables to fresh skolem variables +-- and type variables to skolems, each with a meta-kind variable kind +tcHsTyVarBndrs (HsQTvs { hsq_kvs = kv_ns, hsq_tvs = hs_tvs }) thing_inside + = do { kvs <- mapM mkKindSigVar kv_ns + ; tcExtendTyVarEnv kvs $ do + { tvs <- mapM tcHsTyVarBndr hs_tvs + ; traceTc "tcHsTyVarBndrs {" (vcat [ text "Hs kind vars:" <+> ppr kv_ns + , text "Hs type vars:" <+> ppr hs_tvs + , text "Kind vars:" <+> ppr kvs + , text "Type vars:" <+> ppr tvs ]) + ; res <- tcExtendTyVarEnv tvs (thing_inside (kvs ++ tvs)) + ; traceTc "tcHsTyVarBndrs }" (vcat [ text "Hs kind vars:" <+> ppr kv_ns + , text "Hs type vars:" <+> ppr hs_tvs + , text "Kind vars:" <+> ppr kvs + , text "Type vars:" <+> ppr tvs ]) + ; return res } } tcHsTyVarBndr :: LHsTyVarBndr Name -> TcM TcTyVar -- Return a type variable -- initialised with a kind variable. --- Typically the Kind inside the KindedTyVar will be a tyvar with a mutable kind --- in it. We aren't yet sure whether the binder is a *type* variable or a *kind* --- variable. See Note [Kind-checking kind-polymorphic types] +-- Typically the Kind inside the HsTyVarBndr will be a tyvar with a mutable kind +-- in it. -- -- If the variable is already in scope return it, instead of introducing a new -- one. This can occur in @@ -908,23 +1183,25 @@ tcHsTyVarBndr :: LHsTyVarBndr Name -> TcM TcTyVar -- type F (a,b) c = ... -- Here a,b will be in scope when processing the associated type instance for F. -- See Note [Associated type tyvar names] in Class -tcHsTyVarBndr (L _ hs_tv) - = do { let name = hsTyVarName hs_tv - ; mb_tv <- tcLookupLcl_maybe name +tcHsTyVarBndr (L _ (HsTyVarBndr name mkind Nothing)) + = do { mb_tv <- tcLookupLcl_maybe name ; case mb_tv of { Just (ATyVar _ tv) -> return tv ; _ -> do - { kind <- case hs_tv of - UserTyVar {} -> newMetaKindVar - KindedTyVar _ kind -> tcLHsKind kind + { kind <- case mkind of + Nothing -> newMetaKindVar + Just kind -> tcLHsKind kind ; return (mkTcTyVar name kind (SkolemTv False)) } } } +-- tcHsTyVarBndr is never called from a context where roles annotations are allowed +tcHsTyVarBndr (L _ (HsTyVarBndr name _ _)) + = addErrTc (illegalRoleAnnot name) >> failM + ------------------ -kindGeneralize :: TyVarSet -> [Name] -> TcM [KindVar] -kindGeneralize tkvs _names_to_avoid +kindGeneralize :: TyVarSet -> TcM [KindVar] +kindGeneralize tkvs = do { gbl_tvs <- tcGetGlobalTyVars -- Already zonked - ; tkvs <- zonkTyVarsAndFV tkvs - ; let kvs_to_quantify = filter isKindVar (varSetElems (tkvs `minusVarSet` gbl_tvs)) + ; quantifyTyVars gbl_tvs (filterVarSet isKindVar tkvs) } -- ToDo: remove the (filter isKindVar) -- Any type variables in tkvs will be in scope, -- and hence in gbl_tvs, so after removing gbl_tvs @@ -935,17 +1212,6 @@ kindGeneralize tkvs _names_to_avoid -- When typechecking the body of the bracket, we typecheck $t to a -- unification variable 'alpha', with no biding forall. We don't -- want to kind-quantify it! - - ; traceTc "kindGeneralise" (vcat [ppr kvs_to_quantify]) - ; ASSERT2 (all isKindVar kvs_to_quantify, ppr kvs_to_quantify $$ ppr tkvs) - -- This assertion is obviosly true because of the filter isKindVar - -- but we'll remove that when reorganising TH, and then the assertion - -- will mean something - - -- If we tidied the kind variables, which should all be mutable, - -- this 'zonkQuantifiedTyVars' update the original TyVar to point to - -- the tided and skolemised one - zonkQuantifiedTyVars kvs_to_quantify } \end{code} Note [Kind generalisation] @@ -1015,12 +1281,11 @@ kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside -- to match the kind variables they mention against the ones -- we've freshly brought into scope kc_tv :: LHsTyVarBndr Name -> Kind -> TcM (Name, Kind) - kc_tv (L _ (UserTyVar n)) exp_k - = return (n, exp_k) - kc_tv (L _ (KindedTyVar n hs_k)) exp_k - = do { k <- tcLHsKind hs_k - ; checkKind k exp_k - ; return (n, exp_k) } + kc_tv (L _ (HsTyVarBndr n mkind _)) exp_k + | Just hs_k <- mkind = do { k <- tcLHsKind hs_k + ; checkKind k exp_k + ; return (n, exp_k) } + | otherwise = return (n, exp_k) ----------------------- tcTyClTyVars :: Name -> LHsTyVarBndrs Name -- LHS of the type or class decl @@ -1052,10 +1317,10 @@ tcTyClTyVars tycon (HsQTvs { hsq_kvs = hs_kvs, hsq_tvs = hs_tvs }) thing_inside ; tvs <- zipWithM tc_hs_tv hs_tvs kinds ; tcExtendTyVarEnv tvs (thing_inside (kvs ++ tvs) res) } where - tc_hs_tv (L _ (UserTyVar n)) kind = return (mkTyVar n kind) - tc_hs_tv (L _ (KindedTyVar n hs_k)) kind = do { tc_kind <- tcLHsKind hs_k - ; checkKind kind tc_kind - ; return (mkTyVar n kind) } + tc_hs_tv (L _ (HsTyVarBndr n mkind _)) kind + = do { whenIsJust mkind $ \k -> do { tc_kind <- tcLHsKind k + ; checkKind kind tc_kind } + ; return $ mkTyVar n kind } ----------------------------------- tcDataKindSig :: Kind -> TcM [TyVar] @@ -1165,7 +1430,7 @@ tcHsPatSigType ctxt (HsWB { hswb_cts = hs_ty, hswb_kvs = sig_kvs, hswb_tvs = sig ; let ktv_binds = (sig_kvs `zip` kvs) ++ (sig_tvs `zip` tvs) ; sig_ty <- tcExtendTyVarEnv2 ktv_binds $ tcHsLiftedType hs_ty - ; sig_ty <- zonkTcType sig_ty + ; sig_ty <- zonkSigType sig_ty ; checkValidType ctxt sig_ty ; return (sig_ty, ktv_binds) } where @@ -1410,6 +1675,11 @@ checkExpectedKind ty act_kind (EK exp_kind ek_ctxt) ; traceTc "checkExpectedKind 1" (ppr ty $$ ppr tidy_act_kind $$ ppr tidy_exp_kind $$ ppr env1 $$ ppr env2) ; failWithTcM (env2, err) } } } + +illegalRoleAnnot :: Name -> SDoc +illegalRoleAnnot var + = ptext (sLit "Illegal role annotation on variable") <+> ppr var <> semi $$ + ptext (sLit "role annotations are not allowed here") \end{code} %************************************************************************ @@ -1555,7 +1825,7 @@ pprHsSigCtxt ctxt hs_ty = sep [ ptext (sLit "In") <+> pprUserTypeCtxt ctxt <> co pp_sig (ForSigCtxt n) = pp_n_colon n pp_sig _ = ppr (unLoc hs_ty) - pp_n_colon n = ppr n <+> dcolon <+> ppr (unLoc hs_ty) + pp_n_colon n = pprPrefixOcc n <+> dcolon <+> ppr (unLoc hs_ty) badPatSigTvs :: TcType -> [TyVar] -> SDoc badPatSigTvs sig_ty bad_tvs diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 9f6b571be4..1481b2552d 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -19,10 +19,7 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where import HsSyn import TcBinds -import TcTyClsDecls( tcAddImplicits, tcAddTyFamInstCtxt, tcAddDataFamInstCtxt, - tcSynFamInstDecl, - wrongKindOfFamily, tcFamTyPats, kcDataDefn, dataDeclChecks, - tcConDecls, checkValidTyCon ) +import TcTyClsDecls import TcClassDcl( tcClassDecl2, HsSigFun, lookupHsSig, mkHsSigFun, emptyHsSigs, findMethodBind, instantiateMethod, tcInstanceMethodBody ) @@ -31,7 +28,6 @@ import TcRnMonad import TcValidity import TcMType import TcType -import Coercion( mkSingleCoAxiom, mkBranchedCoAxiom, pprCoAxBranch ) import BuildTyCl import Inst import InstEnv @@ -42,7 +38,6 @@ import TcEnv import TcHsType import TcUnify import MkCore ( nO_METHOD_BINDING_ERROR_ID ) -import CoreSyn ( DFunArg(..) ) import Type import TcEvidence import TyCon @@ -51,10 +46,10 @@ import DataCon import Class import Var import VarEnv -import VarSet ( mkVarSet, subVarSet, varSetElems ) +import VarSet import Pair import CoreUnfold ( mkDFunUnfolding ) -import CoreSyn ( Expr(Var), CoreExpr ) +import CoreSyn ( Expr(Var, Type), CoreExpr, mkTyApps, mkVarApps ) import PrelNames ( tYPEABLE_INTERNAL, typeableClassName, oldTypeableClassNames ) import Bag @@ -67,6 +62,7 @@ import Id import MkId import Name import NameSet +import NameEnv import Outputable import SrcLoc import Util @@ -190,9 +186,9 @@ Instead we use a cunning trick. a suitable constructor application -- inlining df "on the fly" as it were. - * We give the ClassOp 'op2' a BuiltinRule that extracts the right piece - iff its argument satisfies exprIsConApp_maybe. This is done in - MkId mkDictSelId + * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that + extracts the right piece iff its argument satisfies + exprIsConApp_maybe. This is done in MkId mkDictSelId * We make 'df' CONLIKE, so that shared uses still match; eg let d = df d1 d2 @@ -456,7 +452,7 @@ addClsInsts :: [InstInfo Name] -> TcM a -> TcM a addClsInsts infos thing_inside = tcExtendLocalInstEnv (map iSpec infos) thing_inside -addFamInsts :: [FamInst Branched] -> TcM a -> TcM a +addFamInsts :: [FamInst] -> TcM a -> TcM a -- Extend (a) the family instance envt -- (b) the type envt with stuff from data type decls addFamInsts fam_insts thing_inside @@ -466,7 +462,7 @@ addFamInsts fam_insts thing_inside ; tcg_env <- tcAddImplicits things ; setGblEnv tcg_env thing_inside } where - axioms = map famInstAxiom fam_insts + axioms = map (toBranchedAxiom . famInstAxiom) fam_insts tycons = famInstsRepTyCons fam_insts things = map ATyCon tycons ++ map ACoAxiom axioms \end{code} @@ -490,7 +486,7 @@ the brutal solution will do. \begin{code} tcLocalInstDecl :: LInstDecl Name - -> TcM ([InstInfo Name], [FamInst Branched]) + -> TcM ([InstInfo Name], [FamInst]) -- A source-file instance declaration -- Type-check all the stuff before the "where" -- @@ -501,13 +497,13 @@ tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl })) tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl })) = do { fam_inst <- tcDataFamInstDecl Nothing (L loc decl) - ; return ([], [toBranchedFamInst fam_inst]) } + ; return ([], [fam_inst]) } tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) = do { (insts, fam_insts) <- tcClsInstDecl (L loc decl) - ; return (insts, map toBranchedFamInst fam_insts) } + ; return (insts, fam_insts) } -tcClsInstDecl :: LClsInstDecl Name -> TcM ([InstInfo Name], [FamInst Unbranched]) +tcClsInstDecl :: LClsInstDecl Name -> TcM ([InstInfo Name], [FamInst]) tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds , cid_sigs = uprags, cid_tyfam_insts = ats , cid_datafam_insts = adts })) @@ -534,7 +530,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds ; let defined_ats = mkNameSet $ map (tyFamInstDeclName . unLoc) ats defined_adts = mkNameSet $ map (unLoc . dfid_tycon . unLoc) adts - mk_deflt_at_instances :: ClassATItem -> TcM [FamInst Unbranched] + mk_deflt_at_instances :: ClassATItem -> TcM [FamInst] mk_deflt_at_instances (fam_tc, defs) -- User supplied instances ==> everything is OK | tyConName fam_tc `elemNameSet` defined_ats @@ -559,7 +555,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys' ; let axiom = mkSingleCoAxiom rep_tc_name tvs' fam_tc pat_tys' rhs' ; ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) - newFamInst SynFamilyInst False {- group -} axiom } + newFamInst SynFamilyInst axiom } ; tyfam_insts1 <- mapM mk_deflt_at_instances (classATItems clas) @@ -582,10 +578,10 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds tcAssocTyDecl :: Class -- Class of associated type -> VarEnv Type -- Instantiation of class TyVars -> LTyFamInstDecl Name - -> TcM (FamInst Unbranched) + -> TcM (FamInst) tcAssocTyDecl clas mini_env ldecl = do { fam_inst <- tcTyFamInstDecl (Just (clas, mini_env)) ldecl - ; return $ toUnbranchedFamInst fam_inst } + ; return fam_inst } \end{code} %************************************************************************ @@ -621,14 +617,12 @@ tcFamInstDeclCombined mb_clsinfo fam_tc_lname ; return fam_tc } tcTyFamInstDecl :: Maybe (Class, VarEnv Type) -- the class & mini_env if applicable - -> LTyFamInstDecl Name -> TcM (FamInst Branched) + -> LTyFamInstDecl Name -> TcM FamInst -- "type instance" -tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_group = group - , tfid_eqns = eqns })) +tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) = setSrcSpan loc $ tcAddTyFamInstCtxt decl $ - do { let (eqn1:_) = eqns - fam_lname = tfie_tycon (unLoc eqn1) + do { let fam_lname = tfie_tycon (unLoc eqn) ; fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_lname -- (0) Check it's an open type family @@ -638,36 +632,20 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_group = group (notOpenFamily fam_tc) -- (1) do the work of verifying the synonym group - ; co_ax_branches <- tcSynFamInstDecl fam_tc decl + ; co_ax_branch <- tcSynFamInstDecl fam_tc decl - -- (2) check for validity and inaccessibility - ; foldlM_ (check_valid_branch fam_tc) [] co_ax_branches + -- (2) check for validity + ; checkValidTyFamInst mb_clsinfo fam_tc co_ax_branch -- (3) construct coercion axiom ; rep_tc_name <- newFamInstAxiomName loc (tyFamInstDeclName decl) - (map cab_lhs co_ax_branches) - ; let axiom = mkBranchedCoAxiom rep_tc_name fam_tc co_ax_branches - ; newFamInst SynFamilyInst group axiom } - where - check_valid_branch :: TyCon - -> [CoAxBranch] -- previous - -> CoAxBranch -- current - -> TcM [CoAxBranch] -- current : previous - check_valid_branch fam_tc prev_branches cur_branch - = do { -- Check the well-formedness of the instance - checkValidTyFamInst mb_clsinfo fam_tc cur_branch - - -- Check whether the branch is dominated by earlier - -- ones and hence is inaccessible - ; when (cur_branch `isDominatedBy` prev_branches) $ - setSrcSpan (coAxBranchSpan cur_branch) $ - addErrTc $ inaccessibleCoAxBranch fam_tc cur_branch - - ; return $ cur_branch : prev_branches } + [co_ax_branch] + ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch + ; newFamInst SynFamilyInst axiom } tcDataFamInstDecl :: Maybe (Class, VarEnv Type) - -> LDataFamInstDecl Name -> TcM (FamInst Unbranched) + -> LDataFamInstDecl Name -> TcM FamInst -- "newtype instance" and "data instance" tcDataFamInstDecl mb_clsinfo (L loc decl@(DataFamInstDecl @@ -684,7 +662,8 @@ tcDataFamInstDecl mb_clsinfo ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc) -- Kind check type patterns - ; tcFamTyPats fam_tc pats (kcDataDefn defn) $ + ; tcFamTyPats (unLoc fam_tc_name) (tyConKind fam_tc) pats + (kcDataDefn (unLoc fam_tc_name) defn) $ \tvs' pats' res_kind -> do { -- Check that left-hand side contains no type family applications @@ -706,17 +685,19 @@ tcDataFamInstDecl mb_clsinfo ; let orig_res_ty = mkTyConApp fam_tc pats' ; (rep_tc, fam_inst) <- fixM $ \ ~(rec_rep_tc, _) -> - do { data_cons <- tcConDecls new_or_data rec_rep_tc + do { data_cons <- tcConDecls new_or_data (unLoc fam_tc_name) rec_rep_tc (tvs', orig_res_ty) cons ; tc_rhs <- case new_or_data of DataType -> return (mkDataTyConRhs data_cons) NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) -- freshen tyvars - ; let axiom = mkSingleCoAxiom axiom_name tvs' fam_tc pats' - (mkTyConApp rep_tc (mkTyVarTys tvs')) + ; let (eta_tvs, eta_pats) = eta_reduce tvs' pats' + axiom = mkSingleCoAxiom axiom_name eta_tvs fam_tc eta_pats + (mkTyConApp rep_tc (mkTyVarTys eta_tvs)) parent = FamInstTyCon axiom fam_tc pats' - rep_tc = buildAlgTyCon rep_tc_name tvs' cType stupid_theta tc_rhs + roles = map (const Nominal) tvs' + rep_tc = buildAlgTyCon rep_tc_name tvs' roles cType stupid_theta tc_rhs Recursive False -- No promotable to the kind level h98_syntax parent @@ -725,14 +706,53 @@ tcDataFamInstDecl mb_clsinfo -- further instance might not introduce a new recursive -- dependency. (2) They are always valid loop breakers as -- they involve a coercion. - ; fam_inst <- newFamInst (DataFamilyInst rep_tc) False axiom + ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom ; return (rep_tc, fam_inst) } -- Remember to check validity; no recursion to worry about here - ; checkValidTyCon rep_tc + ; let role_annots = unitNameEnv rep_tc_name (repeat Nothing) + ; checkValidTyCon rep_tc role_annots ; return fam_inst } } + where + -- See Note [Eta reduction for data family axioms] + -- [a,b,c,d].T [a] c Int c d ==> [a,b,c]. T [a] c Int c + eta_reduce tvs pats = go (reverse tvs) (reverse pats) + go (tv:tvs) (pat:pats) + | Just tv' <- getTyVar_maybe pat + , tv == tv' + , not (tv `elemVarSet` tyVarsOfTypes pats) + = go tvs pats + go tvs pats = (reverse tvs, reverse pats) \end{code} +Note [Eta reduction for data family axioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + data family T a b :: * + newtype instance T Int a = MkT (IO a) deriving( Monad ) +We'd like this to work. From the 'newtype instance' you might +think we'd get: + newtype TInt a = MkT (IO a) + axiom ax1 a :: T Int a ~ TInt a -- The type-instance part + axiom ax2 a :: TInt a ~ IO a -- The newtype part + +But now what can we do? We have this problem + Given: d :: Monad IO + Wanted: d' :: Monad (T Int) = d |> ???? +What coercion can we use for the ??? + +Solution: eta-reduce both axioms, thus: + axiom ax1 :: T Int ~ TInt + axiom ax2 :: TInt ~ IO +Now + d' = d |> Monad (sym (ax2 ; ax1)) + +This eta reduction happens both for data instances and newtype instances. + +See Note [Newtype eta] in TyCon. + + + %************************************************************************ %* * Type-checking instance declarations, pass 2 @@ -796,12 +816,11 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) ; dfun_ev_vars <- newEvVars dfun_theta - ; (sc_binds, sc_ev_vars, sc_dfun_args) - <- tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta' + ; (sc_binds, sc_ev_vars) <- tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta' -- Deal with 'SPECIALISE instance' pragmas -- See Note [SPECIALISE instance pragmas] - ; spec_inst_info <- tcSpecInstPrags dfun_id ibinds + ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds -- Typecheck the methods ; (meth_ids, meth_binds) @@ -831,11 +850,10 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) con_app_tys = wrapId (mkWpTyApps inst_tys) (dataConWrapId dict_constr) con_app_scs = mkHsWrap (mkWpEvApps (map EvId sc_ev_vars)) con_app_tys - con_app_args = foldl mk_app con_app_scs $ - map (wrapId arg_wrapper) meth_ids + con_app_args = foldl app_to_meth con_app_scs meth_ids - mk_app :: HsExpr Id -> HsExpr Id -> HsExpr Id - mk_app fun arg = HsApp (L loc fun) (L loc arg) + app_to_meth :: HsExpr Id -> Id -> HsExpr Id + app_to_meth fun meth_id = L loc fun `HsApp` L loc (wrapId arg_wrapper meth_id) inst_tv_tys = mkTyVarTys inst_tyvars arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys @@ -843,19 +861,26 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- Do not inline the dfun; instead give it a magic DFunFunfolding -- See Note [ClassOp/DFun selection] -- See also note [Single-method classes] - dfun_id_w_fun + (dfun_id_w_fun, dfun_spec_prags) | isNewTyCon class_tc - = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } + = ( dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } + , SpecPrags [] ) -- Newtype dfuns just inline unconditionally, + -- so don't attempt to specialise them | otherwise - = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_ty dfun_args - `setInlinePragma` dfunInlinePragma + = ( dfun_id `setIdUnfolding` mkDFunUnfolding (inst_tyvars ++ dfun_ev_vars) + dict_constr dfun_args + `setInlinePragma` dfunInlinePragma + , SpecPrags spec_inst_prags ) - dfun_args :: [DFunArg CoreExpr] - dfun_args = sc_dfun_args ++ map (DFunPolyArg . Var) meth_ids + dfun_args :: [CoreExpr] + dfun_args = map Type inst_tys ++ + map Var sc_ev_vars ++ + map mk_meth_app meth_ids + mk_meth_app meth_id = Var meth_id `mkTyApps` inst_tv_tys `mkVarApps` dfun_ev_vars export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id_w_fun - , abe_mono = self_dict, abe_prags = noSpecPrags } - -- NB: noSpecPrags, see Note [SPECIALISE instance pragmas] + , abe_mono = self_dict, abe_prags = dfun_spec_prags } + -- NB: see Note [SPECIALISE instance pragmas] main_bind = AbsBinds { abs_tvs = inst_tyvars , abs_ev_vars = dfun_ev_vars , abs_exports = [export] @@ -866,13 +891,12 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) listToBag meth_binds) } where - dfun_ty = idType dfun_id - dfun_id = instanceDFunId ispec - loc = getSrcSpan dfun_id + dfun_id = instanceDFunId ispec + loc = getSrcSpan dfun_id ------------------------------ tcSuperClasses :: DFunId -> [TcTyVar] -> [EvVar] -> TcThetaType - -> TcM (TcEvBinds, [EvVar], [DFunArg CoreExpr]) + -> TcM (TcEvBinds, [EvVar]) -- See Note [Silent superclass arguments] tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta = do { -- Check that all superclasses can be deduced from @@ -881,19 +905,18 @@ tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta emitWanteds ScOrigin sc_theta ; if null inst_tyvars && null dfun_ev_vars - then return (sc_binds, sc_evs, map (DFunPolyArg . Var) sc_evs) - else return (emptyTcEvBinds, sc_lam_args, sc_dfun_args) } + then return (sc_binds, sc_evs) + else return (emptyTcEvBinds, sc_lam_args) } where n_silent = dfunNSilent dfun_id - n_tv_args = length inst_tyvars orig_ev_vars = drop n_silent dfun_ev_vars - (sc_lam_args, sc_dfun_args) = unzip (map (find n_tv_args dfun_ev_vars) sc_theta) - find _ [] pred + sc_lam_args = map (find dfun_ev_vars) sc_theta + find [] pred = pprPanic "tcInstDecl2" (ppr dfun_id $$ ppr (idType dfun_id) $$ ppr pred) - find i (ev:evs) pred - | pred `eqPred` evVarPred ev = (ev, DFunLamArg i) - | otherwise = find (i+1) evs pred + find (ev:evs) pred + | pred `eqPred` evVarPred ev = ev + | otherwise = find evs pred ---------------------- mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar] @@ -1056,35 +1079,56 @@ Consider {-# SPECIALISE instance Ix (Int,Int) #-} range (x,y) = ... -We do *not* want to make a specialised version of the dictionary -function. Rather, we want specialised versions of each *method*. -Thus we should generate something like this: +We make a specialised version of the dictionary function, AND +specialised versions of each *method*. Thus we should generate +something like this: $dfIxPair :: (Ix a, Ix b) => Ix (a,b) - {- DFUN [$crangePair, ...] -} + {-# DFUN [$crangePair, ...] #-} + {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-} $dfIxPair da db = Ix ($crangePair da db) (...other methods...) $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)] {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-} $crange da db = <blah> - {-# RULE range ($dfIx da db) = $crange da db #-} +The SPECIALISE pragmas are acted upon by the desugarer, which generate + + dii :: Ix Int + dii = ... + + $s$dfIxPair :: Ix ((Int,Int),(Int,Int)) + {-# DFUN [$crangePair di di, ...] #-} + $s$dfIxPair = Ix ($crangePair di di) (...) + + {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-} + + $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)] + $c$crangePair = ...specialised RHS of $crangePair... + {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-} + Note that - * The RULE is unaffected by the specialisation. We don't want to - specialise $dfIx, because then it would need a specialised RULE - which is a pain. The single RULE works fine at all specialisations. - See Note [How instance declarations are translated] above + * The specialised dictionary $s$dfIxPair is very much needed, in case we + call a function that takes a dictionary, but in a context where the + specialised dictionary can be used. See Trac #7797. - * Instead, we want to specialise the *method*, $crange + * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because + it still has a DFunUnfolding. See Note [ClassOp/DFun selection] + + * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways: + --> {ClassOp rule for range} $crangePair Int Int d1 d2 + --> {SPEC rule for $crangePair} $s$crangePair + or thus: + --> {SPEC rule for $dfIxPair} range $s$dfIxPair + --> {ClassOpRule for range} $s$crangePair + It doesn't matter which way. + + * We want to specialise the RHS of both $dfIxPair and $crangePair, + but the SAME HsWrapper will do for both! We can call tcSpecPrag + just once, and pass the result (in spec_inst_info) to tcInstanceMethods. -In practice, rather than faking up a SPECIALISE pragama for each -method (which is painful, since we'd have to figure out its -specialised type), we call tcSpecPrag *as if* were going to specialise -$dfIx -- you can see that in the call to tcSpecInst. That generates a -SpecPrag which, as it turns out, can be used unchanged for each method. -The "it turns out" bit is delicate, but it works fine! \begin{code} tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag @@ -1437,7 +1481,6 @@ That is, just as if you'd written So for the above example we generate: - {-# INLINE $dmop1 #-} -- $dmop1 has an InlineCompulsory unfolding $dmop1 d b x = op2 d (not b) x @@ -1517,11 +1560,6 @@ badFamInstDecl tc_name quotes (ppr tc_name) , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ] -inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc -inaccessibleCoAxBranch tc fi - = ptext (sLit "Inaccessible family instance equation:") $$ - (pprCoAxBranch tc fi) - notOpenFamily :: TyCon -> SDoc notOpenFamily tc = ptext (sLit "Illegal instance for closed family") <+> quotes (ppr tc) diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 0a68584483..23d63ba178 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -20,12 +20,12 @@ import VarSet import Type import Unify import FamInstEnv -import Coercion( mkAxInstRHS ) +import InstEnv( lookupInstEnv, instanceDFunId ) import Var import TcType import PrelNames (singIClassName, ipClassNameKey ) - +import Id( idType ) import Class import TyCon import Name @@ -243,9 +243,14 @@ spontaneousSolveStage workItem = do { mb_solved <- trySpontaneousSolve workItem ; case mb_solved of SPCantSolve - | CTyEqCan { cc_tyvar = tv, cc_ev = fl } <- workItem + | CTyEqCan { cc_tyvar = tv, cc_rhs = rhs, cc_ev = fl } <- workItem -- Unsolved equality - -> do { n_kicked <- kickOutRewritable (ctEvFlavour fl) tv + -> do { untch <- getUntouchables + ; traceTcS "Can't solve tyvar equality" + (vcat [ text "LHS:" <+> ppr tv <+> dcolon <+> ppr (tyVarKind tv) + , text "RHS:" <+> ppr rhs <+> dcolon <+> ppr (typeKind rhs) + , text "Untouchables =" <+> ppr untch ]) + ; n_kicked <- kickOutRewritable (ctEvFlavour fl) tv ; traceFireTcS workItem $ ptext (sLit "Kept as inert") <+> ppr_kicked n_kicked <> colon <+> ppr workItem @@ -404,7 +409,8 @@ trySpontaneousSolve :: WorkItem -> TcS SPSolveResult trySpontaneousSolve workItem@(CTyEqCan { cc_ev = gw , cc_tyvar = tv1, cc_rhs = xi, cc_loc = d }) | isGiven gw - = return SPCantSolve + = do { traceTcS "No spontaneous solve for given" (ppr workItem) + ; return SPCantSolve } | Just tv2 <- tcGetTyVar_maybe xi = do { tch1 <- isTouchableMetaTyVarTcS tv1 ; tch2 <- isTouchableMetaTyVarTcS tv2 @@ -412,21 +418,17 @@ trySpontaneousSolve workItem@(CTyEqCan { cc_ev = gw (True, True) -> trySpontaneousEqTwoWay d gw tv1 tv2 (True, False) -> trySpontaneousEqOneWay d gw tv1 xi (False, True) -> trySpontaneousEqOneWay d gw tv2 (mkTyVarTy tv1) - _ -> return SPCantSolve } + _ -> return SPCantSolve } | otherwise = do { tch1 <- isTouchableMetaTyVarTcS tv1 ; if tch1 then trySpontaneousEqOneWay d gw tv1 xi - else do { untch <- getUntouchables - ; traceTcS "Untouchable LHS, can't spontaneously solve workitem" $ - vcat [text "Untouchables =" <+> ppr untch - , text "Workitem =" <+> ppr workItem ] - ; return SPCantSolve } - } + else return SPCantSolve } -- No need for -- trySpontaneousSolve (CFunEqCan ...) = ... -- See Note [No touchables as FunEq RHS] in TcSMonad -trySpontaneousSolve _ = return SPCantSolve +trySpontaneousSolve item = do { traceTcS "Spont: no tyvar on lhs" (ppr item) + ; return SPCantSolve } ---------------- trySpontaneousEqOneWay :: CtLoc -> CtEvidence @@ -457,57 +459,6 @@ trySpontaneousEqTwoWay d gw tv1 tv2 nicer_to_update_tv2 = isSigTyVar tv1 || isSystemName (Var.varName tv2) \end{code} -Note [Kind errors] -~~~~~~~~~~~~~~~~~~ -Consider the wanted problem: - alpha ~ (# Int, Int #) -where alpha :: ArgKind and (# Int, Int #) :: (#). We can't spontaneously solve this constraint, -but we should rather reject the program that give rise to it. If 'trySpontaneousEqTwoWay' -simply returns @CantSolve@ then that wanted constraint is going to propagate all the way and -get quantified over in inference mode. That's bad because we do know at this point that the -constraint is insoluble. Instead, we call 'recKindErrorTcS' here, which will fail later on. - -The same applies in canonicalization code in case of kind errors in the givens. - -However, when we canonicalize givens we only check for compatibility (@compatKind@). -If there were a kind error in the givens, this means some form of inconsistency or dead code. - -You may think that when we spontaneously solve wanteds we may have to look through the -bindings to determine the right kind of the RHS type. E.g one may be worried that xi is -@alpha@ where alpha :: ? and a previous spontaneous solving has set (alpha := f) with (f :: *). -But we orient our constraints so that spontaneously solved ones can rewrite all other constraint -so this situation can't happen. - -Note [Spontaneous solving and kind compatibility] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note that our canonical constraints insist that *all* equalities (tv ~ -xi) or (F xis ~ rhs) require the LHS and the RHS to have *compatible* -the same kinds. ("compatible" means one is a subKind of the other.) - - - It can't be *equal* kinds, because - b) wanted constraints don't necessarily have identical kinds - eg alpha::? ~ Int - b) a solved wanted constraint becomes a given - - - SPJ thinks that *given* constraints (tv ~ tau) always have that - tau has a sub-kind of tv; and when solving wanted constraints - in trySpontaneousEqTwoWay we re-orient to achieve this. - - - Note that the kind invariant is maintained by rewriting. - Eg wanted1 rewrites wanted2; if both were compatible kinds before, - wanted2 will be afterwards. Similarly givens. - -Caveat: - - Givens from higher-rank, such as: - type family T b :: * -> * -> * - type instance T Bool = (->) - - f :: forall a. ((T a ~ (->)) => ...) -> a -> ... - flop = f (...) True - Whereas we would be able to apply the type instance, we would not be able to - use the given (T Bool ~ (->)) in the body of 'flop' - - Note [Avoid double unifications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The spontaneous solver has to return a given which mentions the unified unification @@ -527,8 +478,6 @@ double unifications is the main reason we disallow touchable unification variables as RHS of type family equations: F xis ~ alpha. \begin{code} ----------------- - solveWithIdentity :: CtLoc -> CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult -- Solve with the identity coercion -- Precondition: kind(xi) is a sub-kind of kind(tv) @@ -1397,7 +1346,7 @@ doTopReact inerts workItem ; case workItem of CDictCan { cc_ev = fl, cc_class = cls, cc_tyargs = xis , cc_loc = d } - -> doTopReactDict inerts workItem fl cls xis d + -> doTopReactDict inerts fl cls xis d CFunEqCan { cc_ev = fl, cc_fun = tc, cc_tyargs = args , cc_rhs = xi, cc_loc = d } @@ -1407,42 +1356,31 @@ doTopReact inerts workItem return NoTopInt } -------------------- -doTopReactDict :: InertSet -> WorkItem -> CtEvidence -> Class -> [Xi] +doTopReactDict :: InertSet -> CtEvidence -> Class -> [Xi] -> CtLoc -> TcS TopInteractResult -doTopReactDict inerts workItem fl cls xis loc - = do { instEnvs <- getInstEnvs - ; let pred = mkClassPred cls xis - fd_eqns = improveFromInstEnv instEnvs (pred, arising_sdoc) - - ; fd_work <- rewriteWithFunDeps fd_eqns loc - ; if not (null fd_work) then - do { updWorkListTcS (extendWorkListEqs fd_work) - ; return SomeTopInt { tir_rule = "Dict/Top (fundeps)" - , tir_new_item = ContinueWith workItem } } - else if not (isWanted fl) then - return NoTopInt - else do - - { solved_dicts <- getTcSInerts >>= (return . inert_solved_dicts) - ; case lookupSolvedDict solved_dicts pred of { - Just ev -> do { setEvBind dict_id (ctEvTerm ev); - ; return $ - SomeTopInt { tir_rule = "Dict/Top (cached)" - , tir_new_item = Stop } } ; - Nothing -> do - - { lkup_inst_res <- matchClassInst inerts cls xis loc - ; case lkup_inst_res of - GenInst wtvs ev_term -> do { addSolvedDict fl - ; doSolveFromInstance wtvs ev_term } - NoInstance -> return NoTopInt } } } } +doTopReactDict inerts fl cls xis loc + | not (isWanted fl) + = try_fundeps_and_return + + | Just ev <- lookupSolvedDict inerts pred -- Cached + = do { setEvBind dict_id (ctEvTerm ev); + ; return $ SomeTopInt { tir_rule = "Dict/Top (cached)" + , tir_new_item = Stop } } + + | otherwise -- Not cached + = do { lkup_inst_res <- matchClassInst inerts cls xis loc + ; case lkup_inst_res of + GenInst wtvs ev_term -> do { addSolvedDict fl + ; solve_from_instance wtvs ev_term } + NoInstance -> try_fundeps_and_return } where arising_sdoc = pprArisingAt loc dict_id = ctEvId fl - - doSolveFromInstance :: [CtEvidence] -> EvTerm -> TcS TopInteractResult + pred = mkClassPred cls xis + + solve_from_instance :: [CtEvidence] -> EvTerm -> TcS TopInteractResult -- Precondition: evidence term matches the predicate workItem - doSolveFromInstance evs ev_term + solve_from_instance evs ev_term | null evs = do { traceTcS "doTopReact/found nullary instance for" $ ppr dict_id @@ -1462,11 +1400,23 @@ doTopReactDict inerts workItem fl cls xis loc SomeTopInt { tir_rule = "Dict/Top (solved, more work)" , tir_new_item = Stop } } + -- We didn't solve it; so try functional dependencies with + -- the instance environment, and return + -- NB: even if there *are* some functional dependencies against the + -- instance environment, there might be a unique match, and if + -- so we make sure we get on and solve it first. See Note [Weird fundeps] + try_fundeps_and_return + = do { instEnvs <- getInstEnvs + ; let fd_eqns = improveFromInstEnv instEnvs (pred, arising_sdoc) + ; fd_work <- rewriteWithFunDeps fd_eqns loc + ; unless (null fd_work) (updWorkListTcS (extendWorkListEqs fd_work)) + ; return NoTopInt } + -------------------- doTopReactFunEq :: Ct -> CtEvidence -> TyCon -> [Xi] -> Xi -> CtLoc -> TcS TopInteractResult doTopReactFunEq _ct fl fun_tc args xi loc - = ASSERT (isSynFamilyTyCon fun_tc) -- No associated data families have + = ASSERT(isSynFamilyTyCon fun_tc) -- No associated data families have -- reached this far -- Look in the cache of solved funeqs do { fun_eq_cache <- getTcSInerts >>= (return . inert_solved_funeqs) @@ -1481,17 +1431,13 @@ doTopReactFunEq _ct fl fun_tc args xi loc do { match_res <- matchFam fun_tc args -- See Note [MATCHING-SYNONYMS] ; case match_res of { Nothing -> return NoTopInt ; - Just (FamInstMatch { fim_instance = famInst - , fim_index = index - , fim_tys = rep_tys }) -> + Just (co, ty) -> -- Found a top-level instance do { -- Add it to the solved goals unless (isDerived fl) (addSolvedFunEq fam_ty fl xi) - ; let coe_ax = famInstAxiom famInst - ; succeed_with "Fun/Top" (mkTcAxInstCo coe_ax index rep_tys) - (mkAxInstRHS coe_ax index rep_tys) } } } } } + ; succeed_with "Fun/Top" co ty } } } } } where fam_ty = mkTyConApp fun_tc args @@ -1592,6 +1538,25 @@ and now we need improvement between that derived superclass an the Given (L a b) Test typecheck/should_fail/FDsFromGivens also shows why it's a good idea to emit Derived FDs for givens as well. +Note [Weird fundeps] +~~~~~~~~~~~~~~~~~~~~ +Consider class Het a b | a -> b where + het :: m (f c) -> a -> m b + + class GHet (a :: * -> *) (b :: * -> *) | a -> b + instance GHet (K a) (K [a]) + instance Het a b => GHet (K a) (K b) + +The two instances don't actually conflict on their fundeps, +although it's pretty strange. So they are both accepted. Now +try [W] GHet (K Int) (K Bool) +This triggers fudeps from both instance decls; but it also +matches a *unique* instance decl, and we should go ahead and +pick that one right now. Otherwise, if we don't, it ends up +unsolved in the inert set and is reported as an error. + +Trac #7875 is a case in point. + Note [Overriding implicit parameters] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1740,17 +1705,18 @@ matchClassInst _ clas [ k, ty ] _ case unwrapNewTyCon_maybe (classTyCon clas) of Just (_,dictRep, axDict) | Just tcSing <- tyConAppTyCon_maybe dictRep -> - do mbInst <- matchFam tcSing [k,ty] + do mbInst <- matchOpenFam tcSing [k,ty] case mbInst of Just FamInstMatch { fim_instance = FamInst { fi_axiom = axDataFam , fi_flavor = DataFamilyInst tcon } - , fim_index = ix, fim_tys = tys + , fim_tys = tys } | Just (_,_,axSing) <- unwrapNewTyCon_maybe tcon -> - + -- co1 and co3 are at role R, while co2 is at role N. + -- BUT, when desugaring to Coercions, the roles get fixed. do let co1 = mkTcSymCo $ mkTcUnbranchedAxInstCo axSing tys - co2 = mkTcSymCo $ mkTcAxInstCo axDataFam ix tys + co2 = mkTcSymCo $ mkTcUnbranchedAxInstCo axDataFam tys co3 = mkTcSymCo $ mkTcUnbranchedAxInstCo axDict [k,ty] return $ GenInst [] $ EvCast (EvLit evLit) $ mkTcTransCo co1 $ mkTcTransCo co2 co3 @@ -1763,44 +1729,60 @@ matchClassInst _ clas [ k, ty ] _ matchClassInst inerts clas tys loc = do { dflags <- getDynFlags - ; let pred = mkClassPred clas tys - incoherent_ok = xopt Opt_IncoherentInstances dflags - ; mb_result <- matchClass clas tys ; untch <- getUntouchables ; traceTcS "matchClassInst" $ vcat [ text "pred =" <+> ppr pred , text "inerts=" <+> ppr inerts , text "untouchables=" <+> ppr untch ] - ; case mb_result of - MatchInstNo -> return NoInstance - MatchInstMany -> return NoInstance -- defer any reactions of a multitude until - -- we learn more about the reagent - MatchInstSingle (_,_) - | not incoherent_ok && given_overlap untch - -> -- see Note [Instance and Given overlap] - do { traceTcS "Delaying instance application" $ - vcat [ text "Workitem=" <+> pprType (mkClassPred clas tys) - , text "Relevant given dictionaries=" <+> ppr givens_for_this_clas ] - ; return NoInstance - } - - MatchInstSingle (dfun_id, mb_inst_tys) -> - do { checkWellStagedDFun pred dfun_id loc - - -- mb_inst_tys :: Maybe TcType - -- See Note [DFunInstType: instantiating types] in InstEnv - - ; (tys, dfun_phi) <- instDFunType dfun_id mb_inst_tys - ; let (theta, _) = tcSplitPhiTy dfun_phi - ; if null theta then - return (GenInst [] (EvDFunApp dfun_id tys [])) - else do - { evc_vars <- instDFunConstraints theta - ; let new_ev_vars = freshGoals evc_vars - -- new_ev_vars are only the real new variables that can be emitted - dfun_app = EvDFunApp dfun_id tys (getEvTerms evc_vars) - ; return $ GenInst new_ev_vars dfun_app } } - } + ; instEnvs <- getInstEnvs + ; case lookupInstEnv instEnvs clas tys of + ([], _, _) -- Nothing matches + -> do { traceTcS "matchClass not matching" $ + vcat [ text "dict" <+> ppr pred ] + ; return NoInstance } + + ([(ispec, inst_tys)], [], _) -- A single match + | not (xopt Opt_IncoherentInstances dflags) + , given_overlap untch + -> -- See Note [Instance and Given overlap] + do { traceTcS "Delaying instance application" $ + vcat [ text "Workitem=" <+> pprType (mkClassPred clas tys) + , text "Relevant given dictionaries=" <+> ppr givens_for_this_clas ] + ; return NoInstance } + + | otherwise + -> do { let dfun_id = instanceDFunId ispec + ; traceTcS "matchClass success" $ + vcat [text "dict" <+> ppr pred, + text "witness" <+> ppr dfun_id + <+> ppr (idType dfun_id) ] + -- Record that this dfun is needed + ; match_one dfun_id inst_tys } + + (matches, _, _) -- More than one matches + -- Defer any reactions of a multitude + -- until we learn more about the reagent + -> do { traceTcS "matchClass multiple matches, deferring choice" $ + vcat [text "dict" <+> ppr pred, + text "matches" <+> ppr matches] + ; return NoInstance } } where + pred = mkClassPred clas tys + + match_one :: DFunId -> [Maybe TcType] -> TcS LookupInstResult + -- See Note [DFunInstType: instantiating types] in InstEnv + match_one dfun_id mb_inst_tys + = do { checkWellStagedDFun pred dfun_id loc + ; (tys, dfun_phi) <- instDFunType dfun_id mb_inst_tys + ; let (theta, _) = tcSplitPhiTy dfun_phi + ; if null theta then + return (GenInst [] (EvDFunApp dfun_id tys [])) + else do + { evc_vars <- instDFunConstraints theta + ; let new_ev_vars = freshGoals evc_vars + -- new_ev_vars are only the real new variables that can be emitted + dfun_app = EvDFunApp dfun_id tys (getEvTerms evc_vars) + ; return $ GenInst new_ev_vars dfun_app } } + givens_for_this_clas :: Cts givens_for_this_clas = lookupUFM (cts_given (inert_dicts $ inert_cans inerts)) clas diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index f0dd6e9ddd..481cb89ab0 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -25,7 +25,7 @@ module TcMType ( newFlexiTyVarTy, -- Kind -> TcM TcType newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] newPolyFlexiTyVarTy, - newMetaKindVar, newMetaKindVars, mkKindSigVar, + newMetaKindVar, newMetaKindVars, mkTcTyVarName, cloneMetaTyVar, newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, @@ -51,9 +51,9 @@ module TcMType ( -- Zonking zonkTcPredType, skolemiseSigTv, skolemiseUnboundMetaTyVar, - zonkTcTyVar, zonkTcTyVars, zonkTyVarsAndFV, - zonkQuantifiedTyVar, zonkQuantifiedTyVars, - zonkTcType, zonkTcTypes, zonkTcThetaType, + zonkTcTyVar, zonkTcTyVars, zonkTyVarsAndFV, zonkTcTypeAndFV, + zonkQuantifiedTyVar, quantifyTyVars, + zonkTcTyVarBndr, zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcKind, defaultKindVarToStar, zonkEvVar, zonkWC, zonkId, zonkCt, zonkCts, zonkSkolemInfo, @@ -112,10 +112,6 @@ newMetaKindVar = do { uniq <- newUnique newMetaKindVars :: Int -> TcM [TcKind] newMetaKindVars n = mapM (\ _ -> newMetaKindVar) (nOfThem n ()) - -mkKindSigVar :: Name -> KindVar --- Use the specified name; don't clone it -mkKindSigVar n = mkTcTyVar n superKind (SkolemTv False) \end{code} @@ -482,90 +478,59 @@ tcInstTyVarX subst tyvar %************************************************************************ %* * -\subsection{Zonking -- the exernal interfaces} + Quantification %* * %************************************************************************ -@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment. -To improve subsequent calls to the same function it writes the zonked set back into -the environment. - -\begin{code} -tcGetGlobalTyVars :: TcM TcTyVarSet -tcGetGlobalTyVars - = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv - ; gbl_tvs <- readMutVar gtv_var - ; gbl_tvs' <- zonkTyVarsAndFV gbl_tvs - ; writeMutVar gtv_var gbl_tvs' - ; return gbl_tvs' } - where -\end{code} - ------------------ Type variables - -\begin{code} -zonkTyVar :: TyVar -> TcM TcType --- Works on TyVars and TcTyVars -zonkTyVar tv | isTcTyVar tv = zonkTcTyVar tv - | otherwise = return (mkTyVarTy tv) - -- Hackily, when typechecking type and class decls - -- we have TyVars in scopeadded (only) in - -- TcHsType.tcTyClTyVars, but it seems - -- painful to make them into TcTyVars there - -zonkTyVarsAndFV :: TyVarSet -> TcM TyVarSet -zonkTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTyVar (varSetElems tyvars) - -zonkTcTyVars :: [TcTyVar] -> TcM [TcType] -zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars - ------------------ Types -zonkTyVarKind :: TyVar -> TcM TyVar -zonkTyVarKind tv = do { kind' <- zonkTcKind (tyVarKind tv) - ; return (setTyVarKind tv kind') } - -zonkTcTypes :: [TcType] -> TcM [TcType] -zonkTcTypes tys = mapM zonkTcType tys - -zonkTcThetaType :: TcThetaType -> TcM TcThetaType -zonkTcThetaType theta = mapM zonkTcPredType theta +Note [quantifyTyVars] +~~~~~~~~~~~~~~~~~~~~~ +quantifyTyVars is give the free vars of a type that we +are about to wrap in a forall. -zonkTcPredType :: TcPredType -> TcM TcPredType -zonkTcPredType = zonkTcType -\end{code} +It takes these free type/kind variables and + 1. Zonks them and remove globals + 2. Partitions into type and kind variables (kvs1, tvs) + 3. Extends kvs1 with free kind vars in the kinds of tvs (removing globals) + 4. Calls zonkQuantifiedTyVar on each -------------------- These ...ToType, ...ToKind versions - are used at the end of type checking +Step (3) is often unimportant, because the kind variable is often +also free in the type. Eg + Typeable k (a::k) +has free vars {k,a}. But the type (see Trac #7916) + (f::k->*) (a::k) +has free vars {f,a}, but we must add 'k' as well! Hence step (3). \begin{code} -defaultKindVarToStar :: TcTyVar -> TcM Kind --- We have a meta-kind: unify it with '*' -defaultKindVarToStar kv - = do { ASSERT ( isKindVar kv && isMetaTyVar kv ) - writeMetaTyVar kv liftedTypeKind - ; return liftedTypeKind } - -zonkQuantifiedTyVars :: [TcTyVar] -> TcM [TcTyVar] --- A kind variable k may occur *after* a tyvar mentioning k in its kind +quantifyTyVars :: TcTyVarSet -> TcTyVarSet -> TcM [TcTyVar] +-- See Note [quantifyTyVars] +-- The input is a mixture of type and kind variables; a kind variable k +-- may occur *after* a tyvar mentioning k in its kind -- Can be given a mixture of TcTyVars and TyVars, in the case of --- associated type declarations -zonkQuantifiedTyVars tyvars - = do { let (kvs, tvs) = partition isKindVar tyvars - (meta_kvs, skolem_kvs) - = partition (\kv -> isTcTyVar kv && isMetaTyVar kv) kvs +-- associated type declarations + +quantifyTyVars gbl_tvs tkvs + = do { tkvs <- zonkTyVarsAndFV tkvs + ; gbl_tvs <- zonkTyVarsAndFV gbl_tvs + ; let (kvs1, tvs) = partitionVarSet isKindVar (tkvs `minusVarSet` gbl_tvs) + kvs2 = varSetElems (foldVarSet add_kvs kvs1 tvs + `minusVarSet` gbl_tvs ) + add_kvs tv kvs = tyVarsOfType (tyVarKind tv) `unionVarSet` kvs + -- NB kinds of tvs are zonked by zonkTyVarsAndFV + qtvs = varSetElems tvs -- In the non-PolyKinds case, default the kind variables -- to *, and zonk the tyvars as usual. Notice that this - -- may make zonkQuantifiedTyVars return a shorter list + -- may make quantifyTyVars return a shorter list -- than it was passed, but that's ok ; poly_kinds <- xoptM Opt_PolyKinds - ; qkvs <- if poly_kinds - then return kvs - else WARN ( not (null skolem_kvs), ppr skolem_kvs ) - do { mapM_ defaultKindVarToStar meta_kvs - ; return skolem_kvs } -- Should be empty - - ; mapM zonk_quant (qkvs ++ tvs) } + ; qkvs <- if poly_kinds + then return kvs2 + else do { let (meta_kvs, skolem_kvs) = partition is_meta kvs2 + is_meta kv = isTcTyVar kv && isMetaTyVar kv + ; mapM_ defaultKindVarToStar meta_kvs + ; return skolem_kvs } -- should be empty + + ; mapM zonk_quant (qkvs ++ qtvs) } -- Because of the order, any kind variables -- mentioned in the kinds of the type variables refer to -- the now-quantified versions @@ -609,6 +574,13 @@ zonkQuantifiedTyVar tv skolemiseUnboundMetaTyVar tv vanillaSkolemTv _other -> pprPanic "zonkQuantifiedTyVar" (ppr tv) -- FlatSkol, RuntimeUnk +defaultKindVarToStar :: TcTyVar -> TcM Kind +-- We have a meta-kind: unify it with '*' +defaultKindVarToStar kv + = do { ASSERT( isKindVar kv && isMetaTyVar kv ) + writeMetaTyVar kv liftedTypeKind + ; return liftedTypeKind } + skolemiseUnboundMetaTyVar :: TcTyVar -> TcTyVarDetails -> TcM TyVar -- We have a Meta tyvar with a ref-cell inside it -- Skolemise it, including giving it a new Name, so that @@ -640,8 +612,139 @@ skolemiseSigTv tv skol_tv = setTcTyVarDetails tv (SkolemTv False) \end{code} +Note [Zonking to Skolem] +~~~~~~~~~~~~~~~~~~~~~~~~ +We used to zonk quantified type variables to regular TyVars. However, this +leads to problems. Consider this program from the regression test suite: + + eval :: Int -> String -> String -> String + eval 0 root actual = evalRHS 0 root actual + + evalRHS :: Int -> a + evalRHS 0 root actual = eval 0 root actual + +It leads to the deferral of an equality (wrapped in an implication constraint) + + forall a. () => ((String -> String -> String) ~ a) + +which is propagated up to the toplevel (see TcSimplify.tcSimplifyInferCheck). +In the meantime `a' is zonked and quantified to form `evalRHS's signature. +This has the *side effect* of also zonking the `a' in the deferred equality +(which at this point is being handed around wrapped in an implication +constraint). + +Finally, the equality (with the zonked `a') will be handed back to the +simplifier by TcRnDriver.tcRnSrcDecls calling TcSimplify.tcSimplifyTop. +If we zonk `a' with a regular type variable, we will have this regular type +variable now floating around in the simplifier, which in many places assumes to +only see proper TcTyVars. + +We can avoid this problem by zonking with a skolem. The skolem is rigid +(which we require for a quantified variable), but is still a TcTyVar that the +simplifier knows how to deal with. + +Note [Silly Type Synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + type C u a = u -- Note 'a' unused + + foo :: (forall a. C u a -> C u a) -> u + foo x = ... + + bar :: Num u => u + bar = foo (\t -> t + t) + +* From the (\t -> t+t) we get type {Num d} => d -> d + where d is fresh. + +* Now unify with type of foo's arg, and we get: + {Num (C d a)} => C d a -> C d a + where a is fresh. + +* Now abstract over the 'a', but float out the Num (C d a) constraint + because it does not 'really' mention a. (see exactTyVarsOfType) + The arg to foo becomes + \/\a -> \t -> t+t + +* So we get a dict binding for Num (C d a), which is zonked to give + a = () + [Note Sept 04: now that we are zonking quantified type variables + on construction, the 'a' will be frozen as a regular tyvar on + quantification, so the floated dict will still have type (C d a). + Which renders this whole note moot; happily!] + +* Then the \/\a abstraction has a zonked 'a' in it. + +All very silly. I think its harmless to ignore the problem. We'll end up with +a \/\a in the final result but all the occurrences of a will be zonked to () + +%************************************************************************ +%* * + Zonking +%* * +%************************************************************************ + +@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment. +To improve subsequent calls to the same function it writes the zonked set back into +the environment. + +\begin{code} +tcGetGlobalTyVars :: TcM TcTyVarSet +tcGetGlobalTyVars + = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv + ; gbl_tvs <- readMutVar gtv_var + ; gbl_tvs' <- zonkTyVarsAndFV gbl_tvs + ; writeMutVar gtv_var gbl_tvs' + ; return gbl_tvs' } + where +\end{code} + +----------------- Type variables + +\begin{code} +zonkTcTypeAndFV :: TcType -> TcM TyVarSet +-- Zonk a type and take its free variables +-- With kind polymorphism it can be essential to zonk *first* +-- so that we find the right set of free variables. Eg +-- forall k1. forall (a:k2). a +-- where k2:=k1 is in the substitution. We don't want +-- k2 to look free in this type! +zonkTcTypeAndFV ty = do { ty <- zonkTcType ty; return (tyVarsOfType ty) } + +zonkTyVar :: TyVar -> TcM TcType +-- Works on TyVars and TcTyVars +zonkTyVar tv | isTcTyVar tv = zonkTcTyVar tv + | otherwise = return (mkTyVarTy tv) + -- Hackily, when typechecking type and class decls + -- we have TyVars in scopeadded (only) in + -- TcHsType.tcTyClTyVars, but it seems + -- painful to make them into TcTyVars there + +zonkTyVarsAndFV :: TyVarSet -> TcM TyVarSet +zonkTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTyVar (varSetElems tyvars) + +zonkTcTyVars :: [TcTyVar] -> TcM [TcType] +zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars + +----------------- Types +zonkTyVarKind :: TyVar -> TcM TyVar +zonkTyVarKind tv = do { kind' <- zonkTcKind (tyVarKind tv) + ; return (setTyVarKind tv kind') } + +zonkTcTypes :: [TcType] -> TcM [TcType] +zonkTcTypes tys = mapM zonkTcType tys + +zonkTcThetaType :: TcThetaType -> TcM TcThetaType +zonkTcThetaType theta = mapM zonkTcPredType theta + +zonkTcPredType :: TcPredType -> TcM TcPredType +zonkTcPredType = zonkTcType +\end{code} + +--------------- Constraints + \begin{code} -zonkImplication :: Implication -> TcM Implication +zonkImplication :: Implication -> TcM (Bag Implication) zonkImplication implic@(Implic { ic_untch = untch , ic_binds = binds_var , ic_skols = skols @@ -653,11 +756,14 @@ zonkImplication implic@(Implic { ic_untch = untch ; given' <- mapM zonkEvVar given ; info' <- zonkSkolemInfo info ; wanted' <- zonkWCRec binds_var untch wanted - ; return (implic { ic_skols = skols' - , ic_given = given' - , ic_fsks = [] -- Zonking removes all FlatSkol tyvars - , ic_wanted = wanted' - , ic_info = info' }) } + ; if isEmptyWC wanted' + then return emptyBag + else return $ unitBag $ + implic { ic_fsks = [] -- Zonking removes all FlatSkol tyvars + , ic_skols = skols' + , ic_given = given' + , ic_wanted = wanted' + , ic_info = info' } } zonkEvVar :: EvVar -> TcM EvVar zonkEvVar var = do { ty' <- zonkTcType (varType var) @@ -675,7 +781,7 @@ zonkWCRec :: EvBindsVar -> WantedConstraints -> TcM WantedConstraints zonkWCRec binds_var untch (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) = do { flat' <- zonkFlats binds_var untch flat - ; implic' <- mapBagM zonkImplication implic + ; implic' <- flatMapBagM zonkImplication implic ; insol' <- zonkCts insol -- No need to do the more elaborate zonkFlats thing ; return (WC { wc_flat = flat', wc_impl = implic', wc_insol = insol' }) } @@ -699,9 +805,9 @@ zonkFlats binds_var untch cts , Just tv <- getTyVar_maybe ty_rhs , ASSERT2( not (isFloatedTouchableMetaTyVar untch tv), ppr tv ) isTouchableMetaTyVar untch tv - , typeKind ty_lhs `tcIsSubKind` tyVarKind tv + , not (isSigTyVar tv) || isTyVarTy ty_lhs -- Never unify a SigTyVar with a non-tyvar + , typeKind ty_lhs `tcIsSubKind` tyVarKind tv -- c.f. TcInteract.trySpontaneousEqOneWay , not (tv `elemVarSet` tyVarsOfType ty_lhs) --- , Just ty_lhs' <- occurCheck tv ty_lhs = ASSERT2( isWantedCt orig_ct, ppr orig_ct ) ASSERT2( case tcSplitTyConApp_maybe ty_lhs of { Just (tc,_) -> isSynFamilyTyCon tc; _ -> False }, ppr orig_ct ) do { writeMetaTyVar tv ty_lhs @@ -794,71 +900,6 @@ zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys zonkSkolemInfo skol_info = return skol_info \end{code} -Note [Silly Type Synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - type C u a = u -- Note 'a' unused - - foo :: (forall a. C u a -> C u a) -> u - foo x = ... - - bar :: Num u => u - bar = foo (\t -> t + t) - -* From the (\t -> t+t) we get type {Num d} => d -> d - where d is fresh. - -* Now unify with type of foo's arg, and we get: - {Num (C d a)} => C d a -> C d a - where a is fresh. - -* Now abstract over the 'a', but float out the Num (C d a) constraint - because it does not 'really' mention a. (see exactTyVarsOfType) - The arg to foo becomes - \/\a -> \t -> t+t - -* So we get a dict binding for Num (C d a), which is zonked to give - a = () - [Note Sept 04: now that we are zonking quantified type variables - on construction, the 'a' will be frozen as a regular tyvar on - quantification, so the floated dict will still have type (C d a). - Which renders this whole note moot; happily!] - -* Then the \/\a abstraction has a zonked 'a' in it. - -All very silly. I think its harmless to ignore the problem. We'll end up with -a \/\a in the final result but all the occurrences of a will be zonked to () - -Note [Zonking to Skolem] -~~~~~~~~~~~~~~~~~~~~~~~~ -We used to zonk quantified type variables to regular TyVars. However, this -leads to problems. Consider this program from the regression test suite: - - eval :: Int -> String -> String -> String - eval 0 root actual = evalRHS 0 root actual - - evalRHS :: Int -> a - evalRHS 0 root actual = eval 0 root actual - -It leads to the deferral of an equality (wrapped in an implication constraint) - - forall a. () => ((String -> String -> String) ~ a) - -which is propagated up to the toplevel (see TcSimplify.tcSimplifyInferCheck). -In the meantime `a' is zonked and quantified to form `evalRHS's signature. -This has the *side effect* of also zonking the `a' in the deferred equality -(which at this point is being handed around wrapped in an implication -constraint). - -Finally, the equality (with the zonked `a') will be handed back to the -simplifier by TcRnDriver.tcRnSrcDecls calling TcSimplify.tcSimplifyTop. -If we zonk `a' with a regular type variable, we will have this regular type -variable now floating around in the simplifier, which in many places assumes to -only see proper TcTyVars. - -We can avoid this problem by zonking with a skolem. The skolem is rigid -(which we require for a quantified variable), but is still a TcTyVar that the -simplifier knows how to deal with. %************************************************************************ @@ -886,6 +927,9 @@ zonkTcType ty where go (TyConApp tc tys) = do tys' <- mapM go tys return (TyConApp tc tys') + -- Do NOT establish Type invariants, because + -- doing so is strict in the TyCOn. + -- See Note [Zonking inside the knot] in TcHsType go (LitTy n) = return (LitTy n) @@ -899,6 +943,9 @@ zonkTcType ty -- NB the mkAppTy; we might have instantiated a -- type variable to a type constructor, so we need -- to pull the TyConApp to the top. + -- OK to do this because only strict in the structure + -- not in the TyCon. + -- See Note [Zonking inside the knot] in TcHsType -- The two interesting cases! go (TyVarTy tyvar) | isTcTyVar tyvar = zonkTcTyVar tyvar diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index f4759659d6..cb49d4de2f 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -15,7 +15,7 @@ TcPat: Typechecking patterns module TcPat ( tcLetPat, TcSigFun, TcSigInfo(..), TcPragFun , LetBndrSpec(..), addInlinePrags, warnPrags - , tcPat, tcPats, newNoSigLetBndr, newSigLetBndr + , tcPat, tcPats, newNoSigLetBndr , addDataConStupidTheta, badFieldCon, polyPatSig ) where #include "HsVersions.h" @@ -112,8 +112,8 @@ data PatCtxt = LamPat -- Used for lambdas, case etc (HsMatchContext Name) - | LetPat -- Used only for let(rec) bindings - -- See Note [Let binders] + | LetPat -- Used only for let(rec) pattern bindings + -- See Note [Typing patterns in pattern bindings] TcSigFun -- Tells type sig if any LetBndrSpec -- True <=> no generalisation of this let @@ -121,8 +121,10 @@ data LetBndrSpec = LetLclBndr -- The binder is just a local one; -- an AbsBinds will provide the global version - | LetGblBndr TcPragFun -- There isn't going to be an AbsBinds; - -- here is the inline-pragma information + | LetGblBndr TcPragFun -- Genrealisation plan is NoGen, so there isn't going + -- to be an AbsBinds; So we must bind the global version + -- of the binder right away. + -- Oh, and dhhere is the inline-pragma information makeLazy :: PatEnv -> PatEnv makeLazy penv = penv { pe_lazy = True } @@ -177,15 +179,6 @@ if the original function had a signature like But that's ok: tcMatchesFun (called by tcRhs) can deal with that It happens, too! See Note [Polymorphic methods] in TcClassDcl. -Note [Let binders] -~~~~~~~~~~~~~~~~~~ -eg x :: Int - y :: Bool - (x,y) = e - -...more notes to add here.. - - Note [Existential check] ~~~~~~~~~~~~~~~~~~~~~~~~ Lazy patterns can't bind existentials. They arise in two ways: @@ -215,13 +208,17 @@ tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (TcCoercion, TcId) -- Then coi : pat_ty ~ typeof(xp) -- tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty - | Just sig <- lookup_sig bndr_name - = do { bndr_id <- newSigLetBndr no_gen bndr_name sig + -- See Note [Typing patterns in pattern bindings] + | LetGblBndr prags <- no_gen + , Just sig <- lookup_sig bndr_name + = do { bndr_id <- addInlinePrags (sig_id sig) (prags bndr_name) + ; traceTc "tcPatBndr(gbl,sig)" (ppr bndr_id $$ ppr (idType bndr_id)) ; co <- unifyPatType (idType bndr_id) pat_ty ; return (co, bndr_id) } - | otherwise + | otherwise = do { bndr_id <- newNoSigLetBndr no_gen bndr_name pat_ty + ; traceTc "tcPatBndr(no-sig)" (ppr bndr_id $$ ppr (idType bndr_id)) ; return (mkTcReflCo pat_ty, bndr_id) } tcPatBndr (PE { pe_ctxt = _lam_or_proc }) bndr_name pat_ty @@ -229,20 +226,12 @@ tcPatBndr (PE { pe_ctxt = _lam_or_proc }) bndr_name pat_ty ; return (mkTcReflCo pat_ty, bndr) } ------------ -newSigLetBndr :: LetBndrSpec -> Name -> TcSigInfo -> TcM TcId -newSigLetBndr LetLclBndr name sig - = do { mono_name <- newLocalName name - ; mkLocalBinder mono_name (sig_tau sig) } -newSigLetBndr (LetGblBndr prags) name sig - = addInlinePrags (sig_id sig) (prags name) - ------------- newNoSigLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId --- In the polymorphic case (no_gen = False), generate a "monomorphic version" +-- In the polymorphic case (no_gen = LetLclBndr), generate a "monomorphic version" -- of the Id; the original name will be bound to the polymorphic version -- by the AbsBinds --- In the monomorphic case there is no AbsBinds, and we use the original --- name directly +-- In the monomorphic case (no_gen = LetBglBndr) there is no AbsBinds, and we +-- use the original name directly newNoSigLetBndr LetLclBndr name ty =do { mono_name <- newLocalName name ; mkLocalBinder mono_name ty } @@ -280,16 +269,34 @@ mkLocalBinder name ty = return (Id.mkLocalId name ty) \end{code} -Note [Polymorphism and pattern bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When is_mono holds we are not generalising -But the signature can still be polymorphic! - data T = MkT (forall a. a->a) +Note [Typing patterns in pattern bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are typing a pattern binding + pat = rhs +Then the PatCtxt will be (LetPat sig_fn let_bndr_spec). + +There can still be signatures for the binders: + data T = MkT (forall a. a->a) Int x :: forall a. a->a - MkT x = <rhs> -So the no_gen flag decides whether the pattern-bound variables should -have exactly the type in the type signature (when not generalising) or -the instantiated version (when generalising) + y :: Int + MkT x y = <rhs> + +Two cases, dealt with by the LetPat case of tcPatBndr + + * If we are generalising (generalisation plan is InferGen or + CheckGen), then the let_bndr_spec will be LetLclBndr. In that case + we want to bind a cloned, local version of the variable, with the + type given by the pattern context, *not* by the signature (even if + there is one; see Trac #7268). The mkExport part of the + generalisation step will do the checking and impedence matching + against the signature. + + * If for some some reason we are not generalising (plan = NoGen), the + LetBndrSpec will be LetGblBndr. In that case we must bind the + global version of the Id, and do so with precisely the type given + in the signature. (Then we unify with the type from the pattern + context type. + %************************************************************************ %* * @@ -678,6 +685,7 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside arg_tys' = substTys tenv arg_tys + ; traceTc "tcConPat" (ppr con_name $$ ppr ex_tvs' $$ ppr pat_ty' $$ ppr arg_tys') ; if null ex_tvs && null eq_spec && null theta then do { -- The common case; no class bindings etc -- (see Note [Arrows and patterns]) diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 275ce07089..b5bf4a7169 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -34,7 +34,7 @@ import TcHsSyn import TcExpr import TcRnMonad import TcEvidence -import Coercion( pprCoAxiom ) +import Coercion( pprCoAxiom, pprCoAxBranch ) import FamInst import InstEnv import FamInstEnv @@ -49,7 +49,6 @@ import TcInstDcls import TcIface import TcMType import MkIface -import IfaceSyn import TcSimplify import TcTyClsDecls import LoadIface @@ -75,7 +74,7 @@ import Outputable import DataCon import Type import Class -import CoAxiom ( CoAxBranch(..) ) +import CoAxiom import Inst ( tcGetInstEnvs ) import Data.List ( sortBy ) import Data.IORef ( readIORef ) @@ -460,6 +459,7 @@ tcRnSrcDecls boot_iface decls tcg_fords = fords' } } ; setGlobalTypeEnv tcg_env' final_type_env + } } tc_rn_src_decls :: ModDetails @@ -487,7 +487,7 @@ tc_rn_src_decls boot_details ds case group_tail of { Nothing -> do { tcg_env <- checkMain ; -- Check for `main' traceTc "returning from tc_rn_src_decls: " $ - ppr $ nameEnvElts $ tcg_type_env tcg_env ; -- RAE + ppr $ nameEnvElts $ tcg_type_env tcg_env ; return (tcg_env, tcl_env) } ; @@ -659,10 +659,7 @@ checkHiBootIface Just boot_thing <- mb_boot_thing = when (not (checkBootDecl boot_thing real_thing)) $ addErrAt (nameSrcSpan (getName boot_thing)) - (let boot_decl = tyThingToIfaceDecl - (fromJust mb_boot_thing) - real_decl = tyThingToIfaceDecl real_thing - in bootMisMatch real_thing boot_decl real_decl) + (bootMisMatch real_thing boot_thing) | otherwise = addErrTc (missingBootThing name "defined in") @@ -757,6 +754,7 @@ checkBootTyCon tc1 tc2 eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) in + roles1 == roles2 && -- Checks kind of class eqListBy eqFD clas_fds1 clas_fds2 && (null sc_theta1 && null op_stuff1 && null ats1 @@ -769,17 +767,22 @@ checkBootTyCon tc1 tc2 , Just syn_rhs2 <- synTyConRhs_maybe tc2 , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) = ASSERT(tc1 == tc2) - let eqSynRhs (SynFamilyTyCon o1 i1) (SynFamilyTyCon o2 i2) - = o1==o2 && i1==i2 + let eqSynRhs OpenSynFamilyTyCon OpenSynFamilyTyCon = True + eqSynRhs AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True + eqSynRhs (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True + eqSynRhs (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2) + = eqClosedFamilyAx ax1 ax2 eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2) = eqTypeX env t1 t2 eqSynRhs _ _ = False in + roles1 == roles2 && eqSynRhs syn_rhs1 syn_rhs2 | isAlgTyCon tc1 && isAlgTyCon tc2 , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) = ASSERT(tc1 == tc2) + roles1 == roles2 && eqListBy (eqPredX env) (tyConStupidTheta tc1) (tyConStupidTheta tc2) && eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2) @@ -789,6 +792,9 @@ checkBootTyCon tc1 tc2 | otherwise = False where + roles1 = tyConRoles tc1 + roles2 = tyConRoles tc2 + eqAlgRhs (AbstractTyCon dis1) rhs2 | dis1 = isDistinctAlgRhs rhs2 --Check compatibility | otherwise = True @@ -806,6 +812,19 @@ checkBootTyCon tc1 tc2 && dataConFieldLabels c1 == dataConFieldLabels c2 && eqType (dataConUserType c1) (dataConUserType c2) + eqClosedFamilyAx (CoAxiom { co_ax_branches = branches1 }) + (CoAxiom { co_ax_branches = branches2 }) + = brListLength branches1 == brListLength branches2 + && (and $ brListZipWith eqClosedFamilyBranch branches1 branches2) + + eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_lhs = lhs1, cab_rhs = rhs1 }) + (CoAxBranch { cab_tvs = tvs2, cab_lhs = lhs2, cab_rhs = rhs2 }) + | Just env <- eqTyVarBndrs emptyRnEnv2 tvs1 tvs2 + = eqListBy (eqTypeX env) lhs1 lhs2 && + eqTypeX env rhs1 rhs2 + + | otherwise = False + emptyRnEnv2 :: RnEnv2 emptyRnEnv2 = mkRnEnv2 emptyInScopeSet @@ -815,11 +834,25 @@ missingBootThing name what = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not") <+> text what <+> ptext (sLit "the module") -bootMisMatch :: TyThing -> IfaceDecl -> IfaceDecl -> SDoc -bootMisMatch thing boot_decl real_decl - = vcat [ppr thing <+> ptext (sLit "has conflicting definitions in the module and its hs-boot file"), - ptext (sLit "Main module:") <+> ppr real_decl, - ptext (sLit "Boot file: ") <+> ppr boot_decl] +bootMisMatch :: TyThing -> TyThing -> SDoc +bootMisMatch real_thing boot_thing + = vcat [ppr real_thing <+> + ptext (sLit "has conflicting definitions in the module"), + ptext (sLit "and its hs-boot file"), + ptext (sLit "Main module:") <+> ppr_mismatch real_thing, + ptext (sLit "Boot file: ") <+> ppr_mismatch boot_thing] + where + -- closed type families need special treatment, because they might differ + -- in their equations, which are not stored in the corresponding IfaceDecl + ppr_mismatch thing + | ATyCon tc <- thing + , Just (ClosedSynFamilyTyCon ax) <- synTyConRhs_maybe tc + = hang (ppr iface_decl <+> ptext (sLit "where")) + 2 (vcat $ brListMap (pprCoAxBranch tc) (coAxiomBranches ax)) + + | otherwise + = ppr iface_decl + where iface_decl = tyThingToIfaceDecl thing instMisMatch :: ClsInst -> SDoc instMisMatch inst @@ -956,7 +989,6 @@ tcTopSrcDecls boot_details -- tcg_dus: see Note [Newtype constructor usage in foreign declarations] addUsedRdrNames fo_rdr_names ; - traceTc "Tc8: type_env: " (ppr $ nameEnvElts $ tcg_type_env tcg_env') ; -- RAE return (tcg_env', tcl_env) }}}}}} where @@ -1099,32 +1131,36 @@ check_main dflags tcg_env <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod) pp_main_fn = ppMainFn main_fn -ppMainFn :: RdrName -> SDoc -ppMainFn main_fn - | main_fn == main_RDR_Unqual - = ptext (sLit "function") <+> quotes (ppr main_fn) - | otherwise - = ptext (sLit "main function") <+> quotes (ppr main_fn) - -- | Get the unqualified name of the function to use as the \"main\" for the main module. -- Either returns the default name or the one configured on the command line with -main-is getMainFun :: DynFlags -> RdrName -getMainFun dflags = case (mainFunIs dflags) of - Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) - Nothing -> main_RDR_Unqual +getMainFun dflags = case mainFunIs dflags of + Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) + Nothing -> main_RDR_Unqual checkMainExported :: TcGblEnv -> TcM () -checkMainExported tcg_env = do - dflags <- getDynFlags - case tcg_main tcg_env of - Nothing -> return () -- not the main module - Just main_name -> do - let main_mod = mainModIs dflags - checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $ - ptext (sLit "The") <+> ppMainFn (nameRdrName main_name) <+> - ptext (sLit "is not exported by module") <+> quotes (ppr main_mod) +checkMainExported tcg_env + = case tcg_main tcg_env of + Nothing -> return () -- not the main module + Just main_name -> + do { dflags <- getDynFlags + ; let main_mod = mainModIs dflags + ; checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $ + ptext (sLit "The") <+> ppMainFn (nameRdrName main_name) <+> + ptext (sLit "is not exported by module") <+> quotes (ppr main_mod) } + +ppMainFn :: RdrName -> SDoc +ppMainFn main_fn + | rdrNameOcc main_fn == mainOcc + = ptext (sLit "IO action") <+> quotes (ppr main_fn) + | otherwise + = ptext (sLit "main IO action") <+> quotes (ppr main_fn) + +mainOcc :: OccName +mainOcc = mkVarOccFS (fsLit "main") \end{code} + Note [Root-main Id] ~~~~~~~~~~~~~~~~~~~ The function that the RTS invokes is always :Main.main, which we call @@ -1494,7 +1530,7 @@ getGhciStepIO = do stepTy :: LHsType Name -- Renamed, so needs all binders in place stepTy = noLoc $ HsForAllTy Implicit - (HsQTvs { hsq_tvs = [noLoc (UserTyVar a_tv)] + (HsQTvs { hsq_tvs = [noLoc (HsTyVarBndr a_tv Nothing Nothing)] , hsq_kvs = [] }) (noLoc []) (nlHsFunTy ghciM ioM) @@ -1585,9 +1621,9 @@ tcRnType hsc_env ictxt normalise rdr_type ; ty' <- if normalise then do { fam_envs <- tcGetFamInstEnvs - ; return (snd (normaliseType fam_envs ty)) } + ; return (snd (normaliseType fam_envs Nominal ty)) } -- normaliseType returns a coercion - -- which we discard + -- which we discard, so the Role is irrelevant else return ty ; ; return (ty', typeKind ty) } @@ -1650,13 +1686,8 @@ tcRnDeclsi hsc_env ictxt local_decls = tcg_vects = vects', tcg_fords = fords' } - tcg_env'' <- setGlobalTypeEnv tcg_env' final_type_env - - traceTc "returning from tcRnDeclsi: " $ ppr $ nameEnvElts $ tcg_type_env tcg_env'' -- RAE - - return tcg_env'' - - + setGlobalTypeEnv tcg_env' final_type_env + #endif /* GHCi */ \end{code} @@ -1734,7 +1765,7 @@ tcRnLookupName' name = do tcRnGetInfo :: HscEnv -> Name - -> IO (Messages, Maybe (TyThing, Fixity, [ClsInst], [FamInst Branched])) + -> IO (Messages, Maybe (TyThing, Fixity, [ClsInst], [FamInst])) -- Used to implement :info in GHCi -- @@ -1759,13 +1790,13 @@ tcRnGetInfo hsc_env name (cls_insts, fam_insts) <- lookupInsts thing return (thing, fixity, cls_insts, fam_insts) -lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst Branched]) +lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst]) lookupInsts (ATyCon tc) | Just cls <- tyConClass_maybe tc = do { inst_envs <- tcGetInstEnvs ; return (classInstances inst_envs cls, []) } - | isFamilyTyCon tc || isTyConAssoc tc + | isOpenFamilyTyCon tc || isTyConAssoc tc = do { inst_envs <- tcGetFamInstEnvs ; return ([], familyInstances inst_envs tc) } @@ -1897,7 +1928,7 @@ ppr_types insts type_env -- that the type checker has invented. Top-level user-defined things -- have External names. -ppr_tycons :: [FamInst br] -> TypeEnv -> SDoc +ppr_tycons :: [FamInst] -> TypeEnv -> SDoc ppr_tycons fam_insts type_env = vcat [ text "TYPE CONSTRUCTORS" , nest 2 (ppr_tydecls tycons) @@ -1915,7 +1946,7 @@ ppr_insts :: [ClsInst] -> SDoc ppr_insts [] = empty ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs) -ppr_fam_insts :: [FamInst br] -> SDoc +ppr_fam_insts :: [FamInst] -> SDoc ppr_fam_insts [] = empty ppr_fam_insts fam_insts = text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts) diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 1d2772962d..84dcecfcf8 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -44,12 +44,12 @@ import Outputable import UniqSupply import UniqFM import DynFlags -import Maybes import StaticFlags import FastString import Panic import Util +import Control.Exception import Data.IORef import qualified Data.Set as Set import Control.Monad @@ -187,7 +187,11 @@ initTcPrintErrors -- Used from the interactive loop only initTcPrintErrors env mod todo = initTc env HsSrcFile False mod todo initTcForLookup :: HscEnv -> TcM a -> IO a -initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE +initTcForLookup hsc_env tcm + = do (msgs, m) <- initTc hsc_env HsSrcFile False iNTERACTIVE tcm + case m of + Nothing -> throwIO $ mkSrcErr $ snd msgs + Just x -> return x \end{code} %************************************************************************ @@ -309,7 +313,7 @@ getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a withDoDynamicToo m = do env <- getEnv let dflags = extractDynFlags env - dflags' = doDynamicToo dflags + dflags' = dynamicTooMkDynamicDynFlags dflags env' = replaceDynFlags env dflags' setEnv env' m \end{code} @@ -1103,7 +1107,7 @@ traceTcConstraints :: String -> TcM () traceTcConstraints msg = do { lie_var <- getConstraintVar ; lie <- readTcRef lie_var - ; traceTc (msg ++ "LIE:") (ppr lie) + ; traceTc (msg ++ ": LIE:") (ppr lie) } \end{code} diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 8331b62621..43b4f36aa2 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -298,7 +298,7 @@ data TcGblEnv tcg_anns :: [Annotation], -- ...Annotations tcg_tcs :: [TyCon], -- ...TyCons and Classes tcg_insts :: [ClsInst], -- ...Instances - tcg_fam_insts :: [FamInst Branched],-- ...Family instances + tcg_fam_insts :: [FamInst], -- ...Family instances tcg_rules :: [LRuleDecl Id], -- ...Rules tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports tcg_vects :: [LVectDecl Id], -- ...Vectorisation declarations @@ -885,7 +885,8 @@ data Ct cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] -- The ctev_pred of the evidence is -- of form (tv xi1 xi2 ... xin) - -- or (t1 ~ t2) where not (kind(t1) `compatKind` kind(t2) + -- or (tv1 ~ ty2) where the CTyEqCan kind invariant fails + -- or (F tys ~ ty) where the CFunEqCan kind invariant fails -- See Note [CIrredEvCan constraints] cc_loc :: CtLoc } @@ -893,8 +894,8 @@ data Ct | CTyEqCan { -- tv ~ xi (recall xi means function free) -- Invariant: -- * tv not in tvs(xi) (occurs check) - -- * typeKind xi `compatKind` typeKind tv - -- See Note [Spontaneous solving and kind compatibility] + -- * typeKind xi `subKind` typeKind tv + -- See Note [Kind orientation for CTyEqCan] -- * We prefer unification variables on the left *JUST* for efficiency cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] cc_tyvar :: TcTyVar, @@ -904,7 +905,8 @@ data Ct | CFunEqCan { -- F xis ~ xi -- Invariant: * isSynFamilyTyCon cc_fun - -- * typeKind (F xis) `compatKind` typeKind xi + -- * typeKind (F xis) `subKind` typeKind xi + -- See Note [Kind orientation for CFunEqCan] cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] cc_fun :: TyCon, -- A type function cc_tyargs :: [Xi], -- Either under-saturated or exactly saturated @@ -926,6 +928,49 @@ data Ct } \end{code} +Note [Kind orientation for CTyEqCan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given an equality (t:* ~ s:Open), we absolutely want to re-orient it. +We can't solve it by updating t:=s, ragardless of how touchable 't' is, +because the kinds don't work. Indeed we don't want to leave it with +the orientation (t ~ s), becuase if that gets into the inert set we'll +start replacing t's by s's, and that too is the wrong way round. + +Hence in a CTyEqCan, (t:k1 ~ xi:k2) we require that k2 is a subkind of k1. + +If the two have incompatible kinds, we just don't use a CTyEqCan at all. +See Note [Equalities with incompatible kinds] in TcCanonical + +We can't require *equal* kinds, because + * wanted constraints don't necessarily have identical kinds + eg alpha::? ~ Int + * a solved wanted constraint becomes a given + +Note [Kind orientation for CFunEqCan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For (F xis ~ rhs) we require that kind(rhs) is a subkind of kind(lhs). +This reallly only maters when rhs is an Open type variable (since only type +variables have Open kinds): + F ty ~ (a:Open) +which can happen, say, from + f :: F a b + f = undefined -- The a:Open comes from instantiating 'undefined' + +Note that the kind invariant is maintained by rewriting. +Eg wanted1 rewrites wanted2; if both were compatible kinds before, + wanted2 will be afterwards. Similarly givens. + +Caveat: + - Givens from higher-rank, such as: + type family T b :: * -> * -> * + type instance T Bool = (->) + + f :: forall a. ((T a ~ (->)) => ...) -> a -> ... + flop = f (...) True + Whereas we would be able to apply the type instance, we would not be able to + use the given (T Bool ~ (->)) in the body of 'flop' + + Note [CIrredEvCan constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ CIrredEvCan constraints are used for constraints that are "stuck" @@ -970,13 +1015,33 @@ ctPred :: Ct -> PredType ctPred ct = ctEvPred (cc_ev ct) dropDerivedWC :: WantedConstraints -> WantedConstraints -dropDerivedWC wc@(WC { wc_flat = flats }) - = wc { wc_flat = filterBag isWantedCt flats } - -- Don't filter the insolubles, because derived - -- insolubles should stay so that we report them. +-- See Note [Insoluble derived constraints] +dropDerivedWC wc@(WC { wc_flat = flats, wc_insol = insols }) + = wc { wc_flat = filterBag isWantedCt flats + , wc_insol = filterBag (not . isDerivedCt) insols } + -- Keep Givens from insols because they indicate unreachable code -- The implications are (recursively) already filtered \end{code} +Note [Insoluble derived constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we discard derived constraints at the end of constraint solving; +see dropDerivedWC. For example, + + * If we have an unsolved (Ord a), we don't want to complain about + an unsolved (Eq a) as well. + * If we have kind-incompatible (a::* ~ Int#::#) equality, we + don't want to complain about the kind error twice. + +Arguably, for *some* derived constraints we might want to report errors. +Notably, functional dependencies. If we have + class C a b | a -> b +and we have + [W] C a b, [W] C a c +where a,b,c are all signature variables. Then we could reasonably +report an error unifying (b ~ c). But it's probably not worth it; +after all, we also get an error because we can't discharge the constraint. + %************************************************************************ %* * @@ -1480,7 +1545,7 @@ pprSkolInfo :: SkolemInfo -> SDoc -- Complete the sentence "is a rigid type variable bound by..." pprSkolInfo (SigSkol (FunSigCtxt f) ty) = hang (ptext (sLit "the type signature for")) - 2 (ppr f <+> dcolon <+> ppr ty) + 2 (pprPrefixOcc f <+> dcolon <+> ppr ty) pprSkolInfo (SigSkol cx ty) = hang (pprUserTypeCtxt cx <> colon) 2 (ppr ty) pprSkolInfo (IPSkol ips) = ptext (sLit "the implicit-parameter bindings for") diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs index 1a569d02c7..2ef209c777 100644 --- a/compiler/typecheck/TcRules.lhs +++ b/compiler/typecheck/TcRules.lhs @@ -27,8 +27,6 @@ import TcEvidence( TcEvBinds(..) ) import Type import Id import Name -import Var -import VarSet import SrcLoc import Outputable import FastString @@ -121,10 +119,10 @@ revert to SimplCheck when going under an implication. * Step 2: Zonk the ORIGINAL lhs constraints, and partition them into the ones we will quantify over, and the others -* Step 3: Decide on the type varialbes to quantify over +* Step 3: Decide on the type variables to quantify over * Step 4: Simplify the LHS and RHS constraints separately, using the - quantified constraint sas givens + quantified constraints as givens \begin{code} @@ -162,16 +160,12 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) ; let tpl_ids = lhs_evs ++ id_bndrs forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids) - ; zonked_forall_tvs <- zonkTyVarsAndFV forall_tvs - ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked - ; let tvs_to_quantify = varSetElems (zonked_forall_tvs `minusVarSet` gbl_tvs) - ; qkvs <- kindGeneralize (tyVarsOfTypes (map tyVarKind tvs_to_quantify)) - (map getName tvs_to_quantify) - ; qtvs <- zonkQuantifiedTyVars tvs_to_quantify - ; let qtkvs = qkvs ++ qtvs + ; gbls <- tcGetGlobalTyVars -- Even though top level, there might be top-level + -- monomorphic bindings from the MR; test tc111 + ; qtkvs <- quantifyTyVars gbls forall_tvs ; traceTc "tcRule" (vcat [ doubleQuotes (ftext name) , ppr forall_tvs - , ppr qtvs + , ppr qtkvs , ppr rule_ty , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ] ]) diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 14ec1bad4d..0b2e484f7a 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -81,14 +81,12 @@ module TcSMonad ( newFlexiTcSTy, instFlexiTcS, instFlexiTcSHelperTcS, cloneMetaTyVar, - compatKind, mkKindErrorCtxtTcS, - Untouchables, isTouchableMetaTyVarTcS, isFilledMetaTyVar_maybe, zonkTyVarsAndFV, getDefaultInfo, getDynFlags, - matchClass, matchFam, MatchInstResult (..), + matchFam, matchOpenFam, checkWellStagedDFun, pprEq -- Smaller utils, re-exported from TcM -- TODO (DV): these are only really used in the @@ -110,7 +108,6 @@ import qualified TcRnMonad as TcM import qualified TcMType as TcM import qualified TcEnv as TcM ( checkWellStaged, topIdLvl, tcGetDefaultTys ) -import {-# SOURCE #-} qualified TcUnify as TcM ( mkKindErrorCtxt ) import Kind import TcType import DynFlags @@ -135,7 +132,7 @@ import TcRnTypes import Unique import UniqFM import Maybes ( orElse, catMaybes, firstJust ) -import StaticFlags( opt_NoFlatCache ) +import Pair ( pSnd ) import Control.Monad( unless, when, zipWithM ) import Data.IORef @@ -148,19 +145,6 @@ import Digraph #endif \end{code} - -\begin{code} -compatKind :: Kind -> Kind -> Bool -compatKind k1 k2 = k1 `tcIsSubKind` k2 || k2 `tcIsSubKind` k1 - -mkKindErrorCtxtTcS :: Type -> Kind - -> Type -> Kind - -> ErrCtxt -mkKindErrorCtxtTcS ty1 ki1 ty2 ki2 - = (False,TcM.mkKindErrorCtxt ty1 ty2 ki1 ki2) - -\end{code} - %************************************************************************ %* * %* Worklists * @@ -896,18 +880,19 @@ lookupFlatEqn fam_ty lookupInInerts :: TcPredType -> TcS (Maybe CtEvidence) -- Is this exact predicate type cached in the solved or canonicals of the InertSet lookupInInerts pty - = do { IS { inert_solved_dicts = solved, inert_cans = ics } <- getTcSInerts - ; case lookupSolvedDict solved pty of + = do { inerts <- getTcSInerts + ; case lookupSolvedDict inerts pty of Just ctev -> return (Just ctev) - Nothing -> return (lookupInInertCans ics pty) } + Nothing -> return (lookupInInertCans inerts pty) } -lookupSolvedDict :: PredMap CtEvidence -> TcPredType -> Maybe CtEvidence +lookupSolvedDict :: InertSet -> TcPredType -> Maybe CtEvidence -- Returns just if exactly this predicate type exists in the solved. -lookupSolvedDict tm pty = lookupTM pty $ unPredMap tm +lookupSolvedDict (IS { inert_solved_dicts = solved }) pty + = lookupTM pty (unPredMap solved) -lookupInInertCans :: InertCans -> TcPredType -> Maybe CtEvidence +lookupInInertCans :: InertSet -> TcPredType -> Maybe CtEvidence -- Returns Just if exactly this pred type exists in the inert canonicals -lookupInInertCans ics pty +lookupInInertCans (IS { inert_cans = ics }) pty = case (classifyPredType pty) of ClassPred cls _ -> lookupCCanMap cls (\ct -> ctEvPred ct `eqType` pty) (inert_dicts ics) @@ -1160,6 +1145,7 @@ getTcSInertsRef = TcS (return . tcs_inerts) getTcSWorkListRef :: TcS (IORef WorkList) getTcSWorkListRef = TcS (return . tcs_worklist) + getTcSInerts :: TcS InertSet getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef) @@ -1380,8 +1366,9 @@ newFlattenSkolem Given fam_ty ; let rhs_ty = mkTyVarTy tv ctev = CtGiven { ctev_pred = mkTcEqPred fam_ty rhs_ty , ctev_evtm = EvCoercion (mkTcReflCo fam_ty) } + ; dflags <- getDynFlags ; updInertTcS $ \ is@(IS { inert_fsks = fsks }) -> - extendFlatCache fam_ty ctev rhs_ty + extendFlatCache dflags fam_ty ctev rhs_ty is { inert_fsks = tv : fsks } ; return (ctev, rhs_ty) } @@ -1391,12 +1378,14 @@ newFlattenSkolem _ fam_ty -- Wanted or Derived: make new unification variable ; ctev <- newWantedEvVarNC (mkTcEqPred fam_ty rhs_ty) -- NC (no-cache) version because we've already -- looked in the solved goals an inerts (lookupFlatEqn) - ; updInertTcS $ extendFlatCache fam_ty ctev rhs_ty + ; dflags <- getDynFlags + ; updInertTcS $ extendFlatCache dflags fam_ty ctev rhs_ty ; return (ctev, rhs_ty) } -extendFlatCache :: TcType -> CtEvidence -> TcType -> InertSet -> InertSet -extendFlatCache - | opt_NoFlatCache +extendFlatCache :: DynFlags -> TcType -> CtEvidence -> TcType + -> InertSet -> InertSet +extendFlatCache dflags + | not (gopt Opt_FlatCache dflags) = \ _ _ _ is -> is | otherwise = \ fam_ty ctev rhs_ty is@(IS { inert_flat_cache = fc }) -> @@ -1646,48 +1635,30 @@ rewriteCtFlavor (CtWanted { ctev_evar = evar, ctev_pred = old_pred }) new_pred c --- Matching and looking up classes and family instances --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -data MatchInstResult mi - = MatchInstNo -- No matching instance - | MatchInstSingle mi -- Single matching instance - | MatchInstMany -- Multiple matching instances +matchOpenFam :: TyCon -> [Type] -> TcS (Maybe FamInstMatch) +matchOpenFam tycon args = wrapTcS $ tcLookupFamInst tycon args +matchFam :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType)) +matchFam tycon args + | isOpenSynFamilyTyCon tycon + = do { maybe_match <- matchOpenFam tycon args + ; case maybe_match of + Nothing -> return Nothing + Just (FamInstMatch { fim_instance = famInst + , fim_tys = inst_tys }) + -> let co = mkTcUnbranchedAxInstCo (famInstAxiom famInst) inst_tys + ty = pSnd $ tcCoercionKind co + in return $ Just (co, ty) } -matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Maybe TcType])) --- Look up a class constraint in the instance environment -matchClass clas tys - = do { let pred = mkClassPred clas tys - ; instEnvs <- getInstEnvs - ; case lookupInstEnv instEnvs clas tys of { - ([], _unifs, _) -- Nothing matches - -> do { traceTcS "matchClass not matching" $ - vcat [ text "dict" <+> ppr pred - {- , ppr instEnvs -} ] - - ; return MatchInstNo - } ; - ([(ispec, inst_tys)], [], _) -- A single match - -> do { let dfun_id = is_dfun ispec - ; traceTcS "matchClass success" $ - vcat [text "dict" <+> ppr pred, - text "witness" <+> ppr dfun_id - <+> ppr (idType dfun_id) ] - -- Record that this dfun is needed - ; return $ MatchInstSingle (dfun_id, inst_tys) - } ; - (matches, _unifs, _) -- More than one matches - -> do { traceTcS "matchClass multiple matches, deferring choice" $ - vcat [text "dict" <+> ppr pred, - text "matches" <+> ppr matches] - ; return MatchInstMany - } - } - } + | Just ax <- isClosedSynFamilyTyCon_maybe tycon + , Just (ind, inst_tys) <- chooseBranch ax args + = let co = mkTcAxInstCo ax ind inst_tys + ty = pSnd (tcCoercionKind co) + in return $ Just (co, ty) -matchFam :: TyCon -> [Type] -> TcS (Maybe FamInstMatch) -matchFam tycon args = wrapTcS $ tcLookupFamInst tycon args + | otherwise + = return Nothing + \end{code} \begin{code} diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index a1966108be..b17f3950a4 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -23,6 +23,7 @@ import TcMType as TcM import TcType import TcSMonad as TcS import TcInteract +import Kind ( defaultKind_maybe ) import Inst import FunDeps ( growThetaTyVars ) import Type ( classifyPredType, PredTree(..), getClassPredTys_maybe ) @@ -76,34 +77,53 @@ simplifyTop wanteds simpl_top :: WantedConstraints -> TcS WantedConstraints simpl_top wanteds = do { wc_first_go <- nestTcS (solve_wanteds_and_drop wanteds) - ; free_tvs <- TcS.zonkTyVarsAndFV (tyVarsOfWC wc_first_go) - ; let meta_tvs = filterVarSet isMetaTyVar free_tvs + -- This is where the main work happens + ; try_tyvar_defaulting wc_first_go } + + try_tyvar_defaulting :: WantedConstraints -> TcS WantedConstraints + try_tyvar_defaulting wc + | isEmptyWC wc + = return wc + | otherwise + = do { free_tvs <- TcS.zonkTyVarsAndFV (tyVarsOfWC wc) + ; let meta_tvs = varSetElems (filterVarSet isMetaTyVar free_tvs) -- zonkTyVarsAndFV: the wc_first_go is not yet zonked -- filter isMetaTyVar: we might have runtime-skolems in GHCi, -- and we definitely don't want to try to assign to those! - ; mapM_ defaultTyVar (varSetElems meta_tvs) -- Has unification side effects - ; simpl_top_loop wc_first_go } + ; meta_tvs' <- mapM defaultTyVar meta_tvs -- Has unification side effects + ; if meta_tvs' == meta_tvs -- No defaulting took place; + -- (defaulting returns fresh vars) + then try_class_defaulting wc + else do { wc_residual <- nestTcS (solve_wanteds_and_drop wc) + -- See Note [Must simplify after defaulting] + ; try_class_defaulting wc_residual } } - simpl_top_loop wc + try_class_defaulting :: WantedConstraints -> TcS WantedConstraints + try_class_defaulting wc | isEmptyWC wc || insolubleWC wc - -- Don't do type-class defaulting if there are insolubles - -- Doing so is not going to solve the insolubles - = return wc + = return wc -- Don't do type-class defaulting if there are insolubles + -- Doing so is not going to solve the insolubles | otherwise - = do { wc_residual <- nestTcS (solve_wanteds_and_drop wc) - ; let wc_flat_approximate = approximateWC wc_residual - ; something_happened <- applyDefaultingRules wc_flat_approximate - -- See Note [Top-level Defaulting Plan] - ; if something_happened then - simpl_top_loop wc_residual - else - return wc_residual } + = do { something_happened <- applyDefaultingRules (approximateWC wc) + -- See Note [Top-level Defaulting Plan] + ; if something_happened + then do { wc_residual <- nestTcS (solve_wanteds_and_drop wc) + ; try_class_defaulting wc_residual } + else return wc } \end{code} +Note [Must simplify after defaulting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We may have a deeply buried constraint + (t:*) ~ (a:Open) +which we couldn't solve because of the kind incompatibility, and 'a' is free. +Then when we default 'a' we can solve the constraint. And we want to do +that before starting in on type classes. We MUST do it before reporting +errors, because it isn't an error! Trac #7967 was due to this. + Note [Top-level Defaulting Plan] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We have considered two design choices for where/when to apply defaulting. (i) Do it in SimplCheck mode only /whenever/ you try to solve some flat constraints, maybe deep inside the context of implications. @@ -137,7 +157,7 @@ go with option (i), implemented at SimplifyTop. Namely: Now, that has to do with class defaulting. However there exists type variable /kind/ defaulting. Again this is done at the top-level and the plan is: - At the top-level, once you had a go at solving the constraint, do - figure out /all/ the touchable unification variables of the wanted contraints. + figure out /all/ the touchable unification variables of the wanted constraints. - Apply defaulting to their kinds More details in Note [DefaultTyVar]. @@ -184,18 +204,6 @@ simplifyDefault theta * * *********************************************************************************** -Note [Which variables to quantify] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose the inferred type of a function is - T kappa (alpha:kappa) -> Int -where alpha is a type unification variable and - kappa is a kind unification variable -Then we want to quantify over *both* alpha and kappa. But notice that -kappa appears "at top level" of the type, as well as inside the kind -of alpha. So it should be fine to just look for the "top level" -kind/type variables of the type, without looking transitively into the -kinds of those type variables. - \begin{code} simplifyInfer :: Bool -> Bool -- Apply monomorphism restriction @@ -210,13 +218,10 @@ simplifyInfer :: Bool TcEvBinds) -- ... binding these evidence variables simplifyInfer _top_lvl apply_mr name_taus wanteds | isEmptyWC wanteds - = do { gbl_tvs <- tcGetGlobalTyVars -- Already zonked - ; zonked_taus <- zonkTcTypes (map snd name_taus) - ; let tvs_to_quantify = varSetElems (tyVarsOfTypes zonked_taus `minusVarSet` gbl_tvs) - -- tvs_to_quantify can contain both kind and type vars - -- See Note [Which variables to quantify] - ; qtvs <- zonkQuantifiedTyVars tvs_to_quantify - ; return (qtvs, [], False, emptyTcEvBinds) } + = do { gbl_tvs <- tcGetGlobalTyVars + ; qtkvs <- quantifyTyVars gbl_tvs (tyVarsOfTypes (map snd name_taus)) + ; traceTc "simplifyInfer: emtpy WC" (ppr name_taus $$ ppr qtkvs) + ; return (qtkvs, [], False, emptyTcEvBinds) } | otherwise = do { traceTc "simplifyInfer {" $ vcat @@ -258,7 +263,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds ; tc_lcl_env <- TcRnMonad.getLclEnv ; let untch = tcl_untch tc_lcl_env - ; quant_pred_candidates + ; quant_pred_candidates -- Fully zonked <- if insolubleWC wanted_transformed then return [] -- See Note [Quantification with errors] else do { gbl_tvs <- tcGetGlobalTyVars @@ -280,52 +285,50 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds -- unifications that may have happened ; gbl_tvs <- tcGetGlobalTyVars ; zonked_tau_tvs <- TcM.zonkTyVarsAndFV (tyVarsOfTypes (map snd name_taus)) - ; let init_tvs = zonked_tau_tvs `minusVarSet` gbl_tvs - poly_qtvs = growThetaTyVars quant_pred_candidates init_tvs + ; let poly_qtvs = growThetaTyVars quant_pred_candidates zonked_tau_tvs `minusVarSet` gbl_tvs pbound = filter (quantifyPred poly_qtvs) quant_pred_candidates -- Monomorphism restriction - mr_qtvs = init_tvs `minusVarSet` constrained_tvs - constrained_tvs = tyVarsOfTypes quant_pred_candidates + constrained_tvs = tyVarsOfTypes pbound `unionVarSet` gbl_tvs mr_bites = apply_mr && not (null pbound) - (qtvs, bound) | mr_bites = (mr_qtvs, []) - | otherwise = (poly_qtvs, pbound) + ; (qtvs, bound) <- if mr_bites + then do { qtvs <- quantifyTyVars constrained_tvs zonked_tau_tvs + ; return (qtvs, []) } + else do { qtvs <- quantifyTyVars gbl_tvs poly_qtvs + ; return (qtvs, pbound) } ; traceTc "simplifyWithApprox" $ vcat [ ptext (sLit "quant_pred_candidates =") <+> ppr quant_pred_candidates , ptext (sLit "gbl_tvs=") <+> ppr gbl_tvs , ptext (sLit "zonked_tau_tvs=") <+> ppr zonked_tau_tvs , ptext (sLit "pbound =") <+> ppr pbound - , ptext (sLit "init_qtvs =") <+> ppr init_tvs - , ptext (sLit "poly_qtvs =") <+> ppr poly_qtvs ] - - ; if isEmptyVarSet qtvs && null bound - then do { traceTc "} simplifyInfer/no quantification" empty + , ptext (sLit "bbound =") <+> ppr bound + , ptext (sLit "poly_qtvs =") <+> ppr poly_qtvs + , ptext (sLit "constrained_tvs =") <+> ppr constrained_tvs + , ptext (sLit "mr_bites =") <+> ppr mr_bites + , ptext (sLit "qtvs =") <+> ppr qtvs ] + + ; if null qtvs && null bound + then do { traceTc "} simplifyInfer/no implication needed" empty ; emitConstraints wanted_transformed -- Includes insolubles (if -fdefer-type-errors) -- as well as flats and implications ; return ([], [], mr_bites, TcEvBinds ev_binds_var) } else do - { traceTc "simplifyApprox" $ - ptext (sLit "bound are =") <+> ppr bound - - -- Step 4, zonk quantified variables - ; let minimal_flat_preds = mkMinimalBySCs bound + { -- Step 7) Emit an implication + let minimal_flat_preds = mkMinimalBySCs bound skol_info = InferSkol [ (name, mkSigmaTy [] minimal_flat_preds ty) | (name, ty) <- name_taus ] -- Don't add the quantified variables here, because -- they are also bound in ic_skols and we want them to be -- tidied uniformly - ; qtvs_to_return <- zonkQuantifiedTyVars (varSetElems qtvs) - - -- Step 7) Emit an implication ; minimal_bound_ev_vars <- mapM TcM.newEvVar minimal_flat_preds ; let implic = Implic { ic_untch = pushUntouchables untch - , ic_skols = qtvs_to_return + , ic_skols = qtvs , ic_fsks = [] -- wanted_tansformed arose only from solveWanteds -- hence no flatten-skolems (which come from givens) , ic_given = minimal_bound_ev_vars @@ -339,11 +342,11 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds ; traceTc "} simplifyInfer/produced residual implication for quantification" $ vcat [ ptext (sLit "implic =") <+> ppr implic -- ic_skols, ic_given give rest of result - , ptext (sLit "qtvs =") <+> ppr qtvs_to_return + , ptext (sLit "qtvs =") <+> ppr qtvs , ptext (sLit "spb =") <+> ppr quant_pred_candidates , ptext (sLit "bound =") <+> ppr bound ] - ; return ( qtvs_to_return, minimal_bound_ev_vars + ; return ( qtvs, minimal_bound_ev_vars , mr_bites, TcEvBinds ev_binds_var) } } quantifyPred :: TyVarSet -- Quantifying over these @@ -375,8 +378,10 @@ having to be passed at each call site. But of course, the WHOLE IDEA is that ?y should be passed at each call site (that's what dynamic binding means) so we'd better infer the second. -BOTTOM LINE: when *inferring types* you *must* quantify -over implicit parameters. See the predicate isFreeWhenInferring. +BOTTOM LINE: when *inferring types* you must quantify over implicit +parameters, *even if* they don't mention the bound type variables. +Reason: because implicit parameters, uniquely, have local instance +declarations. See the predicate quantifyPred. Note [Quantification with errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -454,7 +459,7 @@ situations like When inferring a type for 'g', we don't want to apply the instance decl, because then we can't satisfy (C t). So we just notice that g isn't quantified over 't' and partition -the contraints before simplifying. +the constraints before simplifying. This only half-works, but then let-generalisation only half-works. @@ -511,7 +516,8 @@ simplifyRule name lhs_wanted rhs_wanted ; traceTc "simplifyRule" $ vcat [ ptext (sLit "LHS of rule") <+> doubleQuotes (ftext name) , text "zonked_lhs_flats" <+> ppr zonked_lhs_flats - , text "q_cts" <+> ppr q_cts ] + , text "q_cts" <+> ppr q_cts + , text "non_q_cts" <+> ppr non_q_cts ] ; return ( map (ctEvId . ctEvidence) (bagToList q_cts) , lhs_wanted { wc_flat = non_q_cts }) } @@ -796,7 +802,7 @@ defaultTyVar :: TcTyVar -> TcS TcTyVar -- Precondition: MetaTyVars only -- See Note [DefaultTyVar] defaultTyVar the_tv - | not (k `eqKind` default_k) + | Just default_k <- defaultKind_maybe (tyVarKind the_tv) = do { tv' <- TcS.cloneMetaTyVar the_tv ; let new_tv = setTyVarKind tv' default_k ; traceTcS "defaultTyVar" (ppr the_tv <+> ppr new_tv) @@ -807,9 +813,6 @@ defaultTyVar the_tv -- We keep the same Untouchables on tv' | otherwise = return the_tv -- The common case - where - k = tyVarKind the_tv - default_k = defaultKind k approximateWC :: WantedConstraints -> Cts -- Postcondition: Wanted or Derived Cts @@ -972,7 +975,7 @@ skolem has escaped! But it's ok: when we float (Maybe beta[2] ~ gamma[1]), we promote beta[2] to beta[1], and that means the (a ~ beta[1]) will be stuck, as it should be. -Previously we tried to "grow" the skol_set with the contraints, to get +Previously we tried to "grow" the skol_set with the constraints, to get all the tyvars that could *conceivably* unify with the skolems, but that was far too conservative (Trac #7804). Example: this should be fine: f :: (forall a. a -> Proxy x -> Proxy (F x)) -> Int @@ -1164,7 +1167,7 @@ disambigGroup (default_ty:default_tys) group -- discard all side effects from the attempt do { setWantedTyBind the_tv default_ty ; implics_from_defaulting <- solveInteract wanteds - ; MASSERT (isEmptyBag implics_from_defaulting) + ; MASSERT(isEmptyBag implics_from_defaulting) -- I am not certain if any implications can be generated -- but I am letting this fail aggressively if this ever happens. diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 87f35d8e77..2528e69d7e 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -76,7 +76,7 @@ import BasicTypes import DynFlags import Panic import FastString -import Control.Monad ( when ) +import Control.Monad ( when, zipWithM ) import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types @@ -358,7 +358,7 @@ tcBracket brack res_ty -- It's best to simplify the constraint now, even though in -- principle some later unification might be useful for it, -- because we don't want these essentially-junk TH implication - -- contraints floating around nested inside other constraints + -- constraints floating around nested inside other constraints -- See for example Trac #4949 ; _binds2 <- simplifyTop lie @@ -398,8 +398,13 @@ tc_bracket _ (TypBr typ) -- Result type is Type (= Q Typ) tc_bracket _ (DecBrG decls) - = do { _ <- tcTopSrcDecls emptyModDetails decls - -- Typecheck the declarations, dicarding the result + = do { _ <- setXOptM Opt_ExistentialQuantification $ + -- This is an EGREGIOUS HACK to make T5737 work. That test splices + -- in a type in a data constructor arg type, and then we try to + -- check validity for the data type decl, which fails because of + -- the pseudo-existential. Stupid. Will go away after the TH reorg + tcTopSrcDecls emptyModDetails decls + -- Typecheck the declarations, discarding the result -- We'll get all that stuff later, when we splice it in -- Top-level declarations in the bracket get unqualified names @@ -1010,38 +1015,28 @@ reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec] reifyInstances th_nm th_tys = addErrCtxt (ptext (sLit "In the argument of reifyInstances:") <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $ - do { thing <- getThing th_nm - ; case thing of - AGlobal (ATyCon tc) - | Just cls <- tyConClass_maybe tc - -> do { tys <- tc_types (classTyCon cls) th_tys - ; inst_envs <- tcGetInstEnvs - ; let (matches, unifies, _) = lookupInstEnv inst_envs cls tys - ; mapM reifyClassInstance (map fst matches ++ unifies) } - | otherwise - -> do { tys <- tc_types tc th_tys - ; inst_envs <- tcGetFamInstEnvs - ; let matches = lookupFamInstEnv inst_envs tc tys - ; mapM (reifyFamilyInstance . fim_instance) matches } - _ -> bale_out (ppr_th th_nm <+> ptext (sLit "is not a class or type constructor")) - } + do { loc <- getSrcSpanM + ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys) + ; (rn_ty, _fvs) <- checkNoErrs $ rnLHsType doc rdr_ty -- Rename to HsType Name + -- checkNoErrs: see Note [Renamer errors] + ; (ty, _kind) <- tcLHsType rn_ty + + ; case splitTyConApp_maybe ty of -- This expands any type synonyms + Just (tc, tys) -- See Trac #7910 + | Just cls <- tyConClass_maybe tc + -> do { inst_envs <- tcGetInstEnvs + ; let (matches, unifies, _) = lookupInstEnv inst_envs cls tys + ; mapM reifyClassInstance (map fst matches ++ unifies) } + | isOpenFamilyTyCon tc + -> do { inst_envs <- tcGetFamInstEnvs + ; let matches = lookupFamInstEnv inst_envs tc tys + ; mapM (reifyFamilyInstance . fim_instance) matches } + _ -> bale_out (hang (ptext (sLit "reifyInstances:") <+> quotes (ppr ty)) + 2 (ptext (sLit "is not a class constraint or type family application"))) } where doc = ClassInstanceCtx bale_out msg = failWithTc msg - tc_types :: TyCon -> [TH.Type] -> TcM [Type] - tc_types tc th_tys - = do { let tc_arity = tyConArity tc - ; when (length th_tys /= tc_arity) - (bale_out (ptext (sLit "Wrong number of types (expected") - <+> int tc_arity <> rparen)) - ; loc <- getSrcSpanM - ; rdr_tys <- mapM (cvt loc) th_tys -- Convert to HsType RdrName - ; (rn_tys, _fvs) <- checkNoErrs $ rnLHsTypes doc rdr_tys -- Rename to HsType Name - -- checkNoErrs: see Note [Renamer errors] - ; (tys, _res_k) <- tcInferApps tc (tyConKind tc) rn_tys - ; return tys } - cvt :: SrcSpan -> TH.Type -> TcM (LHsType RdrName) cvt loc th_ty = case convertToHsType loc th_ty of Left msg -> failWithTc msg @@ -1174,7 +1169,6 @@ reifyThing (AGlobal (AnId id)) } reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc -reifyThing (AGlobal (ACoAxiom ax)) = reifyAxiom ax reifyThing (AGlobal (ADataCon dc)) = do { let name = dataConName dc ; ty <- reifyType (idType (dataConWrapId dc)) @@ -1197,12 +1191,7 @@ reifyThing (ATyVar tv tv1) reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing) ------------------------------- -reifyAxiom :: CoAxiom br -> TcM TH.Info -reifyAxiom (CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) - = do { eqns <- sequence $ brListMap reifyAxBranch branches - ; return (TH.TyConI (TH.TySynInstD (reifyName tc) eqns)) } - +------------------------------------------- reifyAxBranch :: CoAxBranch -> TcM TH.TySynEqn reifyAxBranch (CoAxBranch { cab_lhs = args, cab_rhs = rhs }) = do { args' <- mapM reifyType args @@ -1221,22 +1210,28 @@ reifyTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc)) | isFamilyTyCon tc - = do { let flavour = reifyFamFlavour tc - tvs = tyConTyVars tc + = do { let tvs = tyConTyVars tc kind = tyConKind tc ; kind' <- if isLiftedTypeKind kind then return Nothing else fmap Just (reifyKind kind) - ; fam_envs <- tcGetFamInstEnvs - ; instances <- mapM reifyFamilyInstance (familyInstances fam_envs tc) - ; tvs' <- reifyTyVars tvs - ; return (TH.FamilyI - (TH.FamilyD flavour (reifyName tc) tvs' kind') - instances) } + ; tvs' <- reifyTyVars tvs Nothing + ; flav' <- reifyFamFlavour tc + ; case flav' of + { Left flav -> -- open type/data family + do { fam_envs <- tcGetFamInstEnvs + ; instances <- mapM reifyFamilyInstance (familyInstances fam_envs tc) + ; return (TH.FamilyI + (TH.FamilyD flav (reifyName tc) tvs' kind') + instances) } + ; Right eqns -> -- closed type family + return (TH.FamilyI + (TH.ClosedTypeFamilyD (reifyName tc) tvs' kind' eqns) + []) } } | Just (tvs, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym = do { rhs' <- reifyType rhs - ; tvs' <- reifyTyVars tvs + ; tvs' <- reifyTyVars tvs (Just $ tyConRoles tc) ; return (TH.TyConI (TH.TySynD (reifyName tc) tvs' rhs')) } @@ -1245,7 +1240,7 @@ reifyTyCon tc = do { cxt <- reifyCxt (tyConStupidTheta tc) ; let tvs = tyConTyVars tc ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc) - ; r_tvs <- reifyTyVars tvs + ; r_tvs <- reifyTyVars tvs (Just $ tyConRoles tc) ; let name = reifyName tc deriv = [] -- Don't know about deriving decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv @@ -1281,7 +1276,7 @@ reifyDataCon tys dc return main_con else do { cxt <- reifyCxt theta' - ; ex_tvs'' <- reifyTyVars ex_tvs' + ; ex_tvs'' <- reifyTyVars ex_tvs' Nothing ; return (TH.ForallC ex_tvs'' cxt main_con) } } ------------------------------ @@ -1291,7 +1286,7 @@ reifyClass cls ; inst_envs <- tcGetInstEnvs ; insts <- mapM reifyClassInstance (InstEnv.classInstances inst_envs cls) ; ops <- mapM reify_op op_stuff - ; tvs' <- reifyTyVars tvs + ; tvs' <- reifyTyVars tvs (Just $ tyConRoles (classTyCon cls)) ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' ops ; return (TH.ClassI dec insts ) } where @@ -1305,7 +1300,7 @@ reifyClassInstance :: ClsInst -> TcM TH.Dec reifyClassInstance i = do { cxt <- reifyCxt (drop n_silent theta) ; thtypes <- reifyTypes types - ; let head_ty = foldl TH.AppT (TH.ConT (reifyName cls)) thtypes + ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) thtypes ; return $ (TH.InstanceD cxt head_ty []) } where (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun) @@ -1313,31 +1308,26 @@ reifyClassInstance i n_silent = dfunNSilent dfun ------------------------------ -reifyFamilyInstance :: FamInst br -> TcM TH.Dec -reifyFamilyInstance fi@(FamInst { fi_flavor = flavor - , fi_branches = branches - , fi_fam = fam }) +reifyFamilyInstance :: FamInst -> TcM TH.Dec +reifyFamilyInstance (FamInst { fi_flavor = flavor + , fi_fam = fam + , fi_tys = lhs + , fi_rhs = rhs }) = case flavor of SynFamilyInst -> - do { th_eqns <- sequence $ brListMap reifyFamInstBranch branches - ; return (TH.TySynInstD (reifyName fam) th_eqns) } + do { th_lhs <- reifyTypes lhs + ; th_rhs <- reifyType rhs + ; return (TH.TySynInstD (reifyName fam) (TH.TySynEqn th_lhs th_rhs)) } DataFamilyInst rep_tc -> do { let tvs = tyConTyVars rep_tc fam' = reifyName fam - lhs = famInstBranchLHS $ famInstSingleBranch (toUnbranchedFamInst fi) ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons rep_tc) ; th_tys <- reifyTypes lhs ; return (if isNewTyCon rep_tc then TH.NewtypeInstD [] fam' th_tys (head cons) [] else TH.DataInstD [] fam' th_tys cons []) } -reifyFamInstBranch :: FamInstBranch -> TcM TH.TySynEqn -reifyFamInstBranch (FamInstBranch { fib_lhs = lhs, fib_rhs = rhs }) - = do { th_lhs <- reifyTypes lhs - ; th_rhs <- reifyType rhs - ; return (TH.TySynEqn th_lhs th_rhs) } - ------------------------------ reifyType :: TypeRep.Type -> TcM TH.Type -- Monadic only because of failure @@ -1354,7 +1344,7 @@ reify_for_all :: TypeRep.Type -> TcM TH.Type reify_for_all ty = do { cxt' <- reifyCxt cxt; ; tau' <- reifyType tau - ; tvs' <- reifyTyVars tvs + ; tvs' <- reifyTyVars tvs Nothing ; return (TH.ForallT tvs' cxt' tau') } where (tvs, cxt, tau) = tcSplitSigmaTy ty @@ -1386,7 +1376,7 @@ reifyKind ki reify_kc_app :: TyCon -> [TypeRep.Kind] -> TcM TH.Kind reify_kc_app kc kis - = fmap (foldl TH.AppT r_kc) (mapM reifyKind kis) + = fmap (mkThAppTs r_kc) (mapM reifyKind kis) where r_kc | Just tc <- isPromotedTyCon_maybe kc , isTupleTyCon tc = TH.TupleT (tyConArity kc) @@ -1399,26 +1389,52 @@ reifyCxt = mapM reifyPred reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys) -reifyFamFlavour :: TyCon -> TH.FamFlavour -reifyFamFlavour tc | isSynFamilyTyCon tc = TH.TypeFam - | isFamilyTyCon tc = TH.DataFam - | otherwise - = panic "TcSplice.reifyFamFlavour: not a type family" +reifyFamFlavour :: TyCon -> TcM (Either TH.FamFlavour [TH.TySynEqn]) +reifyFamFlavour tc + | isOpenSynFamilyTyCon tc = return $ Left TH.TypeFam + | isDataFamilyTyCon tc = return $ Left TH.DataFam + + -- this doesn't really handle abstract closed families, but let's not worry + -- about that now + | Just ax <- isClosedSynFamilyTyCon_maybe tc + = do { eqns <- brListMapM reifyAxBranch $ coAxiomBranches ax + ; return $ Right eqns } + + | otherwise + = panic "TcSplice.reifyFamFlavour: not a type family" -reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr] -reifyTyVars = mapM reifyTyVar . filter isTypeVar +reifyTyVars :: [TyVar] -> Maybe [Role] -- use Nothing if role annot.s are not allowed + -> TcM [TH.TyVarBndr] +reifyTyVars tvs Nothing = mapM reify_tv $ filter isTypeVar tvs where - reifyTyVar tv | isLiftedTypeKind kind = return (TH.PlainTV name) - | otherwise = do kind' <- reifyKind kind - return (TH.KindedTV name kind') + reify_tv tv | isLiftedTypeKind kind = return (TH.PlainTV name) + | otherwise = do kind' <- reifyKind kind + return (TH.KindedTV name kind') where kind = tyVarKind tv name = reifyName tv +reifyTyVars tvs (Just roles) = zipWithM reify_tv tvs' roles' + where + (kvs, tvs') = span isKindVar tvs + roles' = dropList kvs roles + + reify_tv tv role + | isLiftedTypeKind kind = return (TH.RoledTV name role') + | otherwise = do kind' <- reifyKind kind + return (TH.KindedRoledTV name kind' role') + where + kind = tyVarKind tv + name = reifyName tv + role' = case role of + CoAxiom.Nominal -> TH.Nominal + CoAxiom.Representational -> TH.Representational + CoAxiom.Phantom -> TH.Phantom + reify_tc_app :: TyCon -> [TypeRep.Type] -> TcM TH.Type reify_tc_app tc tys = do { tys' <- reifyTypes (removeKinds (tyConKind tc) tys) - ; return (foldl TH.AppT r_tc tys') } + ; return (mkThAppTs r_tc tys') } where arity = tyConArity tc r_tc | isTupleTyCon tc = if isPromotedDataCon tc @@ -1495,6 +1511,9 @@ reifyStrict HsStrict = TH.IsStrict reifyStrict (HsUnpack {}) = TH.Unpacked ------------------------------ +mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type +mkThAppTs fun_ty arg_tys = foldl TH.AppT fun_ty arg_tys + noTH :: LitString -> SDoc -> TcM a noTH s d = failWithTc (hsep [ptext (sLit "Can't represent") <+> ptext s <+> ptext (sLit "in Template Haskell:"), diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index c6467249e8..0cd4f2d5a9 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -37,11 +37,13 @@ import TcMType import TcType import TysWiredIn( unitTy ) import FamInst -import Coercion( mkCoAxBranch ) +import FamInstEnv( isDominatedBy, mkCoAxBranch, mkBranchedCoAxiom ) +import Coercion( pprCoAxBranch, ltRole ) import Type +import TypeRep -- for checkValidRoles import Kind import Class -import CoAxiom( CoAxBranch(..) ) +import CoAxiom import TyCon import DataCon import Id @@ -121,13 +123,15 @@ tcTyClGroup boot_details tyclds = do { -- Step 1: kind-check this group and returns the final -- (possibly-polymorphic) kind of each TyCon and Class -- See Note [Kind checking for type and class decls] - names_w_poly_kinds <- kcTyClGroup tyclds + -- See also Note [Role annotations] + (names_w_poly_kinds, role_annots) <- checkNoErrs $ kcTyClGroup tyclds ; traceTc "tcTyAndCl generalized kinds" (ppr names_w_poly_kinds) + -- the checkNoErrs is necessary to fix #7175. -- Step 2: type-check all groups together, returning -- the final TyCons and Classes ; tyclss <- fixM $ \ rec_tyclss -> do - { let rec_flags = calcRecFlags boot_details rec_tyclss + { let rec_flags = calcRecFlags boot_details role_annots rec_tyclss -- Populate environment with knot-tied ATyCon for TyCons -- NB: if the decls mention any ill-staged data cons @@ -143,17 +147,14 @@ tcTyClGroup boot_details tyclds -- Kind and type check declarations for this group concatMapM (tcTyClDecl rec_flags) tyclds } - -- Step 3: Perform the validity chebck + -- Step 3: Perform the validity check -- We can do this now because we are done with the recursive knot -- Do it before Step 4 (adding implicit things) because the latter -- expects well-formed TyCons ; tcExtendGlobalEnv tyclss $ do { traceTc "Starting validity check" (ppr tyclss) - ; checkNoErrs $ - mapM_ (recoverM (return ()) . addLocM checkValidTyCl) tyclds + ; mapM_ (recoverM (return ()) . addLocM (checkValidTyCl role_annots)) tyclds -- We recover, which allows us to report multiple validity errors - -- but we then fail if any are wrong. Lacking the checkNoErrs - -- we get Trac #7175 -- Step 4: Add the implicit things; -- we want them in the environment because @@ -198,9 +199,9 @@ Note [Kind checking for type and class decls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Kind checking is done thus: - 1. Make up a kind variable for each parameter of the *data* type, - and class, decls, and extend the kind environment (which is in - the TcLclEnv) + 1. Make up a kind variable for each parameter of the *data* type, class, + and closed type family decls, and extend the kind environment (which is + in the TcLclEnv) 2. Dependency-analyse the type *synonyms* (which must be non-recursive), and kind-check them in dependency order. Extend the kind envt. @@ -235,24 +236,41 @@ So we must infer their kinds from their right-hand sides *first* and then use them, whereas for the mutually recursive data types D we bring into scope kind bindings D -> k, where k is a kind variable, and do inference. -Type families -~~~~~~~~~~~~~ +Open type families +~~~~~~~~~~~~~~~~~~ This treatment of type synonyms only applies to Haskell 98-style synonyms. General type functions can be recursive, and hence, appear in `alg_decls'. -The kind of a type family is solely determinded by its kind signature; +The kind of an open type family is solely determinded by its kind signature; hence, only kind signatures participate in the construction of the initial -kind environment (as constructed by `getInitialKind'). In fact, we ignore -instances of families altogether in the following. However, we need to -include the kinds of *associated* families into the construction of the -initial kind environment. (This is handled by `allDecls'). +kind environment (as constructed by `getInitialKind'). In fact, we ignore +instances of families altogether in the following. However, we need to include +the kinds of *associated* families into the construction of the initial kind +environment. (This is handled by `allDecls'). +Note [Role annotations] +~~~~~~~~~~~~~~~~~~~~~~~ +Role processing is threaded through the kind- and type-checker. Here is the +route: + +1. kcTyClGroup returns a list of (Name, Kind, [Maybe Role]) triples. The +elements of the role list correspond to type variables associated with the Name. +Nothing indicates no role annotation. Just r indicates an annotation r. + +2. The role annotations are passed into calcRecFlags, which among other things, +performs role inference. The role annotations are used to initialize the role +inference algorithm. + +3. During validity-checking (in checkRoleAnnot), the inferred roles are +then checked against the annotations. If they don't match, an error is reported. +This is also where the presence of the RoleAnnotations flag is checked. \begin{code} -kcTyClGroup :: TyClGroup Name -> TcM [(Name,Kind)] +kcTyClGroup :: TyClGroup Name -> TcM ([(Name,Kind)], RoleAnnots) -- Kind check this group, kind generalize, and return the resulting local env -- This bindds the TyCons and Classes of the group, but not the DataCons -- See Note [Kind checking for type and class decls] +-- Role annotation extraction is done here, too. See Note [Role annotations] kcTyClGroup decls = do { mod <- getModule ; traceTc "kcTyClGroup" (ptext (sLit "module") <+> ppr mod $$ vcat (map ppr decls)) @@ -266,12 +284,13 @@ kcTyClGroup decls -- Step 1: Bind kind variables for non-synonyms ; let (syn_decls, non_syn_decls) = partition (isSynDecl . unLoc) decls - ; initial_kinds <- getInitialKinds TopLevel non_syn_decls + ; (initial_kinds, role_env) <- getInitialKinds non_syn_decls ; traceTc "kcTyClGroup: initial kinds" (ppr initial_kinds) -- Step 2: Set initial envt, kind-check the synonyms - ; lcl_env <- tcExtendTcTyThingEnv initial_kinds $ - kcSynDecls (calcSynCycles syn_decls) + -- See Note [Role annotations] + ; (lcl_env, role_env') <- tcExtendTcTyThingEnv initial_kinds $ + kcSynDecls (calcSynCycles syn_decls) -- Step 3: Set extended envt, kind-check the non-synonyms ; setLclEnv lcl_env $ @@ -283,16 +302,16 @@ kcTyClGroup decls ; res <- concatMapM (generaliseTCD (tcl_env lcl_env)) decls ; traceTc "kcTyClGroup result" (ppr res) - ; return res } + ; return (res, role_env `plusNameEnv` role_env') } where - generalise :: TcTypeEnv -> Name -> LHsTyVarBndrs Name -> TcM (Name, Kind) + generalise :: TcTypeEnv -> Name -> TcM (Name, Kind) -- For polymorphic things this is a no-op - generalise kind_env name tvs + generalise kind_env name = do { let kc_kind = case lookupNameEnv kind_env name of Just (AThing k) -> k _ -> pprPanic "kcTyClGroup" (ppr name $$ ppr kind_env) - ; kvs <- kindGeneralize (tyVarsOfType kc_kind) (hsLTyVarNames tvs) + ; kvs <- kindGeneralize (tyVarsOfType kc_kind) ; kc_kind' <- zonkTcKind kc_kind -- Make sure kc_kind' has the final, -- skolemised kind variables ; traceTc "Generalise kind" (vcat [ ppr name, ppr kc_kind, ppr kvs, ppr kc_kind' ]) @@ -300,8 +319,8 @@ kcTyClGroup decls generaliseTCD :: TcTypeEnv -> LTyClDecl Name -> TcM [(Name, Kind)] generaliseTCD kind_env (L _ decl) - | ClassDecl { tcdLName = (L _ name), tcdTyVars = tyvars, tcdATs = ats } <- decl - = do { first <- generalise kind_env name tyvars + | ClassDecl { tcdLName = (L _ name), tcdATs = ats } <- decl + = do { first <- generalise kind_env name ; rest <- mapM ((generaliseFamDecl kind_env) . unLoc) ats ; return (first : rest) } @@ -313,13 +332,12 @@ kcTyClGroup decls = pprPanic "generaliseTCD" (ppr decl) | otherwise - -- Note: tcdTyVars is safe here because we've eliminated FamDecl and ForeignType - = do { res <- generalise kind_env (tcdName decl) (tcdTyVars decl) + = do { res <- generalise kind_env (tcdName decl) ; return [res] } generaliseFamDecl :: TcTypeEnv -> FamilyDecl Name -> TcM (Name, Kind) - generaliseFamDecl kind_env (FamilyDecl { fdLName = L _ name, fdTyVars = tyvars }) - = generalise kind_env name tyvars + generaliseFamDecl kind_env (FamilyDecl { fdLName = L _ name }) + = generalise kind_env name mk_thing_env :: [LTyClDecl Name] -> [(Name, TcTyThing)] mk_thing_env [] = [] @@ -333,12 +351,14 @@ mk_thing_env (decl : decls) = (tcdName (unLoc decl), APromotionErr TyConPE) : (mk_thing_env decls) -getInitialKinds :: TopLevelFlag -> [LTyClDecl Name] -> TcM [(Name, TcTyThing)] -getInitialKinds top_lvl decls +getInitialKinds :: [LTyClDecl Name] -> TcM ([(Name, TcTyThing)], RoleAnnots) +getInitialKinds decls = tcExtendTcTyThingEnv (mk_thing_env decls) $ - concatMapM (addLocM (getInitialKind top_lvl)) decls + do { (pairss, annots) <- mapAndUnzipM (addLocM getInitialKind) decls + ; return (concat pairss, mkNameEnv (zip (map (tcdName . unLoc) decls) annots)) } -getInitialKind :: TopLevelFlag -> TyClDecl Name -> TcM [(Name, TcTyThing)] +-- See Note [Kind-checking strategies] in TcHsType +getInitialKind :: TyClDecl Name -> TcM ([(Name, TcTyThing)], [Maybe Role]) -- Allocate a fresh kind variable for each TyCon and Class -- For each tycon, return (tc, AThing k) -- where k is the kind of tc, derived from the LHS @@ -356,92 +376,95 @@ getInitialKind :: TopLevelFlag -> TyClDecl Name -> TcM [(Name, TcTyThing)] -- -- No family instances are passed to getInitialKinds -getInitialKind top_lvl (FamDecl { tcdFam = decl }) = getFamDeclInitialKind top_lvl decl -getInitialKind _ (ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats }) - = kcHsTyVarBndrs False ktvs $ \ arg_kinds -> - do { inner_prs <- getFamDeclInitialKinds ats - ; let main_pr = (name, AThing (mkArrowKinds arg_kinds constraintKind)) - ; return (main_pr : inner_prs) } - -getInitialKind _top_lvl decl@(SynDecl {}) = pprPanic "getInitialKind" (ppr decl) - -getInitialKind top_lvl (DataDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdDataDefn = defn }) - | HsDataDefn { dd_kindSig = Just ksig, dd_cons = cons } <- defn - = ASSERT( isTopLevel top_lvl ) - kcHsTyVarBndrs True ktvs $ \ arg_kinds -> - do { res_k <- tcLHsKind ksig - ; let body_kind = mkArrowKinds arg_kinds res_k - kvs = varSetElems (tyVarsOfType body_kind) - main_pr = (name, AThing (mkForAllTys kvs body_kind)) - inner_prs = [(unLoc (con_name con), APromotionErr RecDataConPE) | L _ con <- cons ] - -- See Note [Recusion and promoting data constructors] - ; return (main_pr : inner_prs) } - - | HsDataDefn { dd_cons = cons } <- defn - = kcHsTyVarBndrs False ktvs $ \ arg_kinds -> - do { let main_pr = (name, AThing (mkArrowKinds arg_kinds liftedTypeKind)) +getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats }) + = do { (cl_kind, inner_prs, role_annots) <- + kcHsTyVarBndrs (kcStrategy decl) ktvs $ + do { inner_prs <- getFamDeclInitialKinds ats + ; return (constraintKind, inner_prs) } + ; let main_pr = (name, AThing cl_kind) + ; return ((main_pr : inner_prs), role_annots) } + +getInitialKind decl@(DataDecl { tcdLName = L _ name + , tcdTyVars = ktvs + , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig + , dd_cons = cons } }) + = do { (decl_kind, num_extra_tvs, role_annots) <- + kcHsTyVarBndrs (kcStrategy decl) ktvs $ + do { res_k <- case m_sig of + Just ksig -> tcLHsKind ksig + Nothing -> return liftedTypeKind + -- return the number of extra type arguments from the res_k so + -- we can extend the role_annots list + ; return (res_k, length $ fst $ splitKindFunTys res_k) } + ; let main_pr = (name, AThing decl_kind) inner_prs = [ (unLoc (con_name con), APromotionErr RecDataConPE) | L _ con <- cons ] - -- See Note [Recusion and promoting data constructors] - ; return (main_pr : inner_prs) } + role_annots' = role_annots ++ replicate num_extra_tvs Nothing + ; return ((main_pr : inner_prs), role_annots') } + +getInitialKind (FamDecl { tcdFam = decl }) + = do { pairs <- getFamDeclInitialKind decl + ; return (pairs, []) } -getInitialKind _ (ForeignType { tcdLName = L _ name }) - = return [(name, AThing liftedTypeKind)] +getInitialKind (ForeignType { tcdLName = L _ name }) + = return ([(name, AThing liftedTypeKind)], []) +getInitialKind decl@(SynDecl {}) + = pprPanic "getInitialKind" (ppr decl) + +--------------------------------- getFamDeclInitialKinds :: [LFamilyDecl Name] -> TcM [(Name, TcTyThing)] getFamDeclInitialKinds decls = tcExtendTcTyThingEnv [ (n, APromotionErr TyConPE) | L _ (FamilyDecl { fdLName = L _ n }) <- decls] $ - concatMapM (addLocM (getFamDeclInitialKind NotTopLevel)) decls + concatMapM (addLocM getFamDeclInitialKind) decls -getFamDeclInitialKind :: TopLevelFlag - -> FamilyDecl Name +getFamDeclInitialKind :: FamilyDecl Name -> TcM [(Name, TcTyThing)] -getFamDeclInitialKind top_lvl (FamilyDecl { fdLName = L _ name - , fdTyVars = ktvs - , fdKindSig = ksig }) - | isTopLevel top_lvl - = kcHsTyVarBndrs True ktvs $ \ arg_kinds -> - do { res_k <- case ksig of - Just k -> tcLHsKind k - Nothing -> return liftedTypeKind - ; let body_kind = mkArrowKinds arg_kinds res_k - kvs = varSetElems (tyVarsOfType body_kind) - ; return [ (name, AThing (mkForAllTys kvs body_kind)) ] } - - | otherwise - = kcHsTyVarBndrs False ktvs $ \ arg_kinds -> - do { res_k <- case ksig of - Just k -> tcLHsKind k - Nothing -> newMetaKindVar - ; return [ (name, AThing (mkArrowKinds arg_kinds res_k)) ] } +getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name + , fdTyVars = ktvs + , fdKindSig = ksig }) + = do { (fam_kind, _, _) <- + kcHsTyVarBndrs (kcStrategyFamDecl decl) ktvs $ + do { res_k <- case ksig of + Just k -> tcLHsKind k + Nothing + | defaultResToStar -> return liftedTypeKind + | otherwise -> newMetaKindVar + ; return (res_k, ()) } + ; return [ (name, AThing fam_kind) ] } + where + defaultResToStar = (kcStrategyFamDecl decl == FullKindSignature) ---------------- -kcSynDecls :: [SCC (LTyClDecl Name)] -> TcM TcLclEnv -- Kind bindings -kcSynDecls [] = getLclEnv +kcSynDecls :: [SCC (LTyClDecl Name)] + -> TcM (TcLclEnv, RoleAnnots) -- Kind bindings and roles +kcSynDecls [] = do { env <- getLclEnv + ; return (env, emptyNameEnv) } kcSynDecls (group : groups) - = do { nk <- kcSynDecl1 group - ; tcExtendKindEnv [nk] (kcSynDecls groups) } + = do { (n,k,mr) <- kcSynDecl1 group + ; (lcl_env, role_env) <- tcExtendKindEnv [(n,k)] (kcSynDecls groups) + ; return (lcl_env, extendNameEnv role_env n mr) } kcSynDecl1 :: SCC (LTyClDecl Name) - -> TcM (Name,TcKind) -- Kind bindings + -> TcM (Name,TcKind,[Maybe Role]) -- Kind bindings with roles kcSynDecl1 (AcyclicSCC (L _ decl)) = kcSynDecl decl kcSynDecl1 (CyclicSCC decls) = do { recSynErr decls; failM } -- Fail here to avoid error cascade -- of out-of-scope tycons -kcSynDecl :: TyClDecl Name -> TcM (Name, TcKind) +kcSynDecl :: TyClDecl Name -> TcM (Name, TcKind, [Maybe Role]) kcSynDecl decl@(SynDecl { tcdTyVars = hs_tvs, tcdLName = L _ name , tcdRhs = rhs }) -- Returns a possibly-unzonked kind = tcAddDeclCtxt decl $ - kcHsTyVarBndrs False hs_tvs $ \ ks -> - do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs) - <+> brackets (ppr ks)) - ; (_, rhs_kind) <- tcLHsType rhs - ; traceTc "kcd2" (ppr name) - ; let tc_kind = mkArrowKinds ks rhs_kind - ; return (name, tc_kind) } + do { (syn_kind, _, mroles) <- + kcHsTyVarBndrs (kcStrategy decl) hs_tvs $ + do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs)) + ; (_, rhs_kind) <- tcLHsType rhs + ; traceTc "kcd2" (ppr name) + ; return (rhs_kind, ()) } + ; return (name, syn_kind, mroles) } kcSynDecl decl = pprPanic "kcSynDecl" (ppr decl) ------------------------------------------------------------------------ @@ -452,20 +475,21 @@ kcLTyClDecl (L loc decl) kcTyClDecl :: TyClDecl Name -> TcM () -- This function is used solely for its side effect on kind variables +-- and to extract role annotations -- NB kind signatures on the type variables and -- result kind signature have aready been dealt with -- by getInitialKind, so we can ignore them here. kcTyClDecl (DataDecl { tcdLName = L _ name, tcdTyVars = hs_tvs, tcdDataDefn = defn }) | HsDataDefn { dd_cons = cons, dd_kindSig = Just _ } <- defn - = mapM_ (wrapLocM kcConDecl) cons + = mapM_ (wrapLocM (kcConDecl name)) cons -- hs_tvs and td_kindSig already dealt with in getInitialKind -- Ignore the dd_ctxt; heavily deprecated and inconvenient | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } <- defn = kcTyClTyVars name hs_tvs $ do { _ <- tcHsContext ctxt - ; mapM_ (wrapLocM kcConDecl) cons } + ; mapM_ (wrapLocM (kcConDecl name)) cons } kcTyClDecl decl@(SynDecl {}) = pprPanic "kcTyClDecl" (ppr decl) @@ -480,17 +504,26 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs kc_sig _ = return () kcTyClDecl (ForeignType {}) = return () + +-- closed type families look at their equations, but other families don't +-- do anything here +kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name + , fdInfo = ClosedTypeFamily eqns })) + = do { k <- kcLookupKind fam_tc_name + ; mapM_ (kcTyFamInstEqn fam_tc_name k) eqns } kcTyClDecl (FamDecl {}) = return () ------------------- -kcConDecl :: ConDecl Name -> TcM () -kcConDecl (ConDecl { con_name = name, con_qvars = ex_tvs - , con_cxt = ex_ctxt, con_details = details, con_res = res }) +kcConDecl :: Name -> ConDecl Name -> TcM () +kcConDecl tc_name (ConDecl { con_name = name, con_qvars = ex_tvs + , con_cxt = ex_ctxt, con_details = details + , con_res = res }) = addErrCtxt (dataConCtxt name) $ - kcHsTyVarBndrs False ex_tvs $ \ _ -> - do { _ <- tcHsContext ex_ctxt - ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details) - ; _ <- tcConRes res + do { _ <- kcHsTyVarBndrs ParametricKinds ex_tvs $ + do { _ <- tcHsContext ex_ctxt + ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details) + ; _ <- tcConRes tc_name (unLoc name) res + ; return (panic "kcConDecl", ()) } ; return () } \end{code} @@ -574,11 +607,11 @@ tcTyClDecl1 parent _rec_info (FamDecl { tcdFam = fd }) = tcFamDecl1 parent fd -- "type" synonym declaration -tcTyClDecl1 _parent _rec_info +tcTyClDecl1 _parent rec_info (SynDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdRhs = rhs }) = ASSERT( isNoParent _parent ) tcTyClTyVars tc_name tvs $ \ tvs' kind -> - tcTySynRhs tc_name tvs' kind rhs + tcTySynRhs rec_info tc_name tvs' kind rhs -- "data/newtype" declaration tcTyClDecl1 _parent rec_info @@ -596,11 +629,12 @@ tcTyClDecl1 _parent rec_info do { (clas, tvs', gen_dm_env) <- fixM $ \ ~(clas,_,_) -> tcTyClTyVars class_name tvs $ \ tvs' kind -> do { MASSERT( isConstraintKind kind ) - ; let -- This little knot is just so we can get - -- hold of the name of the class TyCon, which we - -- need to look up its recursiveness - tycon_name = tyConName (classTyCon clas) - tc_isrec = rti_is_rec rec_info tycon_name + -- This little knot is just so we can get + -- hold of the name of the class TyCon, which we + -- need to look up its recursiveness + ; let tycon_name = tyConName (classTyCon clas) + tc_isrec = rti_is_rec rec_info tycon_name + roles = rti_roles rec_info tycon_name ; ctxt' <- tcHsContext ctxt ; ctxt' <- zonkTcTypeToTypes emptyZonkEnv ctxt' @@ -609,7 +643,7 @@ tcTyClDecl1 _parent rec_info ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths ; at_stuff <- tcClassATs class_name (AssocFamilyTyCon clas) ats at_defs ; clas <- buildClass False {- Must include unfoldings for selectors -} - class_name tvs' ctxt' fds' at_stuff + class_name tvs' roles ctxt' fds' at_stuff sig_stuff tc_isrec ; traceTc "tcClassDecl" (ppr fundeps $$ ppr tvs' $$ ppr fds') ; return (clas, tvs', gen_dm_env) } @@ -642,43 +676,103 @@ tcTyClDecl1 _parent rec_info tcTyClDecl1 _ _ (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name}) - = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)] + = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind)] \end{code} \begin{code} tcFamDecl1 :: TyConParent -> FamilyDecl Name -> TcM [TyThing] tcFamDecl1 parent - (FamilyDecl {fdFlavour = TypeFamily, fdLName = L _ tc_name, fdTyVars = tvs}) + (FamilyDecl {fdInfo = OpenTypeFamily, fdLName = L _ tc_name, fdTyVars = tvs}) = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do - { traceTc "type family:" (ppr tc_name) + { traceTc "open type family:" (ppr tc_name) ; checkFamFlag tc_name - ; let syn_rhs = SynFamilyTyCon { synf_open = True, synf_injective = False } - ; tycon <- buildSynTyCon tc_name tvs' syn_rhs kind parent + ; checkNoRoles tvs + ; let roles = map (const Nominal) tvs' + ; tycon <- buildSynTyCon tc_name tvs' roles OpenSynFamilyTyCon kind parent ; return [ATyCon tycon] } tcFamDecl1 parent - (FamilyDecl {fdFlavour = DataFamily, fdLName = L _ tc_name, fdTyVars = tvs}) + (FamilyDecl { fdInfo = ClosedTypeFamily eqns + , fdLName = lname@(L _ tc_name), fdTyVars = tvs }) +-- Closed type families are a little tricky, because they contain the definition +-- of both the type family and the equations for a CoAxiom. +-- Note: eqns might be empty, in a hs-boot file! + = do { traceTc "closed type family:" (ppr tc_name) + -- the variables in the header have no scope: + ; (tvs', kind) <- tcTyClTyVars tc_name tvs $ \ tvs' kind -> + return (tvs', kind) + + ; checkFamFlag tc_name -- make sure we have -XTypeFamilies + ; checkNoRoles tvs + + -- check to make sure all the names used in the equations are + -- consistent + ; let names = map (tfie_tycon . unLoc) eqns + ; tcSynFamInstNames lname names + + -- process the equations, creating CoAxBranches + ; tycon_kind <- kcLookupKind tc_name + ; branches <- mapM (tcTyFamInstEqn tc_name tycon_kind) eqns + + -- we need the tycon that we will be creating, but it's in scope. + -- just look it up. + ; fam_tc <- tcLookupLocatedTyCon lname + + -- create a CoAxiom, with the correct src location. It is Vitally + -- Important that we do not pass the branches into + -- newFamInstAxiomName. They have types that have been zonked inside + -- the knot and we will die if we look at them. This is OK here + -- because there will only be one axiom, so we don't need to + -- differentiate names. + -- See [Zonking inside the knot] in TcHsType + ; loc <- getSrcSpanM + ; co_ax_name <- newFamInstAxiomName loc tc_name [] + + -- mkBranchedCoAxiom will fail on an empty list of branches, but + -- we'll never look at co_ax in this case + ; let co_ax = mkBranchedCoAxiom co_ax_name fam_tc branches + + -- now, finally, build the TyCon + ; let syn_rhs = if null eqns + then AbstractClosedSynFamilyTyCon + else ClosedSynFamilyTyCon co_ax + roles = map (const Nominal) tvs' + ; tycon <- buildSynTyCon tc_name tvs' roles syn_rhs kind parent + + ; let result = if null eqns + then [ATyCon tycon] + else [ATyCon tycon, ACoAxiom co_ax] + ; return result } +-- We check for instance validity later, when doing validity checking for +-- the tycon + +tcFamDecl1 parent + (FamilyDecl {fdInfo = DataFamily, fdLName = L _ tc_name, fdTyVars = tvs}) = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do { traceTc "data family:" (ppr tc_name) ; checkFamFlag tc_name + ; checkNoRoles tvs ; extra_tvs <- tcDataKindSig kind ; let final_tvs = tvs' ++ extra_tvs -- we may not need these - tycon = buildAlgTyCon tc_name final_tvs Nothing [] + roles = map (const Nominal) final_tvs + tycon = buildAlgTyCon tc_name final_tvs roles Nothing [] DataFamilyTyCon Recursive False -- Not promotable to the kind level True -- GADT syntax parent ; return [ATyCon tycon] } -tcTySynRhs :: Name +tcTySynRhs :: RecTyInfo + -> Name -> [TyVar] -> Kind -> LHsType Name -> TcM [TyThing] -tcTySynRhs tc_name tvs kind hs_ty +tcTySynRhs rec_info tc_name tvs kind hs_ty = do { env <- getLclEnv ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) ; rhs_ty <- tcCheckLHsType hs_ty kind ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty - ; tycon <- buildSynTyCon tc_name tvs (SynonymTyCon rhs_ty) + ; let roles = rti_roles rec_info tc_name + ; tycon <- buildSynTyCon tc_name tvs roles (SynonymTyCon rhs_ty) kind NoParentTyCon ; return [ATyCon tycon] } @@ -692,6 +786,7 @@ tcDataDefn rec_info tc_name tvs kind , dd_cons = cons }) = do { extra_tvs <- tcDataKindSig kind ; let final_tvs = tvs ++ extra_tvs + roles = rti_roles rec_info tc_name ; stupid_theta <- tcHsContext ctxt ; kind_signatures <- xoptM Opt_KindSignatures ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? @@ -708,7 +803,8 @@ tcDataDefn rec_info tc_name tvs kind ; tycon <- fixM $ \ tycon -> do { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs) - ; data_cons <- tcConDecls new_or_data tycon (final_tvs, res_ty) cons + ; data_cons <- tcConDecls new_or_data tc_name tycon + (final_tvs, res_ty) cons ; tc_rhs <- if null cons && is_boot -- In a hs-boot file, empty cons means then return totallyAbstractTyConRhs -- "don't know"; hence totally Abstract @@ -716,7 +812,7 @@ tcDataDefn rec_info tc_name tvs kind DataType -> return (mkDataTyConRhs data_cons) NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs tc_name tycon (head data_cons) - ; return (buildAlgTyCon tc_name final_tvs cType stupid_theta tc_rhs + ; return (buildAlgTyCon tc_name final_tvs roles cType stupid_theta tc_rhs (rti_is_rec rec_info tc_name) (rti_promotable rec_info) (not h98_syntax) NoParentTyCon) } @@ -770,13 +866,13 @@ tcClassATs class_name parent ats at_defs tc_at at = do { [ATyCon fam_tc] <- addLocM (tcFamDecl1 parent) at ; let at_defs = lookupNameEnv at_defs_map (unLoc $ fdLName $ unLoc at) `orElse` [] - ; atd <- concatMapM (tcDefaultAssocDecl fam_tc) at_defs + ; atd <- mapM (tcDefaultAssocDecl fam_tc) at_defs ; return (fam_tc, atd) } ------------------------- tcDefaultAssocDecl :: TyCon -- ^ Family TyCon -> LTyFamInstDecl Name -- ^ RHS - -> TcM [CoAxBranch] -- ^ Type checked RHS and free TyVars + -> TcM CoAxBranch -- ^ Type checked RHS and free TyVars tcDefaultAssocDecl fam_tc (L loc decl) = setSrcSpan loc $ tcAddTyFamInstCtxt decl $ @@ -785,17 +881,12 @@ tcDefaultAssocDecl fam_tc (L loc decl) -- We check for well-formedness and validity later, in checkValidClass ------------------------- -tcSynFamInstDecl :: TyCon -> TyFamInstDecl Name -> TcM [CoAxBranch] +tcSynFamInstDecl :: TyCon -> TyFamInstDecl Name -> TcM CoAxBranch -- Placed here because type family instances appear as -- default decls in class declarations -tcSynFamInstDecl fam_tc (TyFamInstDecl { tfid_eqns = eqns }) - -- we know the first equation matches the fam_tc because of the lookup logic - -- now, just check that all other names match the first - = do { let names = map (tfie_tycon . unLoc) eqns - first = head names - ; tcSynFamInstNames first names - ; checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; mapM (tcTyFamInstEqn fam_tc) eqns } +tcSynFamInstDecl fam_tc (TyFamInstDecl { tfid_eqn = eqn }) + = do { checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; tcTyFamInstEqn (tyConName fam_tc) (tyConKind fam_tc) eqn } -- Checks to make sure that all the names in an instance group are the same tcSynFamInstNames :: Located Name -> [Located Name] -> TcM () @@ -808,23 +899,32 @@ tcSynFamInstNames (L _ first) names = setSrcSpan loc $ failWithTc (msg_fun name) -tcTyFamInstEqn :: TyCon -> LTyFamInstEqn Name -> TcM CoAxBranch -tcTyFamInstEqn fam_tc +kcTyFamInstEqn :: Name -> Kind -> LTyFamInstEqn Name -> TcM () +kcTyFamInstEqn fam_tc_name kind + (L loc (TyFamInstEqn { tfie_pats = pats, tfie_rhs = hs_ty })) + = setSrcSpan loc $ + discardResult $ + tc_fam_ty_pats fam_tc_name kind pats (discardResult . (tcCheckLHsType hs_ty)) + +tcTyFamInstEqn :: Name -> Kind -> LTyFamInstEqn Name -> TcM CoAxBranch +tcTyFamInstEqn fam_tc_name kind (L loc (TyFamInstEqn { tfie_pats = pats, tfie_rhs = hs_ty })) = setSrcSpan loc $ - tcFamTyPats fam_tc pats (discardResult . (tcCheckLHsType hs_ty)) $ + tcFamTyPats fam_tc_name kind pats (discardResult . (tcCheckLHsType hs_ty)) $ \tvs' pats' res_kind -> do { rhs_ty <- tcCheckLHsType hs_ty res_kind ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty - ; traceTc "tcSynFamInstEqn" (ppr fam_tc <+> (ppr tvs' $$ ppr pats' $$ ppr rhs_ty)) + ; traceTc "tcTyFamInstEqn" (ppr fam_tc_name <+> ppr tvs') + -- don't print out the pats here, as they might be zonked inside the knot ; return (mkCoAxBranch tvs' pats' rhs_ty loc) } -kcDataDefn :: HsDataDefn Name -> TcKind -> TcM () +kcDataDefn :: Name -> HsDataDefn Name -> TcKind -> TcM () -- Used for 'data instance' only -- Ordinary 'data' is handled by kcTyClDec -kcDataDefn (HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_kindSig = mb_kind }) res_k +kcDataDefn tc_name + (HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_kindSig = mb_kind }) res_k = do { _ <- tcHsContext ctxt - ; mapM_ (wrapLocM kcConDecl) cons + ; mapM_ (wrapLocM (kcConDecl tc_name)) cons ; kcResultKind mb_kind res_k } ------------------ @@ -836,22 +936,36 @@ kcResultKind Nothing res_k kcResultKind (Just k) res_k = do { k' <- tcLHsKind k ; checkKind k' res_k } +\end{code} -------------------------- --- Kind check type patterns and kind annotate the embedded type variables. --- type instance F [a] = rhs --- --- * Here we check that a type instance matches its kind signature, but we do --- not check whether there is a pattern for each type index; the latter --- check is only required for type synonym instances. +Kind check type patterns and kind annotate the embedded type variables. + type instance F [a] = rhs + * Here we check that a type instance matches its kind signature, but we do + not check whether there is a pattern for each type index; the latter + check is only required for type synonym instances. + +Note [tc_fam_ty_pats vs tcFamTyPats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tc_fam_ty_pats does the type checking of the patterns, but it doesn't +zonk or generate any desugaring. It is used when kind-checking closed +type families. + +tcFamTyPats type checks the patterns, zonks, and then calls thing_inside +to generate a desugaring. It is used during type-checking (not kind-checking). + +\begin{code} ----------------- -tcFamTyPats :: TyCon - -> HsWithBndrs [LHsType Name] -- Patterns - -> (TcKind -> TcM ()) -- Kind checker for RHS - -- result is ignored - -> ([TKVar] -> [TcType] -> Kind -> TcM a) - -> TcM a +-- Note that we can't use the family TyCon, because this is sometimes called +-- from within a type-checking knot. So, we ask our callers to do a little more +-- work. +-- See Note [tc_fam_ty_pats vs tcFamTyPats] +tc_fam_ty_pats :: Name -- of the family TyCon + -> Kind -- of the family TyCon + -> HsWithBndrs [LHsType Name] -- Patterns + -> (TcKind -> TcM ()) -- Kind checker for RHS + -- result is ignored + -> TcM ([Kind], [Type], Kind) -- Check the type patterns of a type or data family instance -- type instance F <pat1> <pat2> = <type> -- The 'tyvars' are the free type variables of pats @@ -863,23 +977,27 @@ tcFamTyPats :: TyCon -- In that case, the type variable 'a' will *already be in scope* -- (and, if C is poly-kinded, so will its kind parameter). -tcFamTyPats fam_tc (HsWB { hswb_cts = arg_pats, hswb_kvs = kvars, hswb_tvs = tvars }) - kind_checker thing_inside - = do { -- A family instance must have exactly the same number of type - -- parameters as the family declaration. You can't write - -- type family F a :: * -> * - -- type instance F Int y = y - -- because then the type (F Int) would be like (\y.y) - ; let (fam_kvs, fam_body) = splitForAllTys (tyConKind fam_tc) - fam_arity = tyConArity fam_tc - length fam_kvs - ; checkTc (length arg_pats == fam_arity) $ - wrongNumberOfParmsErr fam_arity +tc_fam_ty_pats fam_tc_name kind + (HsWB { hswb_cts = arg_pats, hswb_kvs = kvars, hswb_tvs = tvars }) + kind_checker + = do { let (fam_kvs, fam_body) = splitForAllTys kind + + -- We wish to check that the pattern has the right number of arguments + -- in checkValidFamPats (in TcValidity), so we can do the check *after* + -- we're done with the knot. But, the splitKindFunTysN below will panic + -- if there are *too many* patterns. So, we do a preliminary check here. + -- Note that we don't have enough information at hand to do a full check, + -- as that requires the full declared arity of the family, which isn't + -- nearby. + ; let max_args = length (fst $ splitKindFunTys fam_body) + ; checkTc (length arg_pats <= max_args) $ + wrongNumberOfParmsErrTooMany max_args -- Instantiate with meta kind vars ; fam_arg_kinds <- mapM (const newMetaKindVar) fam_kvs ; loc <- getSrcSpanM ; let (arg_kinds, res_kind) - = splitKindFunTysN fam_arity $ + = splitKindFunTysN (length arg_pats) $ substKiWith fam_kvs fam_arg_kinds fam_body hs_tvs = HsQTvs { hsq_kvs = kvars , hsq_tvs = userHsTyVarBndrs loc tvars } @@ -888,22 +1006,35 @@ tcFamTyPats fam_tc (HsWB { hswb_cts = arg_pats, hswb_kvs = kvars, hswb_tvs = tva -- See Note [Quantifying over family patterns] ; typats <- tcHsTyVarBndrs hs_tvs $ \ _ -> do { kind_checker res_kind - ; tcHsArgTys (quotes (ppr fam_tc)) arg_pats arg_kinds } + ; tcHsArgTys (quotes (ppr fam_tc_name)) arg_pats arg_kinds } + + ; return (fam_arg_kinds, typats, res_kind) } + +-- See Note [tc_fam_ty_pats vs tcFamTyPats] +tcFamTyPats :: Name -- of the family ToCon + -> Kind -- of the family TyCon + -> HsWithBndrs [LHsType Name] -- patterns + -> (TcKind -> TcM ()) -- kind-checker for RHS + -> ([TKVar] -> [TcType] -> Kind -> TcM a) + -> TcM a +tcFamTyPats fam_tc_name kind pats kind_checker thing_inside + = do { (fam_arg_kinds, typats, res_kind) + <- tc_fam_ty_pats fam_tc_name kind pats kind_checker ; let all_args = fam_arg_kinds ++ typats -- Find free variables (after zonking) and turn -- them into skolems, so that we don't subsequently -- replace a meta kind var with AnyK -- Very like kindGeneralize - ; tkvs <- zonkTyVarsAndFV (tyVarsOfTypes all_args) - ; qtkvs <- zonkQuantifiedTyVars (varSetElems tkvs) + ; qtkvs <- quantifyTyVars emptyVarSet (tyVarsOfTypes all_args) -- Zonk the patterns etc into the Type world ; (ze, qtkvs') <- zonkTyBndrsX emptyZonkEnv qtkvs ; all_args' <- zonkTcTypeToTypes ze all_args ; res_kind' <- zonkTcTypeToType ze res_kind - ; traceTc "tcFamTyPats" (pprTvBndrs qtkvs' $$ ppr all_args' $$ ppr res_kind') + ; traceTc "tcFamTyPats" (ppr fam_tc_name) + -- don't print out too much, as we might be in the knot ; tcExtendTyVarEnv qtkvs' $ thing_inside qtkvs' all_args' res_kind' } \end{code} @@ -991,56 +1122,54 @@ consUseH98Syntax _ = True -- All constructors have same shape ----------------------------------- -tcConDecls :: NewOrData -> TyCon -> ([TyVar], Type) +tcConDecls :: NewOrData -> Name -> TyCon -> ([TyVar], Type) -> [LConDecl Name] -> TcM [DataCon] -tcConDecls new_or_data rep_tycon res_tmpl cons - = mapM (addLocM (tcConDecl new_or_data rep_tycon res_tmpl)) cons +tcConDecls new_or_data tc_name rep_tycon (tmpl_tvs, res_tmpl) cons + = mapM (addLocM $ tcConDecl new_or_data tc_name rep_tycon tmpl_tvs res_tmpl) cons tcConDecl :: NewOrData - -> TyCon -- Representation tycon - -> ([TyVar], Type) -- Return type template (with its template tyvars) + -> Name -- of tycon + -> TyCon -- Representation tycon + -> [TyVar] -> Type -- Return type template (with its template tyvars) + -- (tvs, T tys), where T is the family TyCon -> ConDecl Name -> TcM DataCon -tcConDecl new_or_data rep_tycon res_tmpl -- Data types +tcConDecl new_or_data tc_name rep_tycon tmpl_tvs res_tmpl -- Data types (ConDecl { con_name = name , con_qvars = hs_tvs, con_cxt = hs_ctxt , con_details = hs_details, con_res = hs_res_ty }) = addErrCtxt (dataConCtxt name) $ do { traceTc "tcConDecl 1" (ppr name) - ; (tvs, ctxt, arg_tys, res_ty, is_infix, field_lbls, stricts) - <- tcHsTyVarBndrs hs_tvs $ \ tvs -> + ; (ctxt, arg_tys, res_ty, is_infix, field_lbls, stricts) + <- tcHsTyVarBndrs hs_tvs $ \ _ -> do { ctxt <- tcHsContext hs_ctxt ; details <- tcConArgs new_or_data hs_details - ; res_ty <- tcConRes hs_res_ty + ; res_ty <- tcConRes tc_name (unLoc name) hs_res_ty ; let (is_infix, field_lbls, btys) = details (arg_tys, stricts) = unzip btys - ; return (tvs, ctxt, arg_tys, res_ty, is_infix, field_lbls, stricts) } - - ; let pretend_res_ty = case res_ty of - ResTyH98 -> unitTy - ResTyGADT ty -> ty - pretend_con_ty = mkSigmaTy tvs ctxt (mkFunTys arg_tys pretend_res_ty) - -- This pretend_con_ty stuff is just a convenient way to get the - -- free kind variables of the type, for kindGeneralize to work on + ; return (ctxt, arg_tys, res_ty, is_infix, field_lbls, stricts) } -- Generalise the kind variables (returning quantifed TcKindVars) - -- and quantify the type variables (substiting their kinds) - ; kvs <- kindGeneralize (tyVarsOfType pretend_con_ty) (map getName tvs) - ; tvs <- zonkQuantifiedTyVars tvs - + -- and quantify the type variables (substituting their kinds) + -- REMEMBER: 'tkvs' are: + -- ResTyH98: the *existential* type variables only + -- ResTyGADT: *all* the quantified type variables + -- c.f. the comment on con_qvars in HsDecls + ; tkvs <- case res_ty of + ResTyH98 -> quantifyTyVars (mkVarSet tmpl_tvs) (tyVarsOfTypes (ctxt++arg_tys)) + ResTyGADT res_ty -> quantifyTyVars emptyVarSet (tyVarsOfTypes (res_ty:ctxt++arg_tys)) + -- Zonk to Types - ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv (kvs ++ tvs) + ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv tkvs ; arg_tys <- zonkTcTypeToTypes ze arg_tys ; ctxt <- zonkTcTypeToTypes ze ctxt ; res_ty <- case res_ty of ResTyH98 -> return ResTyH98 ResTyGADT ty -> ResTyGADT <$> zonkTcTypeToType ze ty - ; let (univ_tvs, ex_tvs, eq_preds, res_ty') - = rejigConRes res_tmpl qtkvs res_ty + ; let (univ_tvs, ex_tvs, eq_preds, res_ty') = rejigConRes tmpl_tvs res_tmpl qtkvs res_ty - ; traceTc "tcConDecl 3" (ppr name) ; fam_envs <- tcGetFamInstEnvs ; buildDataCon fam_envs (unLoc name) is_infix stricts field_lbls @@ -1073,10 +1202,49 @@ tcConArg new_or_data bty ; traceTc "tcConArg 2" (ppr bty) ; return (arg_ty, getBangStrictness bty) } -tcConRes :: ResType (LHsType Name) -> TcM (ResType Type) -tcConRes ResTyH98 = return ResTyH98 -tcConRes (ResTyGADT res_ty) = do { res_ty' <- tcHsLiftedType res_ty - ; return (ResTyGADT res_ty') } +tcConRes :: Name -- of tycon (for checking the validity of return type) + -> Name -- of datacon (for error messages only) + -> ResType (LHsType Name) -> TcM (ResType Type) +tcConRes _ _ ResTyH98 = return ResTyH98 +tcConRes tc_name dc_name (ResTyGADT res_ty) + = do { -- See Note [Checking GADT return types] + case hsTyGetAppHead_maybe res_ty of + Just (tc_name', _) + | tc_name' == tc_name -> return () + _ -> addErrTc (badDataConTyCon dc_name tc_name res_ty) + ; res_ty' <- tcHsLiftedType res_ty + ; return (ResTyGADT res_ty') } + +\end{code} + +Note [Checking GADT return types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There isn't really a good place to check that the return type of a GADT is +well-formed (that is, its head is the datatype's TyCon). One might think that +we can usefully do this in checkValidDataCon. But, the problem is that +rejigConRes, which sorts out the proper fields for the DataCon, has to match +the return type of the declaration with an appropriate template. If the return +type is mal-formed, this match fails, and rejigConRes has nowhere to go. +Before roles, rejigConRes just panicked in this scenario, because +checkValidDataCon was always called before anyone looked at the type of the +DataCon; laziness saved the day. However, role inference needs to look at the +types of all the DataCons in a group. Furthermore, checkValidTyCon needs to +make sure that the inferred roles are compatible with user-supplied role +annotations, so checkValidTyCon must force the role inference. So, if we're +not careful about all of this, role inference would force rejigConRes's panic, +and nastiness would ensue. + +There are two ways out of this scenario: + 1) Make sure we call checkValidDataCon on every DataCon in a group before + checking role annotations. This works fine, but it requires a change in + plumbing all the way up to tcTyClGroup, which is a little painful. + + 2) Do the check in tcConRes. It's a little harder to do the check here, + because the check must be made on an HsType, instead of a Type. Why + can't we look at the result of tcHsLiftedType? Because eventually, we'll + need to look inside of a TyCon, and that's a no-no inside of the knot. + +\begin{code} -- Example -- data instance T (b,c) where @@ -1087,7 +1255,7 @@ tcConRes (ResTyGADT res_ty) = do { res_ty' <- tcHsLiftedType res_ty -- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 -- In this case orig_res_ty = T (e,e) -rejigConRes :: ([TyVar], Type) -- Template for result type; e.g. +rejigConRes :: [TyVar] -> Type -- Template for result type; e.g. -- data instance T [a] b c = ... -- gives template ([a,b,c], T [a] b c) -> [TyVar] -- where MkT :: forall x y z. ... @@ -1097,16 +1265,15 @@ rejigConRes :: ([TyVar], Type) -- Template for result type; e.g. [(TyVar,Type)], -- Equality predicates Type) -- Typechecked return type -- We don't check that the TyCon given in the ResTy is - -- the same as the parent tycon, because we are in the middle - -- of a recursive knot; so it's postponed until checkValidDataCon + -- the same as the parent tycon, because tcConRes has already done it -rejigConRes (tmpl_tvs, res_ty) dc_tvs ResTyH98 +rejigConRes tmpl_tvs res_ty dc_tvs ResTyH98 = (tmpl_tvs, dc_tvs, [], res_ty) -- In H98 syntax the dc_tvs are the existential ones -- data T a b c = forall d e. MkT ... -- The {a,b,c} are tc_tvs, and {d,e} are dc_tvs -rejigConRes (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) +rejigConRes tmpl_tvs res_tmpl dc_tvs (ResTyGADT res_ty) -- E.g. data T [a] b c where -- MkT :: forall x y z. T [(x,y)] z z -- Then we generate @@ -1120,10 +1287,8 @@ rejigConRes (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty) where Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty -- This 'Just' pattern is sure to match, because if not - -- checkValidDataCon will complain first. The 'subst' - -- should not be looked at until after checkValidDataCon - -- We can't check eagerly because we are in a "knot" in - -- which 'tycon' is not yet fully defined + -- tcConRes will complain first. + -- See Note [Checking GADT return types] -- /Lazily/ figure out the univ_tvs etc -- Each univ_tv is either a dc_tv or a tmpl_tv @@ -1190,8 +1355,8 @@ checkClassCycleErrs cls where cls_cycles = calcClassCycles cls checkValidDecl :: SDoc -- the context for error checking - -> Located Name -> TcM () -checkValidDecl ctxt lname + -> Located Name -> RoleAnnots -> TcM () +checkValidDecl ctxt lname mroles = addErrCtxt ctxt $ do { traceTc "Validity of 1" (ppr lname) ; env <- getGblEnv @@ -1202,26 +1367,27 @@ checkValidDecl ctxt lname ; case thing of ATyCon tc -> do traceTc " of kind" (ppr (tyConKind tc)) - checkValidTyCon tc + checkValidTyCon tc mroles AnId _ -> return () -- Generic default methods are checked -- with their parent class _ -> panic "checkValidTyCl" ; traceTc "Done validity of" (ppr thing) } - -checkValidTyCl :: TyClDecl Name -> TcM () -checkValidTyCl decl - = do { checkValidDecl (tcMkDeclCtxt decl) (tyClDeclLName decl) + +checkValidTyCl :: RoleAnnots -> TyClDecl Name -> TcM () +checkValidTyCl mroles decl + = do { checkValidDecl (tcMkDeclCtxt decl) (tyClDeclLName decl) mroles ; case decl of ClassDecl { tcdATs = ats } -> mapM_ (checkValidFamDecl . unLoc) ats _ -> return () } checkValidFamDecl :: FamilyDecl Name -> TcM () -checkValidFamDecl (FamilyDecl { fdLName = lname, fdFlavour = flav }) +checkValidFamDecl (FamilyDecl { fdLName = lname, fdInfo = flav }) = checkValidDecl (hsep [ptext (sLit "In the"), ppr flav, ptext (sLit "declaration for"), quotes (ppr lname)]) lname + (pprPanic "checkValidFamDecl" (ppr lname)) -- no roles on families ------------------------- -- For data types declared with record syntax, we require @@ -1238,22 +1404,32 @@ checkValidFamDecl (FamilyDecl { fdLName = lname, fdFlavour = flav }) -- T2 { f1 :: c, f2 :: c, f3 ::Int } :: T -- Here we do not complain about f1,f2 because they are existential -checkValidTyCon :: TyCon -> TcM () -checkValidTyCon tc +checkValidTyCon :: TyCon -> RoleAnnots -> TcM () +checkValidTyCon tc mroles | Just cl <- tyConClass_maybe tc - = checkValidClass cl + = do { check_roles + ; checkValidClass cl } | Just syn_rhs <- synTyConRhs_maybe tc = case syn_rhs of - SynFamilyTyCon {} -> return () - SynonymTyCon ty -> checkValidType syn_ctxt ty + ClosedSynFamilyTyCon ax -> checkValidClosedCoAxiom ax + AbstractClosedSynFamilyTyCon -> + do { hsBoot <- tcIsHsBoot + ; checkTc hsBoot $ + ptext (sLit "You may omit the equations in a closed type family") $$ + ptext (sLit "only in a .hs-boot file") } + OpenSynFamilyTyCon -> return () + SynonymTyCon ty -> + do { check_roles + ; checkValidType syn_ctxt ty } | otherwise - = do { -- Check the context on the data decl + = do { unless (isFamilyTyCon tc) $ check_roles -- don't check data families! + + -- Check the context on the data decl ; traceTc "cvtc1" (ppr tc) ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) - -- Check arg types of data constructors ; traceTc "cvtc2" (ppr tc) ; dflags <- getDynFlags @@ -1270,6 +1446,23 @@ checkValidTyCon tc name = tyConName tc data_cons = tyConDataCons tc + -- Role annotations are given only on *type* variables, but a tycon stores + -- roles for all variables. So, we drop the kind roles (which are all + -- Nominal, anyway). + tyvars = tyConTyVars tc + (kind_vars, type_vars) = span isKindVar tyvars + roles = tyConRoles tc + type_roles = dropList kind_vars roles + + role_annots = case lookupNameEnv mroles name of + Just rs -> rs + Nothing -> pprPanic "checkValidTyCon role_annots" (ppr name) + + check_roles + = do { _ <- zipWith3M checkRoleAnnot type_vars role_annots type_roles + ; lint <- goptM Opt_DoCoreLinting + ; when lint $ checkValidRoles tc } + groups = equivClasses cmp_fld (concatMap get_fields data_cons) cmp_fld (f1,_) (f2,_) = f1 `compare` f2 get_fields con = dataConFieldLabels con `zip` repeat con @@ -1310,6 +1503,94 @@ checkValidTyCon tc fty2 = dataConFieldType con2 label check_fields [] = panic "checkValidTyCon/check_fields []" +checkRoleAnnot :: TyVar -> Maybe Role -> Role -> TcM () +checkRoleAnnot _ Nothing _ = return () +checkRoleAnnot tv (Just r1) r2 + = when (r1 /= r2) $ + addErrTc $ badRoleAnnot (tyVarName tv) r1 r2 + +-- This is a double-check on the role inference algorithm. It is only run when +-- -dcore-lint is enabled. See Note [Role inference] in TcTyDecls +checkValidRoles :: TyCon -> TcM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in CoreLint +checkValidRoles tc + | isAlgTyCon tc + -- tyConDataCons returns an empty list for data families + = mapM_ check_dc_roles (tyConDataCons tc) + | Just (SynonymTyCon rhs) <- synTyConRhs_maybe tc + = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs + | otherwise + = return () + where + check_dc_roles datacon + = let univ_tvs = dataConUnivTyVars datacon + ex_tvs = dataConExTyVars datacon + args = dataConRepArgTys datacon + univ_roles = zipVarEnv univ_tvs (tyConRoles tc) + -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs + ex_roles = mkVarEnv (zip ex_tvs (repeat Nominal)) + role_env = univ_roles `plusVarEnv` ex_roles in + mapM_ (check_ty_roles role_env Representational) args + + check_ty_roles env role (TyVarTy tv) + = case lookupVarEnv env tv of + Just role' -> unless (role' `ltRole` role || role' == role) $ + report_error $ ptext (sLit "type variable") <+> quotes (ppr tv) <+> + ptext (sLit "cannot have role") <+> ppr role <+> + ptext (sLit "because it was assigned role") <+> ppr role' + Nothing -> report_error $ ptext (sLit "type variable") <+> quotes (ppr tv) <+> + ptext (sLit "missing in environment") + + check_ty_roles env Representational (TyConApp tc tys) + = let roles' = tyConRoles tc in + zipWithM_ (maybe_check_ty_roles env) roles' tys + + check_ty_roles env Nominal (TyConApp _ tys) + = mapM_ (check_ty_roles env Nominal) tys + + check_ty_roles _ Phantom ty@(TyConApp {}) + = pprPanic "check_ty_roles" (ppr ty) + + check_ty_roles env role (AppTy ty1 ty2) + = check_ty_roles env role ty1 + >> check_ty_roles env Nominal ty2 + + check_ty_roles env role (FunTy ty1 ty2) + = check_ty_roles env role ty1 + >> check_ty_roles env role ty2 + + check_ty_roles env role (ForAllTy tv ty) + = check_ty_roles (extendVarEnv env tv Nominal) role ty + + check_ty_roles _ _ (LitTy {}) = return () + + maybe_check_ty_roles env role ty + = when (role == Nominal || role == Representational) $ + check_ty_roles env role ty + + report_error doc + = addErrTc $ vcat [ptext (sLit "Internal error in role inference:"), + doc, + ptext (sLit "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug")] + +checkValidClosedCoAxiom :: CoAxiom Branched -> TcM () +checkValidClosedCoAxiom (CoAxiom { co_ax_branches = branches, co_ax_tc = tc }) + = tcAddClosedTypeFamilyDeclCtxt tc $ + do { brListFoldlM_ check_accessibility [] branches + ; void $ brListMapM (checkValidTyFamInst Nothing tc) branches } + where + check_accessibility :: [CoAxBranch] -- prev branches (in reverse order) + -> CoAxBranch -- cur branch + -> TcM [CoAxBranch] -- cur : prev + -- Check whether the branch is dominated by earlier + -- ones and hence is inaccessible + check_accessibility prev_branches cur_branch + = do { when (cur_branch `isDominatedBy` prev_branches) $ + setSrcSpan (coAxBranchSpan cur_branch) $ + addErrTc $ inaccessibleCoAxBranch tc cur_branch + ; return (cur_branch : prev_branches) } + checkFieldCompat :: Name -> DataCon -> DataCon -> TyVarSet -> Type -> Type -> Type -> Type -> TcM () checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2 @@ -1325,14 +1606,7 @@ checkValidDataCon dflags existential_ok tc con = setSrcSpan (srcLocSpan (getSrcLoc con)) $ addErrCtxt (dataConCtxt con) $ do { traceTc "Validity of data con" (ppr con) - ; let tc_tvs = tyConTyVars tc - res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) - actual_res_ty = dataConOrigResTy con - ; traceTc "checkValidDataCon" (ppr con $$ ppr tc $$ ppr tc_tvs $$ ppr res_ty_tmpl) - ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs) - res_ty_tmpl - actual_res_ty)) - (badDataConTyCon con res_ty_tmpl actual_res_ty) + ; traceTc "checkValidDataCon" (ppr con $$ ppr tc) -- IA0_TODO: we should also check that kind variables -- are only instantiated with kind variables ; checkValidMonoType (dataConOrigResTy con) @@ -1375,16 +1649,26 @@ checkNewDataCon :: DataCon -> TcM () checkNewDataCon con = do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys)) -- One argument - ; checkTc (null eq_spec) (newtypePredError con) + + ; check_con (null eq_spec) $ + ptext (sLit "A newtype constructor must have a return type of form T a1 ... an") -- Return type is (T a b c) - ; checkTc (null ex_tvs && null theta) (newtypeExError con) + + ; check_con (null theta) $ + ptext (sLit "A newtype constructor cannot have a context in its type") + + ; check_con (null ex_tvs) $ + ptext (sLit "A newtype constructor cannot have existential type variables") -- No existentials + ; checkTc (not (any isBanged (dataConStrictMarks con))) (newtypeStrictError con) -- No strictness } where (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con + check_con what msg + = checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con)) ------------------------------- checkValidClass :: Class -> TcM () @@ -1472,6 +1756,13 @@ checkFamFlag tc_name where err_msg = hang (ptext (sLit "Illegal family declaraion for") <+> quotes (ppr tc_name)) 2 (ptext (sLit "Use -XTypeFamilies to allow indexed type families")) + +checkNoRoles :: LHsTyVarBndrs Name -> TcM () +checkNoRoles (HsQTvs { hsq_tvs = tvs }) + = mapM_ check tvs + where + check (L _ (HsTyVarBndr _ _ Nothing)) = return () + check (L _ (HsTyVarBndr name _ (Just _))) = addErrTc $ illegalRoleAnnot name \end{code} @@ -1699,10 +1990,7 @@ tcAddDefaultAssocDeclCtxt name thing_inside tcAddTyFamInstCtxt :: TyFamInstDecl Name -> TcM a -> TcM a tcAddTyFamInstCtxt decl - | [_] <- tfid_eqns decl = tcAddFamInstCtxt (ptext (sLit "type instance")) (tyFamInstDeclName decl) - | otherwise - = tcAddFamInstCtxt (ptext (sLit "type instance group")) (tyFamInstDeclName decl) tcAddDataFamInstCtxt :: DataFamInstDecl Name -> TcM a -> TcM a tcAddDataFamInstCtxt decl @@ -1717,6 +2005,13 @@ tcAddFamInstCtxt flavour tycon thing_inside <+> ptext (sLit "declaration for"), quotes (ppr tycon)] +tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a +tcAddClosedTypeFamilyDeclCtxt tc + = addErrCtxt ctxt + where + ctxt = ptext (sLit "In the equations for closed type family") <+> + quotes (ppr tc) + resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc resultTypeMisMatch field_name con1 con2 = vcat [sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2, @@ -1733,7 +2028,7 @@ dataConCtxt con = ptext (sLit "In the definition of data constructor") <+> quote classOpCtxt :: Var -> Type -> SDoc classOpCtxt sel_id tau = sep [ptext (sLit "When checking the class method:"), - nest 2 (ppr sel_id <+> dcolon <+> ppr tau)] + nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] nullaryClassErr :: Class -> SDoc nullaryClassErr cls @@ -1770,11 +2065,11 @@ recClsErr cycles = addErr (sep [ptext (sLit "Cycle in class declaration (via superclasses):"), nest 2 (hsep (intersperse (text "->") (map ppr cycles)))]) -badDataConTyCon :: DataCon -> Type -> Type -> SDoc -badDataConTyCon data_con res_ty_tmpl actual_res_ty +badDataConTyCon :: Name -> Name -> LHsType Name -> SDoc +badDataConTyCon data_con tc actual_res_ty = hang (ptext (sLit "Data constructor") <+> quotes (ppr data_con) <+> ptext (sLit "returns type") <+> quotes (ppr actual_res_ty)) - 2 (ptext (sLit "instead of an instance of its parent type") <+> quotes (ppr res_ty_tmpl)) + 2 (ptext (sLit "instead of an instance of its parent type") <+> quotes (ppr tc)) badGadtKindCon :: DataCon -> SDoc badGadtKindCon data_con @@ -1788,10 +2083,11 @@ badGadtDecl tc_name , nest 2 (parens $ ptext (sLit "Use -XGADTs to allow GADTs")) ] badExistential :: DataCon -> SDoc -badExistential con_name - = hang (ptext (sLit "Data constructor") <+> quotes (ppr con_name) <+> +badExistential con + = hang (ptext (sLit "Data constructor") <+> quotes (ppr con) <+> ptext (sLit "has existential type variables, a context, or a specialised result type")) - 2 (parens $ ptext (sLit "Use -XExistentialQuantification or -XGADTs to allow this")) + 2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con) + , parens $ ptext (sLit "Use -XExistentialQuantification or -XGADTs to allow this") ]) badStupidTheta :: Name -> SDoc badStupidTheta tc_name @@ -1802,21 +2098,11 @@ newtypeConError tycon n = sep [ptext (sLit "A newtype must have exactly one constructor,"), nest 2 $ ptext (sLit "but") <+> quotes (ppr tycon) <+> ptext (sLit "has") <+> speakN n ] -newtypeExError :: DataCon -> SDoc -newtypeExError con - = sep [ptext (sLit "A newtype constructor cannot have an existential context,"), - nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")] - newtypeStrictError :: DataCon -> SDoc newtypeStrictError con = sep [ptext (sLit "A newtype constructor cannot have a strictness annotation,"), nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does")] -newtypePredError :: DataCon -> SDoc -newtypePredError con - = sep [ptext (sLit "A newtype constructor must have a return type of form T a1 ... an"), - nest 2 $ ptext (sLit "but") <+> quotes (ppr con) <+> ptext (sLit "does not")] - newtypeFieldErr :: DataCon -> Int -> SDoc newtypeFieldErr con_name n_flds = sep [ptext (sLit "The constructor of a newtype must have exactly one field"), @@ -1833,11 +2119,6 @@ emptyConDeclsErr tycon = sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"), nest 2 $ ptext (sLit "(-XEmptyDataDecls permits this)")] -wrongNumberOfParmsErr :: Arity -> SDoc -wrongNumberOfParmsErr exp_arity - = ptext (sLit "Number of parameters must match family declaration; expected") - <+> ppr exp_arity - wrongKindOfFamily :: TyCon -> SDoc wrongKindOfFamily family = ptext (sLit "Wrong category of family instance; declaration was for a") @@ -1847,10 +2128,27 @@ wrongKindOfFamily family | isAlgTyCon family = ptext (sLit "data type") | otherwise = pprPanic "wrongKindOfFamily" (ppr family) +wrongNumberOfParmsErrTooMany :: Arity -> SDoc +wrongNumberOfParmsErrTooMany max_args + = ptext (sLit "Number of parameters must match family declaration; expected no more than") + <+> ppr max_args + wrongNamesInInstGroup :: Name -> Name -> SDoc wrongNamesInInstGroup first cur - = ptext (sLit "Mismatched family names in instance group.") $$ + = ptext (sLit "Mismatched type names in closed type family declaration.") $$ ptext (sLit "First name was") <+> (ppr first) <> (ptext (sLit "; this one is")) <+> (ppr cur) +inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc +inaccessibleCoAxBranch tc fi + = ptext (sLit "Inaccessible family instance equation:") $$ + (pprCoAxBranch tc fi) + +badRoleAnnot :: Name -> Role -> Role -> SDoc +badRoleAnnot var annot inferred + = hang (ptext (sLit "Role mismatch on variable") <+> ppr var <> colon) + 2 (sep [ ptext (sLit "Annotation says"), ppr annot + , ptext (sLit "but role"), ppr inferred + , ptext (sLit "is required") ]) + \end{code} diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index fb54899715..bea2cd19be 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -18,7 +18,8 @@ files for imported data types. module TcTyDecls( calcRecFlags, RecTyInfo(..), - calcSynCycles, calcClassCycles + calcSynCycles, calcClassCycles, + RoleAnnots ) where #include "HsVersions.h" @@ -34,15 +35,20 @@ import DataCon import Var import Name import NameEnv +import VarEnv +import VarSet import NameSet +import Coercion ( ltRole ) import Avail import Digraph import BasicTypes import SrcLoc +import Outputable import UniqSet -import Maybes( mapCatMaybes, isJust ) -import Util ( lengthIs, isSingleton ) +import Util +import Maybes import Data.List +import Control.Monad \end{code} @@ -351,13 +357,15 @@ compiled, plus the outer structure of directly-mentioned types. \begin{code} data RecTyInfo = RTI { rti_promotable :: Bool + , rti_roles :: Name -> [Role] , rti_is_rec :: Name -> RecFlag } -calcRecFlags :: ModDetails -> [TyThing] -> RecTyInfo +calcRecFlags :: ModDetails -> RoleAnnots -> [TyThing] -> RecTyInfo -- The 'boot_names' are the things declared in M.hi-boot, if M is the current module. -- Any type constructors in boot_names are automatically considered loop breakers -calcRecFlags boot_details tyclss +calcRecFlags boot_details mrole_env tyclss = RTI { rti_promotable = is_promotable + , rti_roles = roles , rti_is_rec = is_rec } where rec_tycon_names = mkNameSet (map tyConName all_tycons) @@ -367,6 +375,8 @@ calcRecFlags boot_details tyclss is_promotable = all (isPromotableTyCon rec_tycon_names) all_tycons + roles = inferRoles mrole_env all_tycons + ----------------- Recursion calculation ---------------- is_rec n | n `elemNameSet` rec_names = Recursive | otherwise = NonRecursive @@ -518,6 +528,279 @@ isPromotableType rec_tcs con_arg_ty go _ = False \end{code} +%************************************************************************ +%* * + Role inference +%* * +%************************************************************************ + +Note [Role inference] +~~~~~~~~~~~~~~~~~~~~~ +The role inference algorithm uses class, datatype, and synonym definitions +to infer the roles on the parameters. Although these roles are stored in the +tycons, we can perform this algorithm on the built tycons, as long as we +don't peek at an as-yet-unknown roles field! Ah, the magic of laziness. + +First, we choose appropriate initial roles. For families, roles (including +initial roles) are N. For all other types, we start with the role in the +role annotation (if any), or otherwise use Phantom. This is done in +initialRoleEnv1. + +The function irGroup then propagates role information until it reaches a +fixpoint, preferring N over R, P and R over P. To aid in this, we have a monad +RoleM, which is a combination reader and state monad. In its state are the +current RoleEnv, which gets updated by role propagation, and an update bit, +which we use to know whether or not we've reached the fixpoint. The +environment of RoleM contains the tycon whose parameters we are inferring, and +a VarEnv from parameters to their positions, so we can update the RoleEnv. +Between tycons, this reader information is missing; it is added by +addRoleInferenceInfo. + +There are two kinds of tycons to consider: algebraic ones (including classes) +and type synonyms. (Remember, families don't participate -- all their parameters +are N.) An algebraic tycon processes each of its datacons, in turn. Note that +a datacon's universally quantified parameters might be different from the parent +tycon's parameters, so we use the datacon's univ parameters in the mapping from +vars to positions. Note also that we don't want to infer roles for existentials +(they're all at N, too), so we put them in the set of local variables. As an +optimisation, we skip any tycons whose roles are already all Nominal, as there +nowhere else for them to go. For synonyms, we just analyse their right-hand sides. + +irType walks through a type, looking for uses of a variable of interest and +propagating role information. Because anything used under a phantom position +is at phantom and anything used under a nominal position is at nominal, the +irType function can assume that anything it sees is at representational. (The +other possibilities are pruned when they're encountered.) + +The rest of the code is just plumbing. + +How do we know that this algorithm is correct? It should meet the following +specification: + +Let Z be a role context -- a mapping from variables to roles. The following +rules define the property (Z |- t : r), where t is a type and r is a role: + +Z(a) = r' r' <= r +------------------------- RCVar +Z |- a : r + +---------- RCConst +Z |- T : r -- T is a type constructor + +Z |- t1 : r +Z |- t2 : N +-------------- RCApp +Z |- t1 t2 : r + +forall i<=n. (r_i is R or N) implies Z |- t_i : r_i +roles(T) = r_1 .. r_n +---------------------------------------------------- RCDApp +Z |- T t_1 .. t_n : R + +Z, a:N |- t : r +---------------------- RCAll +Z |- forall a:k.t : r + + +We also have the following rules: + +For all datacon_i in type T, where a_1 .. a_n are universally quantified +and b_1 .. b_m are existentially quantified, and the arguments are t_1 .. t_p, +then if forall j<=p, a_1 : r_1 .. a_n : r_n, b_1 : N .. b_m : N |- t_j : R, +then roles(T) = r_1 .. r_n + +roles(->) = R, R +roles(~#) = N, N + +With -dcore-lint on, the output of this algorithm is checked in checkValidRoles, +called from checkValidTycon. + +\begin{code} +type RoleEnv = NameEnv [Role] -- from tycon names to roles +type RoleAnnots = NameEnv [Maybe Role] -- from tycon names to role annotations, + -- which may be left out + +-- This, and any of the functions it calls, must *not* look at the roles +-- field of a tycon we are inferring roles about! +-- See Note [Role inference] +inferRoles :: RoleAnnots -> [TyCon] -> Name -> [Role] +inferRoles annots tycons + = let role_env = initialRoleEnv annots tycons + role_env' = irGroup role_env tycons in + \name -> case lookupNameEnv role_env' name of + Just roles -> roles + Nothing -> pprPanic "inferRoles" (ppr name) + +initialRoleEnv :: RoleAnnots -> [TyCon] -> RoleEnv +initialRoleEnv annots = extendNameEnvList emptyNameEnv . + map (initialRoleEnv1 annots) + +initialRoleEnv1 :: RoleAnnots -> TyCon -> (Name, [Role]) +initialRoleEnv1 annots_env tc + | isFamilyTyCon tc = (name, map (const Nominal) tyvars) + | isAlgTyCon tc + || isSynTyCon tc = (name, default_roles) + | otherwise = pprPanic "initialRoleEnv1" (ppr tc) + where name = tyConName tc + tyvars = tyConTyVars tc + + -- whether are not there are annotations, we're guaranteed that + -- the length of role_annots is appropriate + role_annots = case lookupNameEnv annots_env name of + Just annots -> annots + Nothing -> pprPanic "initialRoleEnv1 annots" (ppr name) + default_roles = let kvs = takeWhile isKindVar tyvars in + map (const Nominal) kvs ++ + zipWith orElse role_annots (repeat Phantom) + +irGroup :: RoleEnv -> [TyCon] -> RoleEnv +irGroup env tcs + = let (env', update) = runRoleM env $ mapM_ irTyCon tcs in + if update + then irGroup env' tcs + else env' + +irTyCon :: TyCon -> RoleM () +irTyCon tc + | isAlgTyCon tc + = do { old_roles <- lookupRoles tc + ; unless (all (== Nominal) old_roles) $ -- also catches data families, + -- which don't want or need role inference + do { whenIsJust (tyConClass_maybe tc) (irClass tc_name) + ; mapM_ (irDataCon tc_name) (visibleDataCons $ algTyConRhs tc) }} + + | Just (SynonymTyCon ty) <- synTyConRhs_maybe tc + = addRoleInferenceInfo tc_name (tyConTyVars tc) $ + irType emptyVarSet ty + + | otherwise + = return () + + where + tc_name = tyConName tc + +-- any type variable used in an associated type must be Nominal +irClass :: Name -> Class -> RoleM () +irClass tc_name cls + = addRoleInferenceInfo tc_name cls_tvs $ + mapM_ ir_at (classATs cls) + where + cls_tvs = classTyVars cls + cls_tv_set = mkVarSet cls_tvs + + ir_at at_tc + = mapM_ (updateRole Nominal) (varSetElems nvars) + where nvars = (mkVarSet $ tyConTyVars at_tc) `intersectVarSet` cls_tv_set + +-- See Note [Role inference] +irDataCon :: Name -> DataCon -> RoleM () +irDataCon tc_name datacon + = addRoleInferenceInfo tc_name (dataConUnivTyVars datacon) $ + let ex_var_set = mkVarSet $ dataConExTyVars datacon in + mapM_ (irType ex_var_set) (dataConRepArgTys datacon) + +irType :: VarSet -> Type -> RoleM () +irType = go + where + go lcls (TyVarTy tv) = unless (tv `elemVarSet` lcls) $ + updateRole Representational tv + go lcls (AppTy t1 t2) = go lcls t1 >> mark_nominal lcls t2 + go lcls (TyConApp tc tys) + = do { roles <- lookupRolesX tc + ; zipWithM_ (go_app lcls) roles tys } + go lcls (FunTy t1 t2) = go lcls t1 >> go lcls t2 + go lcls (ForAllTy tv ty) = go (extendVarSet lcls tv) ty + go _ (LitTy {}) = return () + + go_app _ Phantom _ = return () -- nothing to do here + go_app lcls Nominal ty = mark_nominal lcls ty -- all vars below here are N + go_app lcls Representational ty = go lcls ty + + mark_nominal lcls ty = let nvars = tyVarsOfType ty `minusVarSet` lcls in + mapM_ (updateRole Nominal) (varSetElems nvars) + +-- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps +lookupRolesX :: TyCon -> RoleM [Role] +lookupRolesX tc + = do { roles <- lookupRoles tc + ; return $ roles ++ repeat Nominal } + +-- gets the roles either from the environment or the tycon +lookupRoles :: TyCon -> RoleM [Role] +lookupRoles tc + = do { env <- getRoleEnv + ; case lookupNameEnv env (tyConName tc) of + Just roles -> return roles + Nothing -> return $ tyConRoles tc } + +-- tries to update a role; won't even update a role "downwards" +updateRole :: Role -> TyVar -> RoleM () +updateRole role tv + = do { var_ns <- getVarNs + ; case lookupVarEnv var_ns tv of + { Nothing -> pprPanic "updateRole" (ppr tv) + ; Just n -> do + { name <- getTyConName + ; updateRoleEnv name n role }}} + +-- the state in the RoleM monad +data RoleInferenceState = RIS { role_env :: RoleEnv + , update :: Bool } + +-- the environment in the RoleM monad +type VarPositions = VarEnv Int +data RoleInferenceInfo = RII { var_ns :: VarPositions + , name :: Name } + +-- See [Role inference] +newtype RoleM a = RM { unRM :: Maybe RoleInferenceInfo + -> RoleInferenceState + -> (a, RoleInferenceState) } +instance Monad RoleM where + return x = RM $ \_ state -> (x, state) + a >>= f = RM $ \m_info state -> let (a', state') = unRM a m_info state in + unRM (f a') m_info state' + +runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool) +runRoleM env thing = (env', update) + where RIS { role_env = env', update = update } = snd $ unRM thing Nothing state + state = RIS { role_env = env, update = False } + +addRoleInferenceInfo :: Name -> [TyVar] -> RoleM a -> RoleM a +addRoleInferenceInfo name tvs thing + = RM $ \_nothing state -> ASSERT( isNothing _nothing ) + unRM thing (Just info) state + where info = RII { var_ns = mkVarEnv (zip tvs [0..]), name = name } + +getRoleEnv :: RoleM RoleEnv +getRoleEnv = RM $ \_ state@(RIS { role_env = env }) -> (env, state) + +getVarNs :: RoleM VarPositions +getVarNs = RM $ \m_info state -> + case m_info of + Nothing -> panic "getVarNs" + Just (RII { var_ns = var_ns }) -> (var_ns, state) + +getTyConName :: RoleM Name +getTyConName = RM $ \m_info state -> + case m_info of + Nothing -> panic "getTyConName" + Just (RII { name = name }) -> (name, state) + + +updateRoleEnv :: Name -> Int -> Role -> RoleM () +updateRoleEnv name n role + = RM $ \_ state@(RIS { role_env = role_env }) -> ((), + case lookupNameEnv role_env name of + Nothing -> pprPanic "updateRoleEnv" (ppr name) + Just roles -> let (before, old_role : after) = splitAt n roles in + if role `ltRole` old_role + then let roles' = before ++ role : after + role_env' = extendNameEnv role_env name roles' in + RIS { role_env = role_env', update = True } + else state ) + +\end{code} %************************************************************************ %* * diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 77f7de682f..8a8de41159 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -37,7 +37,7 @@ module TcType ( TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv, MetaDetails(Flexi, Indirect), MetaInfo(..), isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, - isSigTyVar, isOverlappableTyVar, isTyConableTyVar, + isSigTyVar, isOverlappableTyVar, isTyConableTyVar, isFlatSkolTyVar, isAmbiguousTyVar, metaTvRef, metaTyVarInfo, isFlexi, isIndirect, isRuntimeUnkSkol, isTypeVar, isKindVar, @@ -613,7 +613,7 @@ isImmutableTyVar tv | otherwise = True isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar, - isMetaTyVar, isAmbiguousTyVar :: TcTyVar -> Bool + isMetaTyVar, isAmbiguousTyVar, isFlatSkolTyVar :: TcTyVar -> Bool isTyConableTyVar tv -- True of a meta-type variable that can be filled in @@ -624,6 +624,12 @@ isTyConableTyVar tv MetaTv { mtv_info = SigTv } -> False _ -> True +isFlatSkolTyVar tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + FlatSkol {} -> True + _ -> False + isSkolemTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of @@ -1324,18 +1330,19 @@ orphNamesOfDFunHead dfun_ty (_, _, head_ty) -> orphNamesOfType head_ty orphNamesOfCo :: Coercion -> NameSet -orphNamesOfCo (Refl ty) = orphNamesOfType ty -orphNamesOfCo (TyConAppCo tc cos) = unitNameSet (getName tc) `unionNameSets` orphNamesOfCos cos +orphNamesOfCo (Refl _ ty) = orphNamesOfType ty +orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSets` orphNamesOfCos cos orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2 orphNamesOfCo (ForAllCo _ co) = orphNamesOfCo co orphNamesOfCo (CoVarCo _) = emptyNameSet orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSets` orphNamesOfCos cos -orphNamesOfCo (UnsafeCo ty1 ty2) = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2 +orphNamesOfCo (UnivCo _ ty1 ty2) = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2 orphNamesOfCo (SymCo co) = orphNamesOfCo co orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2 orphNamesOfCo (NthCo _ co) = orphNamesOfCo co orphNamesOfCo (LRCo _ co) = orphNamesOfCo co orphNamesOfCo (InstCo co ty) = orphNamesOfCo co `unionNameSets` orphNamesOfType ty +orphNamesOfCo (SubCo co) = orphNamesOfCo co orphNamesOfCos :: [Coercion] -> NameSet orphNamesOfCos = orphNamesOfThings orphNamesOfCo diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 601135d303..b3a4743939 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -31,11 +31,7 @@ module TcUnify ( matchExpectedAppTy, matchExpectedFunTys, matchExpectedFunKind, - wrapFunResCoercion, - - -------------------------------- - -- Errors - mkKindErrorCtxt + wrapFunResCoercion ) where @@ -153,12 +149,15 @@ matchExpectedFunTys herald arity orig_ty Flexi -> defer n_req ty } -- In all other cases we bale out into ordinary unification - go n_req ty = defer n_req ty + -- However unlike the meta-tyvar case, we are sure that the + -- number of arrows doesn't match up, so we can add a bit + -- more context to the error message (cf Trac #7869) + go n_req ty = addErrCtxtM mk_ctxt $ + defer n_req ty ------------ defer n_req fun_ty - = addErrCtxtM mk_ctxt $ - do { arg_tys <- newFlexiTyVarTys n_req openTypeKind + = do { arg_tys <- newFlexiTyVarTys n_req openTypeKind -- See Note [Foralls to left of arrow] ; res_ty <- newFlexiTyVarTy openTypeKind ; co <- unifyType fun_ty (mkFunTys arg_tys res_ty) @@ -1163,7 +1162,7 @@ unifyKindEq (FunTy a1 r1) (FunTy a2 r2) unifyKindEq (TyConApp kc1 k1s) (TyConApp kc2 k2s) | kc1 == kc2 - = ASSERT (length k1s == length k2s) + = ASSERT(length k1s == length k2s) -- Should succeed since the kind constructors are the same, -- and the kinds are sort-checked, thus fully applied do { mb_eqs <- zipWithM unifyKindEq k1s k2s @@ -1197,19 +1196,4 @@ uUnboundKVar kv1 non_var_k2 ; case occurCheckExpand dflags kv1 k2b of OC_OK k2c -> do { writeMetaTyVar kv1 k2c; return (Just EQ) } _ -> return Nothing } - -mkKindErrorCtxt :: Type -> Type -> Kind -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc) -mkKindErrorCtxt ty1 ty2 k1 k2 env0 - = let (env1, ty1') = tidyOpenType env0 ty1 - (env2, ty2') = tidyOpenType env1 ty2 - (env3, k1' ) = tidyOpenKind env2 k1 - (env4, k2' ) = tidyOpenKind env3 k2 - in do ty1 <- zonkTcType ty1' - ty2 <- zonkTcType ty2' - k1 <- zonkTcKind k1' - k2 <- zonkTcKind k2' - return (env4, - vcat [ ptext (sLit "Kind incompatibility when matching types xx:") - , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1 - , ppr ty2 <+> dcolon <+> ppr k2 ]) ]) \end{code} diff --git a/compiler/typecheck/TcUnify.lhs-boot b/compiler/typecheck/TcUnify.lhs-boot index aa93536705..35a7155a08 100644 --- a/compiler/typecheck/TcUnify.lhs-boot +++ b/compiler/typecheck/TcUnify.lhs-boot @@ -1,14 +1,11 @@ \begin{code} module TcUnify where -import TcType ( TcTauType, Type, Kind ) -import VarEnv ( TidyEnv ) +import TcType ( TcTauType ) import TcRnTypes ( TcM ) import TcEvidence ( TcCoercion ) -import Outputable ( SDoc ) -- This boot file exists only to tie the knot between -- TcUnify and Inst unifyType :: TcTauType -> TcTauType -> TcM TcCoercion -mkKindErrorCtxt :: Type -> Type -> Kind -> Kind -> TidyEnv -> TcM (TidyEnv, SDoc) \end{code} diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs index d036c04dbf..968d8695cc 100644 --- a/compiler/typecheck/TcValidity.lhs +++ b/compiler/typecheck/TcValidity.lhs @@ -8,7 +8,7 @@ module TcValidity ( Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, expectedKindInCtxt, checkValidTheta, checkValidFamPats, - checkValidInstHead, checkValidInstance, validDerivPred, + checkValidInstance, validDerivPred, checkInstTermination, checkValidTyFamInst, checkTyFamFreeness, checkConsistentFamInst, arityErr, badATErr @@ -45,6 +45,7 @@ import ListSetOps import SrcLoc import Outputable import FastString +import BasicTypes ( Arity ) import Control.Monad import Data.List ( (\\) ) @@ -61,6 +62,12 @@ import Data.List ( (\\) ) \begin{code} checkAmbiguity :: UserTypeCtxt -> Type -> TcM () checkAmbiguity ctxt ty + | GhciCtxt <- ctxt -- Allow ambiguous types in GHCi's :kind command + = return () -- E.g. type family T a :: * -- T :: forall k. k -> * + -- Then :k T should work in GHCi, not complain that + -- (T k) is ambiguous! + + | otherwise = do { allow_ambiguous <- xoptM Opt_AllowAmbiguousTypes ; unless allow_ambiguous $ do {(subst, _tvs) <- tcInstSkolTyVars (varSetElems (tyVarsOfType ty)) @@ -276,30 +283,54 @@ check_type ctxt rank (AppTy ty1 ty2) ; check_arg_type ctxt rank ty2 } check_type ctxt rank ty@(TyConApp tc tys) - | isSynTyCon tc - = do { -- Check that the synonym has enough args - -- This applies equally to open and closed synonyms - -- It's OK to have an *over-applied* type synonym - -- data Tree a b = ... - -- type Foo a = Tree [a] - -- f :: Foo a b -> ... - checkTc (tyConArity tc <= length tys) arity_msg - - -- See Note [Liberal type synonyms] + | isSynTyCon tc = check_syn_tc_app ctxt rank ty tc tys + | isUnboxedTupleTyCon tc = check_ubx_tuple ctxt ty tys + | otherwise = mapM_ (check_arg_type ctxt rank) tys + +check_type _ _ (LitTy {}) = return () + +check_type _ _ ty = pprPanic "check_type" (ppr ty) + +---------------------------------------- +check_syn_tc_app :: UserTypeCtxt -> Rank -> KindOrType + -> TyCon -> [KindOrType] -> TcM () +check_syn_tc_app ctxt rank ty tc tys + | tc_arity <= n_args -- Saturated + -- Check that the synonym has enough args + -- This applies equally to open and closed synonyms + -- It's OK to have an *over-applied* type synonym + -- data Tree a b = ... + -- type Foo a = Tree [a] + -- f :: Foo a b -> ... + = do { -- See Note [Liberal type synonyms] ; liberal <- xoptM Opt_LiberalTypeSynonyms ; if not liberal || isSynFamilyTyCon tc then -- For H98 and synonym families, do check the type args - mapM_ (check_mono_type ctxt synArgMonoType) tys + mapM_ check_arg tys else -- In the liberal case (only for closed syns), expand then check case tcView ty of Just ty' -> check_type ctxt rank ty' - Nothing -> pprPanic "check_tau_type" (ppr ty) - } - - | isUnboxedTupleTyCon tc + Nothing -> pprPanic "check_tau_type" (ppr ty) } + + | GhciCtxt <- ctxt -- Accept under-saturated type synonyms in + -- GHCi :kind commands; see Trac #7586 + = mapM_ check_arg tys + + | otherwise + = failWithTc (arityErr "Type synonym" (tyConName tc) tc_arity n_args) + where + n_args = length tys + tc_arity = tyConArity tc + check_arg | isSynFamilyTyCon tc = check_arg_type ctxt rank + | otherwise = check_mono_type ctxt synArgMonoType + +---------------------------------------- +check_ubx_tuple :: UserTypeCtxt -> KindOrType + -> [KindOrType] -> TcM () +check_ubx_tuple ctxt ty tys = do { ub_tuples_allowed <- xoptM Opt_UnboxedTuples - ; checkTc ub_tuples_allowed ubx_tup_msg + ; checkTc ub_tuples_allowed (ubxArgTyErr ty) ; impred <- xoptM Opt_ImpredicativeTypes ; let rank' = if impred then ArbitraryRank else tyConArgMonoType @@ -307,21 +338,7 @@ check_type ctxt rank ty@(TyConApp tc tys) -- However, args are allowed to be unlifted, or -- more unboxed tuples, so can't use check_arg_ty ; mapM_ (check_type ctxt rank') tys } - - | otherwise - = mapM_ (check_arg_type ctxt rank) tys - - where - n_args = length tys - tc_arity = tyConArity tc - - arity_msg = arityErr "Type synonym" (tyConName tc) tc_arity n_args - ubx_tup_msg = ubxArgTyErr ty - -check_type _ _ (LitTy {}) = return () - -check_type _ _ ty = pprPanic "check_type" (ppr ty) - + ---------------------------------------- check_arg_type :: UserTypeCtxt -> Rank -> KindOrType -> TcM () -- The sort of type that can instantiate a type variable, @@ -819,11 +836,9 @@ validDerivPred tv_set pred checkValidInstance :: UserTypeCtxt -> LHsType Name -> Type -> TcM ([TyVar], ThetaType, Class, [Type]) checkValidInstance ctxt hs_type ty - = do { let (tvs, theta, tau) = tcSplitSigmaTy ty - ; case getClassPredTys_maybe tau of { - Nothing -> failWithTc (ptext (sLit "Malformed instance type")) ; - Just (clas,inst_tys) -> - do { setSrcSpan head_loc (checkValidInstHead ctxt clas inst_tys) + | Just (clas,inst_tys) <- getClassPredTys_maybe tau + , inst_tys `lengthIs` classArity clas + = do { setSrcSpan head_loc (checkValidInstHead ctxt clas inst_tys) ; checkValidTheta ctxt theta -- The Termination and Coverate Conditions @@ -845,8 +860,12 @@ checkValidInstance ctxt hs_type ty ; checkTc (checkInstCoverage clas inst_tys) (instTypeErr clas inst_tys msg) } - ; return (tvs, theta, clas, inst_tys) } } } + ; return (tvs, theta, clas, inst_tys) } + + | otherwise + = failWithTc (ptext (sLit "Malformed instance head:") <+> ppr tau) where + (tvs, theta, tau) = tcSplitSigmaTy ty msg = parens (vcat [ptext (sLit "the Coverage Condition fails for one of the functional dependencies;"), undecidableMsg]) @@ -1117,10 +1136,25 @@ checkValidFamPats :: TyCon -> [TyVar] -> [Type] -> TcM () -- e.g. we disallow (Trac #7536) -- type T a = Int -- type instance F (T a) = a +-- c) Have the right number of patterns checkValidFamPats fam_tc tvs ty_pats - = do { mapM_ checkTyFamFreeness ty_pats + = do { -- A family instance must have exactly the same number of type + -- parameters as the family declaration. You can't write + -- type family F a :: * -> * + -- type instance F Int y = y + -- because then the type (F Int) would be like (\y.y) + checkTc (length ty_pats == fam_arity) $ + wrongNumberOfParmsErr (fam_arity - length fam_kvs) -- report only types + ; mapM_ checkTyFamFreeness ty_pats ; let unbound_tvs = filterOut (`elemVarSet` exactTyVarsOfTypes ty_pats) tvs ; checkTc (null unbound_tvs) (famPatErr fam_tc unbound_tvs ty_pats) } + where fam_arity = tyConArity fam_tc + (fam_kvs, _) = splitForAllTys (tyConKind fam_tc) + +wrongNumberOfParmsErr :: Arity -> SDoc +wrongNumberOfParmsErr exp_arity + = ptext (sLit "Number of parameters must match family declaration; expected") + <+> ppr exp_arity -- Ensure that no type family instances occur in a type. -- diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs index 312ce84525..7a1251f8ea 100644 --- a/compiler/types/Class.lhs +++ b/compiler/types/Class.lhs @@ -143,15 +143,15 @@ parent class. Thus type F b x a :: * We make F use the same Name for 'a' as C does, and similary 'b'. -The only reason for this is when checking instances it's easier to match +The reason for this is when checking instances it's easier to match them up, to ensure they match. Eg instance C Int [d] where type F [d] x Int = .... we should make sure that the first and third args match the instance header. -This is the reason we use the Name and TyVar from the parent declaration, -in both class and instance decls: just to make this check easier. +Having the same variables for class and tycon is also used in checkValidRoles +(in TcTyClsDecls) when checking a class's roles. %************************************************************************ diff --git a/compiler/types/CoAxiom.lhs b/compiler/types/CoAxiom.lhs index bf432cae49..e507607cd3 100644 --- a/compiler/types/CoAxiom.lhs +++ b/compiler/types/CoAxiom.lhs @@ -4,7 +4,7 @@ \begin{code} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs, ScopedTypeVariables #-} -- | Module for coercion axioms, used to represent type family instances -- and newtypes @@ -13,17 +13,20 @@ module CoAxiom ( Branched, Unbranched, BranchIndex, BranchList(..), toBranchList, fromBranchList, toBranchedList, toUnbranchedList, - brListLength, brListNth, brListMap, brListFoldr, - brListZipWith, brListIndices, + brListLength, brListNth, brListMap, brListFoldr, brListMapM, + brListFoldlM_, brListZipWith, CoAxiom(..), CoAxBranch(..), toBranchedAxiom, toUnbranchedAxiom, coAxiomName, coAxiomArity, coAxiomBranches, - coAxiomTyCon, isImplicitCoAxiom, - coAxiomNthBranch, coAxiomSingleBranch_maybe, - coAxiomSingleBranch, coAxBranchTyVars, coAxBranchLHS, - coAxBranchRHS, coAxBranchSpan + coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats, + coAxiomNthBranch, coAxiomSingleBranch_maybe, coAxiomRole, + coAxiomSingleBranch, coAxBranchTyVars, coAxBranchRoles, + coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps, + placeHolderIncomps, + + Role(..) ) where import {-# SOURCE #-} TypeRep ( Type ) @@ -33,6 +36,7 @@ import Name import Unique import Var import Util +import Binary import BasicTypes import Data.Typeable ( Typeable ) import SrcLoc @@ -77,7 +81,7 @@ can unify with the supplied arguments. After all, it is possible that some of the type arguments are lambda-bound type variables whose instantiation may cause an earlier match among the branches. We wish to prohibit this behavior, so the type checker rules out the choice of a branch where a previous branch -can unify. See also [Instance checking within groups] in FamInstEnv.hs. +can unify. See also [Branched instance checking] in FamInstEnv.hs. For example, the following is malformed, where 'a' is a lambda-bound type variable: @@ -99,10 +103,10 @@ that code to deal with branched axioms, especially when the code can be sure of the fact that an axiom is indeed a singleton. At the same time, it seems dangerous to assume singlehood in various places through GHC. -The solution to this is to label a CoAxiom (and FamInst) with a phantom -type variable declaring whether it is known to be a singleton or not. The -list of branches is stored using a special form of list, declared below, -that ensures that the type variable is accurate. +The solution to this is to label a CoAxiom with a phantom type variable +declaring whether it is known to be a singleton or not. The list of branches +is stored using a special form of list, declared below, that ensures that the +type variable is accurate. As of this writing (Dec 2012), it would not be appropriate to use a promoted type as the phantom type, so we use empty datatypes. We wish to have GHC @@ -154,14 +158,6 @@ brListLength :: BranchList a br -> Int brListLength (FirstBranch _) = 1 brListLength (NextBranch _ t) = 1 + brListLength t --- Indices -brListIndices :: BranchList a br -> [BranchIndex] -brListIndices bs = go 0 bs - where - go :: BranchIndex -> BranchList a br -> [BranchIndex] - go n (NextBranch _ t) = n : go (n+1) t - go n (FirstBranch {}) = [n] - -- lookup brListNth :: BranchList a br -> BranchIndex -> a brListNth (FirstBranch b) 0 = b @@ -178,6 +174,21 @@ brListFoldr :: (a -> b -> b) -> b -> BranchList a br -> b brListFoldr f x (FirstBranch b) = f b x brListFoldr f x (NextBranch h t) = f h (brListFoldr f x t) +brListMapM :: Monad m => (a -> m b) -> BranchList a br -> m [b] +brListMapM f (FirstBranch b) = f b >>= \fb -> return [fb] +brListMapM f (NextBranch h t) = do { fh <- f h + ; ft <- brListMapM f t + ; return (fh : ft) } + +brListFoldlM_ :: forall a b m br. Monad m + => (a -> b -> m a) -> a -> BranchList b br -> m () +brListFoldlM_ f z brs = do { _ <- go z brs + ; return () } + where go :: forall br'. Monad m => a -> BranchList b br' -> m a + go acc (FirstBranch b) = f acc b + go acc (NextBranch h t) = do { fh <- f acc h + ; go fh t } + -- zipWith brListZipWith :: (a -> b -> c) -> BranchList a br1 -> BranchList b br2 -> [c] brListZipWith f (FirstBranch a) (FirstBranch b) = [f a b] @@ -197,6 +208,25 @@ instance Outputable a => Outputable (BranchList a br) where %* * %************************************************************************ +Note [Storing compatibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During axiom application, we need to be aware of which branches are compatible +with which others. The full explanation is in Note [Compatibility] in +FamInstEnv. (The code is placed there to avoid a dependency from CoAxiom on +the unification algorithm.) Although we could theoretically compute +compatibility on the fly, this is silly, so we store it in a CoAxiom. + +Specifically, each branch refers to all other branches with which it is +incompatible. This list might well be empty, and it will always be for the +first branch of any axiom. + +CoAxBranches that do not (yet) belong to a CoAxiom should have a panic thunk +stored in cab_incomps. The incompatibilities are properly a property of the +axiom as a whole, and they are computed only when the final axiom is built. + +During serialization, the list is converted into a list of the indices +of the branches. + \begin{code} -- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom. @@ -206,6 +236,7 @@ data CoAxiom br = CoAxiom -- Type equality axiom. { co_ax_unique :: Unique -- unique identifier , co_ax_name :: Name -- name for pretty-printing + , co_ax_role :: Role -- role of the axiom's equality , co_ax_tc :: TyCon -- the head of the LHS patterns , co_ax_branches :: BranchList CoAxBranch br -- the branches that form this axiom @@ -217,22 +248,28 @@ data CoAxiom br data CoAxBranch = CoAxBranch - { cab_loc :: SrcSpan -- Location of the defining equation - -- See Note [CoAxiom locations] - , cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh - -- See Note [CoAxBranch type variables] - , cab_lhs :: [Type] -- Type patterns to match against - , cab_rhs :: Type -- Right-hand side of the equality + { cab_loc :: SrcSpan -- Location of the defining equation + -- See Note [CoAxiom locations] + , cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh + -- See Note [CoAxBranch type variables] + , cab_roles :: [Role] -- See Note [CoAxBranch roles] + , cab_lhs :: [Type] -- Type patterns to match against + , cab_rhs :: Type -- Right-hand side of the equality + , cab_incomps :: [CoAxBranch] -- The previous incompatible branches + -- See Note [Storing compatibility] } deriving Typeable toBranchedAxiom :: CoAxiom br -> CoAxiom Branched -toBranchedAxiom (CoAxiom unique name tc branches implicit) - = CoAxiom unique name tc (toBranchedList branches) implicit +toBranchedAxiom (CoAxiom unique name role tc branches implicit) + = CoAxiom unique name role tc (toBranchedList branches) implicit toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched -toUnbranchedAxiom (CoAxiom unique name tc branches implicit) - = CoAxiom unique name tc (toUnbranchedList branches) implicit +toUnbranchedAxiom (CoAxiom unique name role tc branches implicit) + = CoAxiom unique name role tc (toUnbranchedList branches) implicit + +coAxiomNumPats :: CoAxiom br -> Int +coAxiomNumPats = length . coAxBranchLHS . (flip coAxiomNthBranch 0) coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index @@ -245,6 +282,9 @@ coAxiomArity ax index coAxiomName :: CoAxiom br -> Name coAxiomName = co_ax_name +coAxiomRole :: CoAxiom br -> Role +coAxiomRole = co_ax_role + coAxiomBranches :: CoAxiom br -> BranchList CoAxBranch br coAxiomBranches = co_ax_branches @@ -270,12 +310,21 @@ coAxBranchLHS = cab_lhs coAxBranchRHS :: CoAxBranch -> Type coAxBranchRHS = cab_rhs +coAxBranchRoles :: CoAxBranch -> [Role] +coAxBranchRoles = cab_roles + coAxBranchSpan :: CoAxBranch -> SrcSpan coAxBranchSpan = cab_loc isImplicitCoAxiom :: CoAxiom br -> Bool isImplicitCoAxiom = co_ax_implicit +coAxBranchIncomps :: CoAxBranch -> [CoAxBranch] +coAxBranchIncomps = cab_incomps + +placeHolderIncomps :: [CoAxBranch] +placeHolderIncomps = panic "placeHolderIncomps" + \end{code} Note [CoAxBranch type variables] @@ -300,6 +349,29 @@ class decl, we use the same 'b' to make the same check easy. So, unlike FamInsts, there is no expectation that the cab_tvs are fresh wrt each other, or any other CoAxBranch. +Note [CoAxBranch roles] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider this code: + + newtype Age = MkAge Int + newtype Wrap a = MkWrap a + + convert :: Wrap Age -> Int + convert (MkWrap (MkAge i)) = i + +We want this to compile to: + + NTCo:Wrap :: forall a. Wrap a ~R a + NTCo:Age :: Age ~R Int + convert = \x -> x |> (NTCo:Wrap[0] NTCo:Age[0]) + +But, note that NTCo:Age is at role R. Thus, we need to be able to pass +coercions at role R into axioms. However, we don't *always* want to be able to +do this, as it would be disastrous with type families. The solution is to +annotate the arguments to the axiom with roles, much like we annotate tycon +tyvars. Where do these roles get set? Newtype axioms inherit their roles from +the newtype tycon; family axioms are all at role N. + Note [CoAxiom locations] ~~~~~~~~~~~~~~~~~~~~~~~~ The source location of a CoAxiom is stored in two places in the @@ -353,3 +425,35 @@ instance Typeable br => Data.Data (CoAxiom br) where dataTypeOf _ = mkNoRepType "CoAxiom" \end{code} +%************************************************************************ +%* * + Roles +%* * +%************************************************************************ + +This is defined here to avoid circular dependencies. + +\begin{code} + +-- See Note [Roles] in Coercion +-- defined here to avoid cyclic dependency with Coercion +data Role = Nominal | Representational | Phantom + deriving (Eq, Data.Data, Data.Typeable) + +instance Outputable Role where + ppr Nominal = char 'N' + ppr Representational = char 'R' + ppr Phantom = char 'P' + +instance Binary Role where + put_ bh Nominal = putByte bh 1 + put_ bh Representational = putByte bh 2 + put_ bh Phantom = putByte bh 3 + + get bh = do tag <- getByte bh + case tag of 1 -> return Nominal + 2 -> return Representational + 3 -> return Phantom + _ -> panic ("get Role " ++ show tag) + +\end{code}
\ No newline at end of file diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index 4ade32b0e9..6cda16b9ec 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -15,17 +15,15 @@ -- more on System FC and how coercions fit into it. -- module Coercion ( - -- * CoAxioms - mkCoAxBranch, mkBranchedCoAxiom, mkSingleCoAxiom, - -- * Main data type Coercion(..), Var, CoVar, LeftOrRight(..), pickLR, + Role(..), ltRole, -- ** Functions over coercions - coVarKind, + coVarKind, coVarRole, coercionType, coercionKind, coercionKinds, isReflCo, - isReflCo_maybe, + isReflCo_maybe, coercionRole, mkCoercionType, -- ** Constructing coercions @@ -33,19 +31,19 @@ module Coercion ( mkAxInstCo, mkUnbranchedAxInstCo, mkAxInstLHS, mkAxInstRHS, mkUnbranchedAxInstRHS, mkPiCo, mkPiCos, mkCoCast, - mkSymCo, mkTransCo, mkNthCo, mkLRCo, + mkSymCo, mkTransCo, mkNthCo, mkNthCoRole, mkLRCo, mkInstCo, mkAppCo, mkTyConAppCo, mkFunCo, - mkForAllCo, mkUnsafeCo, - mkNewTypeCo, + mkForAllCo, mkUnsafeCo, mkUnivCo, mkSubCo, mkPhantomCo, + mkNewTypeCo, maybeSubCo, maybeSubCo2, -- ** Decomposition splitNewTypeRepCo_maybe, instNewTyCon_maybe, topNormaliseNewType, topNormaliseNewTypeX, decomposeCo, getCoVar_maybe, - splitTyConAppCo_maybe, splitAppCo_maybe, splitForAllCo_maybe, + nthRole, tyConRolesX, -- ** Coercion variables mkCoVar, isCoVar, isCoVarType, coVarName, setCoVarName, setCoVarUnique, @@ -60,7 +58,8 @@ module Coercion ( substCo, substCos, substCoVar, substCoVars, substCoWithTy, substCoWithTys, cvTvSubst, tvCvSubst, mkCvSubst, zipOpenCvSubst, - substTy, extendTvSubst, extendCvSubstAndInScope, + substTy, extendTvSubst, + extendCvSubstAndInScope, extendTvSubstAndInScope, substTyVarBndr, substCoVarBndr, -- ** Lifting @@ -94,9 +93,9 @@ import CoAxiom import Var import VarEnv import VarSet +import Binary import Maybes ( orElse ) import Name ( Name, NamedThing(..), nameUnique, nameModule, getSrcSpan ) -import NameSet import OccName ( parenSymOcc ) import Util import BasicTypes @@ -104,67 +103,14 @@ import Outputable import Unique import Pair import SrcLoc -import PrelNames ( funTyConKey, eqPrimTyConKey ) +import PrelNames ( funTyConKey, eqPrimTyConKey, eqReprPrimTyConKey ) import Control.Applicative import Data.Traversable (traverse, sequenceA) -import Control.Arrow (second) import FastString import qualified Data.Data as Data hiding ( TyCon ) \end{code} - -%************************************************************************ -%* * - Constructing axioms - These functions are here because tidyType etc - are not available in CoAxiom -%* * -%************************************************************************ - -Note [Tidy axioms when we build them] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We print out axioms and don't want to print stuff like - F k k a b = ... -Instead we must tidy those kind variables. See Trac #7524. - - -\begin{code} -mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars - -> [Type] -- LHS patterns - -> Type -- RHS - -> SrcSpan - -> CoAxBranch -mkCoAxBranch tvs lhs rhs loc - = CoAxBranch { cab_tvs = tvs1 - , cab_lhs = tidyTypes env lhs - , cab_rhs = tidyType env rhs - , cab_loc = loc } - where - (env, tvs1) = tidyTyVarBndrs emptyTidyEnv tvs - -- See Note [Tidy axioms when we build them] - - -mkBranchedCoAxiom :: Name -> TyCon -> [CoAxBranch] -> CoAxiom Branched -mkBranchedCoAxiom ax_name fam_tc branches - = CoAxiom { co_ax_unique = nameUnique ax_name - , co_ax_name = ax_name - , co_ax_tc = fam_tc - , co_ax_implicit = False - , co_ax_branches = toBranchList branches } - -mkSingleCoAxiom :: Name -> [TyVar] -> TyCon -> [Type] -> Type -> CoAxiom Unbranched -mkSingleCoAxiom ax_name tvs fam_tc lhs_tys rhs_ty - = CoAxiom { co_ax_unique = nameUnique ax_name - , co_ax_name = ax_name - , co_ax_tc = fam_tc - , co_ax_implicit = False - , co_ax_branches = FirstBranch branch } - where - branch = mkCoAxBranch tvs lhs_tys rhs_ty (getSrcSpan ax_name) -\end{code} - - %************************************************************************ %* * Coercions @@ -178,8 +124,16 @@ mkSingleCoAxiom ax_name tvs fam_tc lhs_tys rhs_ty -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in coreSyn/CoreLint.lhs data Coercion + -- Each constructor has a "role signature", indicating the way roles are + -- propagated through coercions. P, N, and R stand for coercions of the + -- given role. e stands for a coercion of a specific unknown role (think + -- "role polymorphism"). "e" stands for an explicit role parameter + -- indicating role e. _ stands for a parameter that is not a Role or + -- Coercion. + -- These ones mirror the shape of types - = Refl Type -- See Note [Refl invariant] + = -- Refl :: "e" -> _ -> e + Refl Role Type -- See Note [Refl invariant] -- Invariant: applications of (Refl T) to a bunch of identity coercions -- always show up as Refl. -- For example (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)). @@ -190,20 +144,30 @@ data Coercion -- ConAppCo coercions (like all coercions other than Refl) -- are NEVER the identity. + -- Use (Refl Representational _), not (SubCo (Refl Nominal _)) + -- These ones simply lift the correspondingly-named -- Type constructors into Coercions - | TyConAppCo TyCon [Coercion] -- lift TyConApp + + -- TyConAppCo :: "e" -> _ -> ?? -> e + -- See Note [TyConAppCo roles] + | TyConAppCo Role TyCon [Coercion] -- lift TyConApp -- The TyCon is never a synonym; -- we expand synonyms eagerly -- But it can be a type function | AppCo Coercion Coercion -- lift AppTy + -- AppCo :: e -> N -> e -- See Note [Forall coercions] | ForAllCo TyVar Coercion -- forall a. g + -- :: _ -> e -> e -- These are special - | CoVarCo CoVar + | CoVarCo CoVar -- :: _ -> (N or R) + -- result role depends on the tycon of the variable's type + + -- AxiomInstCo :: e -> _ -> [N] -> e | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion] -- See also [CoAxiom index] -- The coercion arguments always *precisely* saturate @@ -211,14 +175,22 @@ data Coercion -- any left over, we use AppCo. See -- See [Coercion axioms applied to coercions] - | UnsafeCo Type Type - | SymCo Coercion - | TransCo Coercion Coercion + -- see Note [UnivCo] + | UnivCo Role Type Type -- :: "e" -> _ -> _ -> e + | SymCo Coercion -- :: e -> e + | TransCo Coercion Coercion -- :: e -> e -> e -- These are destructors + | NthCo Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) + -- :: _ -> e -> ?? (inverse of TyConAppCo, see Note [TyConAppCo roles]) | LRCo LeftOrRight Coercion -- Decomposes (t_left t_right) + -- :: _ -> N -> N | InstCo Coercion Type + -- :: e -> _ -> e + + | SubCo Coercion -- Turns a ~N into a ~R + -- :: N -> R deriving (Data.Data, Data.Typeable) -- If you edit this type, you may need to update the GHC formalism @@ -226,12 +198,20 @@ data Coercion data LeftOrRight = CLeft | CRight deriving( Eq, Data.Data, Data.Typeable ) +instance Binary LeftOrRight where + put_ bh CLeft = putByte bh 0 + put_ bh CRight = putByte bh 1 + + get bh = do { h <- getByte bh + ; case h of + 0 -> return CLeft + _ -> return CRight } + pickLR :: LeftOrRight -> (a,a) -> a pickLR CLeft (l,_) = l pickLR CRight (_,r) = r \end{code} - Note [Refl invariant] ~~~~~~~~~~~~~~~~~~~~~ Coercions have the following invariant @@ -369,6 +349,142 @@ may turn into C (Nth 0 g) .... Now (Nth 0 g) will optimise to Refl, but perhaps not instantly. +Note [Roles] +~~~~~~~~~~~~ +Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated +in Trac #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see +http://ghc.haskell.org/trac/ghc/wiki/RolesImplementation + +Here is one way to phrase the problem: + +Given: +newtype Age = MkAge Int +type family F x +type instance F Age = Bool +type instance F Int = Char + +This compiles down to: +axAge :: Age ~ Int +axF1 :: F Age ~ Bool +axF2 :: F Int ~ Char + +Then, we can make: +(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char + +Yikes! + +The solution is _roles_, as articulated in "Generative Type Abstraction and +Type-level Computation" (POPL 2010), available at +http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf + +The specification for roles has evolved somewhat since that paper. For the +current full details, see the documentation in docs/core-spec. Here are some +highlights. + +We label every equality with a notion of type equivalence, of which there are +three options: Nominal, Representational, and Phantom. A ground type is +nominally equivalent only with itself. A newtype (which is considered a ground +type in Haskell) is representationally equivalent to its representation. +Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P" +to denote the equivalences. + +The axioms above would be: +axAge :: Age ~R Int +axF1 :: F Age ~N Bool +axF2 :: F Age ~N Char + +Then, because transitivity applies only to coercions proving the same notion +of equivalence, the above construction is impossible. + +However, there is still an escape hatch: we know that any two types that are +nominally equivalent are representationally equivalent as well. This is what +the form SubCo proves -- it "demotes" a nominal equivalence into a +representational equivalence. So, it would seem the following is possible: + +sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char -- WRONG + +What saves us here is that the arguments to a type function F, lifted into a +coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and +we are safe. + +Roles are attached to parameters to TyCons. When lifting a TyCon into a +coercion (through TyConAppCo), we need to ensure that the arguments to the +TyCon respect their roles. For example: + +data T a b = MkT a (F b) + +If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know +that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because +the type function F branches on b's *name*, not representation. So, we say +that 'a' has role Representational and 'b' has role Nominal. The third role, +Phantom, is for parameters not used in the type's definition. Given the +following definition + +data Q a = MkQ Int + +the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we +can construct the coercion Bool ~P Char (using UnivCo). + +See the paper cited above for more examples and information. + +Note [UnivCo] +~~~~~~~~~~~~~ +The UnivCo ("universal coercion") serves two rather separate functions: + - the implementation for unsafeCoerce# + - placeholder for phantom parameters in a TyConAppCo + +At Representational, it asserts that two (possibly unrelated) +types have the same representation and can be casted to one another. +This form is necessary for unsafeCoerce#. + +For optimisation purposes, it is convenient to allow UnivCo to appear +at Nominal role. If we have + +data Foo a = MkFoo (F a) -- F is a type family + +and we want an unsafe coercion from Foo Int to Foo Bool, then it would +be nice to have (TyConAppCo Foo (UnivCo Nominal Int Bool)). So, we allow +Nominal UnivCo's. + +At Phantom role, it is used as an argument to TyConAppCo in the place +of a phantom parameter (a type parameter unused in the type definition). + +For example: + +data Q a = MkQ Int + +We want a coercion for (Q Bool) ~R (Q Char). + +(TyConAppCo Representational Q [UnivCo Phantom Bool Char]) does the trick. + +Note [TyConAppCo roles] +~~~~~~~~~~~~~~~~~~~~~~~ +The TyConAppCo constructor has a role parameter, indicating the role at +which the coercion proves equality. The choice of this parameter affects +the required roles of the arguments of the TyConAppCo. To help explain +it, assume the following definition: + +newtype Age = MkAge Int + +Nominal: All arguments must have role Nominal. Why? So that Foo Age ~N Foo Int +does *not* hold. + +Representational: All arguments must have the roles corresponding to the +result of tyConRoles on the TyCon. This is the whole point of having +roles on the TyCon to begin with. So, we can have Foo Age ~R Foo Int, +if Foo's parameter has role R. + +If a Representational TyConAppCo is over-saturated (which is otherwise fine), +the spill-over arguments must all be at Nominal. This corresponds to the +behavior for AppCo. + +Phantom: All arguments must have role Phantom. This one isn't strictly +necessary for soundness, but this choice removes ambiguity. + + + +The rules here also dictate what the parameters to mkTyConAppCo. + %************************************************************************ %* * \subsection{Coercion variables} @@ -391,7 +507,8 @@ isCoVar v = isCoVarType (varType v) isCoVarType :: Type -> Bool isCoVarType ty -- Tests for t1 ~# t2, the unboxed equality = case splitTyConApp_maybe ty of - Just (tc,tys) -> tc `hasKey` eqPrimTyConKey && tys `lengthAtLeast` 2 + Just (tc,tys) -> (tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey) + && tys `lengthAtLeast` 2 Nothing -> False \end{code} @@ -399,53 +516,56 @@ isCoVarType ty -- Tests for t1 ~# t2, the unboxed equality \begin{code} tyCoVarsOfCo :: Coercion -> VarSet -- Extracts type and coercion variables from a coercion -tyCoVarsOfCo (Refl ty) = tyVarsOfType ty -tyCoVarsOfCo (TyConAppCo _ cos) = tyCoVarsOfCos cos -tyCoVarsOfCo (AppCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2 -tyCoVarsOfCo (ForAllCo tv co) = tyCoVarsOfCo co `delVarSet` tv -tyCoVarsOfCo (CoVarCo v) = unitVarSet v +tyCoVarsOfCo (Refl _ ty) = tyVarsOfType ty +tyCoVarsOfCo (TyConAppCo _ _ cos) = tyCoVarsOfCos cos +tyCoVarsOfCo (AppCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2 +tyCoVarsOfCo (ForAllCo tv co) = tyCoVarsOfCo co `delVarSet` tv +tyCoVarsOfCo (CoVarCo v) = unitVarSet v tyCoVarsOfCo (AxiomInstCo _ _ cos) = tyCoVarsOfCos cos -tyCoVarsOfCo (UnsafeCo ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 -tyCoVarsOfCo (SymCo co) = tyCoVarsOfCo co -tyCoVarsOfCo (TransCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2 -tyCoVarsOfCo (NthCo _ co) = tyCoVarsOfCo co -tyCoVarsOfCo (LRCo _ co) = tyCoVarsOfCo co -tyCoVarsOfCo (InstCo co ty) = tyCoVarsOfCo co `unionVarSet` tyVarsOfType ty +tyCoVarsOfCo (UnivCo _ ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 +tyCoVarsOfCo (SymCo co) = tyCoVarsOfCo co +tyCoVarsOfCo (TransCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2 +tyCoVarsOfCo (NthCo _ co) = tyCoVarsOfCo co +tyCoVarsOfCo (LRCo _ co) = tyCoVarsOfCo co +tyCoVarsOfCo (InstCo co ty) = tyCoVarsOfCo co `unionVarSet` tyVarsOfType ty +tyCoVarsOfCo (SubCo co) = tyCoVarsOfCo co tyCoVarsOfCos :: [Coercion] -> VarSet tyCoVarsOfCos cos = foldr (unionVarSet . tyCoVarsOfCo) emptyVarSet cos coVarsOfCo :: Coercion -> VarSet -- Extract *coerction* variables only. Tiresome to repeat the code, but easy. -coVarsOfCo (Refl _) = emptyVarSet -coVarsOfCo (TyConAppCo _ cos) = coVarsOfCos cos -coVarsOfCo (AppCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 -coVarsOfCo (ForAllCo _ co) = coVarsOfCo co -coVarsOfCo (CoVarCo v) = unitVarSet v +coVarsOfCo (Refl _ _) = emptyVarSet +coVarsOfCo (TyConAppCo _ _ cos) = coVarsOfCos cos +coVarsOfCo (AppCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 +coVarsOfCo (ForAllCo _ co) = coVarsOfCo co +coVarsOfCo (CoVarCo v) = unitVarSet v coVarsOfCo (AxiomInstCo _ _ cos) = coVarsOfCos cos -coVarsOfCo (UnsafeCo _ _) = emptyVarSet -coVarsOfCo (SymCo co) = coVarsOfCo co -coVarsOfCo (TransCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 -coVarsOfCo (NthCo _ co) = coVarsOfCo co -coVarsOfCo (LRCo _ co) = coVarsOfCo co -coVarsOfCo (InstCo co _) = coVarsOfCo co +coVarsOfCo (UnivCo _ _ _) = emptyVarSet +coVarsOfCo (SymCo co) = coVarsOfCo co +coVarsOfCo (TransCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 +coVarsOfCo (NthCo _ co) = coVarsOfCo co +coVarsOfCo (LRCo _ co) = coVarsOfCo co +coVarsOfCo (InstCo co _) = coVarsOfCo co +coVarsOfCo (SubCo co) = coVarsOfCo co coVarsOfCos :: [Coercion] -> VarSet coVarsOfCos cos = foldr (unionVarSet . coVarsOfCo) emptyVarSet cos coercionSize :: Coercion -> Int -coercionSize (Refl ty) = typeSize ty -coercionSize (TyConAppCo _ cos) = 1 + sum (map coercionSize cos) -coercionSize (AppCo co1 co2) = coercionSize co1 + coercionSize co2 -coercionSize (ForAllCo _ co) = 1 + coercionSize co -coercionSize (CoVarCo _) = 1 +coercionSize (Refl _ ty) = typeSize ty +coercionSize (TyConAppCo _ _ cos) = 1 + sum (map coercionSize cos) +coercionSize (AppCo co1 co2) = coercionSize co1 + coercionSize co2 +coercionSize (ForAllCo _ co) = 1 + coercionSize co +coercionSize (CoVarCo _) = 1 coercionSize (AxiomInstCo _ _ cos) = 1 + sum (map coercionSize cos) -coercionSize (UnsafeCo ty1 ty2) = typeSize ty1 + typeSize ty2 -coercionSize (SymCo co) = 1 + coercionSize co -coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 -coercionSize (NthCo _ co) = 1 + coercionSize co -coercionSize (LRCo _ co) = 1 + coercionSize co -coercionSize (InstCo co ty) = 1 + coercionSize co + typeSize ty +coercionSize (UnivCo _ ty1 ty2) = typeSize ty1 + typeSize ty2 +coercionSize (SymCo co) = 1 + coercionSize co +coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 +coercionSize (NthCo _ co) = 1 + coercionSize co +coercionSize (LRCo _ co) = 1 + coercionSize co +coercionSize (InstCo co ty) = 1 + coercionSize co + typeSize ty +coercionSize (SubCo co) = 1 + coercionSize co \end{code} %************************************************************************ @@ -459,24 +579,25 @@ tidyCo :: TidyEnv -> Coercion -> Coercion tidyCo env@(_, subst) co = go co where - go (Refl ty) = Refl (tidyType env ty) - go (TyConAppCo tc cos) = let args = map go cos - in args `seqList` TyConAppCo tc args - go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 - go (ForAllCo tv co) = ForAllCo tvp $! (tidyCo envp co) - where - (envp, tvp) = tidyTyVarBndr env tv - go (CoVarCo cv) = case lookupVarEnv subst cv of - Nothing -> CoVarCo cv - Just cv' -> CoVarCo cv' + go (Refl r ty) = Refl r (tidyType env ty) + go (TyConAppCo r tc cos) = let args = map go cos + in args `seqList` TyConAppCo r tc args + go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 + go (ForAllCo tv co) = ForAllCo tvp $! (tidyCo envp co) + where + (envp, tvp) = tidyTyVarBndr env tv + go (CoVarCo cv) = case lookupVarEnv subst cv of + Nothing -> CoVarCo cv + Just cv' -> CoVarCo cv' go (AxiomInstCo con ind cos) = let args = tidyCos env cos - in args `seqList` AxiomInstCo con ind args - go (UnsafeCo ty1 ty2) = (UnsafeCo $! tidyType env ty1) $! tidyType env ty2 - go (SymCo co) = SymCo $! go co - go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 - go (NthCo d co) = NthCo d $! go co - go (LRCo lr co) = LRCo lr $! go co - go (InstCo co ty) = (InstCo $! go co) $! tidyType env ty + in args `seqList` AxiomInstCo con ind args + go (UnivCo r ty1 ty2) = (UnivCo r $! tidyType env ty1) $! tidyType env ty2 + go (SymCo co) = SymCo $! go co + go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 + go (NthCo d co) = NthCo d $! go co + go (LRCo lr co) = LRCo lr $! go co + go (InstCo co ty) = (InstCo $! go co) $! tidyType env ty + go (SubCo co) = SubCo $! go co tidyCos :: TidyEnv -> [Coercion] -> [Coercion] tidyCos env = map (tidyCo env) @@ -503,16 +624,16 @@ pprCo co = ppr_co TopPrec co pprParendCo co = ppr_co TyConPrec co ppr_co :: Prec -> Coercion -> SDoc -ppr_co _ (Refl ty) = angleBrackets (ppr ty) +ppr_co _ (Refl r ty) = angleBrackets (ppr ty) <> ppr_role r -ppr_co p co@(TyConAppCo tc [_,_]) +ppr_co p co@(TyConAppCo _ tc [_,_]) | tc `hasKey` funTyConKey = ppr_fun_co p co -ppr_co p (TyConAppCo tc cos) = pprTcApp p ppr_co tc cos -ppr_co p (AppCo co1 co2) = maybeParen p TyConPrec $ - pprCo co1 <+> ppr_co TyConPrec co2 -ppr_co p co@(ForAllCo {}) = ppr_forall_co p co -ppr_co _ (CoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv) +ppr_co _ (TyConAppCo r tc cos) = pprTcApp TyConPrec ppr_co tc cos <> ppr_role r +ppr_co p (AppCo co1 co2) = maybeParen p TyConPrec $ + pprCo co1 <+> ppr_co TyConPrec co2 +ppr_co p co@(ForAllCo {}) = ppr_forall_co p co +ppr_co _ (CoVarCo cv) = parenSymOcc (getOccName cv) (ppr cv) ppr_co p (AxiomInstCo con index cos) = pprPrefixApp p (ppr (getName con) <> brackets (ppr index)) (map (ppr_co TyConPrec) cos) @@ -525,11 +646,15 @@ ppr_co p co@(TransCo {}) = maybeParen p FunPrec $ ppr_co p (InstCo co ty) = maybeParen p TyConPrec $ pprParendCo co <> ptext (sLit "@") <> pprType ty -ppr_co p (UnsafeCo ty1 ty2) = pprPrefixApp p (ptext (sLit "UnsafeCo")) +ppr_co p (UnivCo r ty1 ty2) = pprPrefixApp p (ptext (sLit "UnivCo") <+> ppr r) [pprParendType ty1, pprParendType ty2] ppr_co p (SymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendCo co] ppr_co p (NthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <> int n) [pprParendCo co] ppr_co p (LRCo sel co) = pprPrefixApp p (ppr sel) [pprParendCo co] +ppr_co p (SubCo co) = pprPrefixApp p (ptext (sLit "Sub")) [pprParendCo co] + +ppr_role :: Role -> SDoc +ppr_role r = underscore <> ppr r trans_co_list :: Coercion -> [Coercion] -> [Coercion] trans_co_list (TransCo co1 co2) cos = trans_co_list co1 (trans_co_list co2 cos) @@ -543,7 +668,7 @@ ppr_fun_co :: Prec -> Coercion -> SDoc ppr_fun_co p co = pprArrowChain p (split co) where split :: Coercion -> [SDoc] - split (TyConAppCo f [arg,res]) + split (TyConAppCo _ f [arg,res]) | f `hasKey` funTyConKey = ppr_co FunPrec arg : split res split co = [ppr_co TopPrec co] @@ -607,25 +732,20 @@ getCoVar_maybe :: Coercion -> Maybe CoVar getCoVar_maybe (CoVarCo cv) = Just cv getCoVar_maybe _ = Nothing --- | Attempts to tease a coercion apart into a type constructor and the application --- of a number of coercion arguments to that constructor -splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion]) -splitTyConAppCo_maybe (Refl ty) = (fmap . second . map) Refl (splitTyConApp_maybe ty) -splitTyConAppCo_maybe (TyConAppCo tc cos) = Just (tc, cos) -splitTyConAppCo_maybe _ = Nothing - +-- first result has role equal to input; second result is Nominal splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion) -- ^ Attempt to take a coercion application apart. splitAppCo_maybe (AppCo co1 co2) = Just (co1, co2) -splitAppCo_maybe (TyConAppCo tc cos) +splitAppCo_maybe (TyConAppCo r tc cos) | isDecomposableTyCon tc || cos `lengthExceeds` tyConArity tc , Just (cos', co') <- snocView cos - = Just (mkTyConAppCo tc cos', co') -- Never create unsaturated type family apps! + , Just co'' <- unSubCo_maybe co' + = Just (mkTyConAppCo r tc cos', co'') -- Never create unsaturated type family apps! -- Use mkTyConAppCo to preserve the invariant -- that identity coercions are always represented by Refl -splitAppCo_maybe (Refl ty) +splitAppCo_maybe (Refl r ty) | Just (ty1, ty2) <- splitAppTy_maybe ty - = Just (Refl ty1, Refl ty2) + = Just (Refl r ty1, Refl Nominal ty2) splitAppCo_maybe _ = Nothing splitForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion) @@ -638,22 +758,38 @@ splitForAllCo_maybe _ = Nothing coVarKind :: CoVar -> (Type,Type) coVarKind cv | Just (tc, [_kind,ty1,ty2]) <- splitTyConApp_maybe (varType cv) - = ASSERT (tc `hasKey` eqPrimTyConKey) + = ASSERT(tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey) (ty1,ty2) | otherwise = panic "coVarKind, non coercion variable" +coVarRole :: CoVar -> Role +coVarRole cv + | tc `hasKey` eqPrimTyConKey + = Nominal + | tc `hasKey` eqReprPrimTyConKey + = Representational + | otherwise + = pprPanic "coVarRole: unknown tycon" (ppr cv) + + where + tc = case tyConAppTyCon_maybe (varType cv) of + Just tc0 -> tc0 + Nothing -> pprPanic "coVarRole: not tyconapp" (ppr cv) + -- | Makes a coercion type from two types: the types whose equality -- is proven by the relevant 'Coercion' -mkCoercionType :: Type -> Type -> Type -mkCoercionType = mkPrimEqPred +mkCoercionType :: Role -> Type -> Type -> Type +mkCoercionType Nominal = mkPrimEqPred +mkCoercionType Representational = mkReprPrimEqPred +mkCoercionType Phantom = panic "mkCoercionType" isReflCo :: Coercion -> Bool -isReflCo (Refl {}) = True -isReflCo _ = False +isReflCo (Refl {}) = True +isReflCo _ = False isReflCo_maybe :: Coercion -> Maybe Type -isReflCo_maybe (Refl ty) = Just ty -isReflCo_maybe _ = Nothing +isReflCo_maybe (Refl _ ty) = Just ty +isReflCo_maybe _ = Nothing \end{code} %************************************************************************ @@ -666,32 +802,36 @@ isReflCo_maybe _ = Nothing mkCoVarCo :: CoVar -> Coercion -- cv :: s ~# t mkCoVarCo cv - | ty1 `eqType` ty2 = Refl ty1 + | ty1 `eqType` ty2 = Refl Nominal ty1 | otherwise = CoVarCo cv where (ty1, ty2) = ASSERT( isCoVar cv ) coVarKind cv -mkReflCo :: Type -> Coercion +mkReflCo :: Role -> Type -> Coercion mkReflCo = Refl -mkAxInstCo :: CoAxiom br -> Int -> [Type] -> Coercion +mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> Coercion -- mkAxInstCo can legitimately be called over-staturated; -- i.e. with more type arguments than the coercion requires -mkAxInstCo ax index tys - | arity == n_tys = AxiomInstCo ax_br index rtys +mkAxInstCo role ax index tys + | arity == n_tys = maybeSubCo2 role ax_role $ AxiomInstCo ax_br index rtys | otherwise = ASSERT( arity < n_tys ) + maybeSubCo2 role ax_role $ foldl AppCo (AxiomInstCo ax_br index (take arity rtys)) (drop arity rtys) where - n_tys = length tys - arity = coAxiomArity ax index - rtys = map Refl tys - ax_br = toBranchedAxiom ax + n_tys = length tys + ax_br = toBranchedAxiom ax + branch = coAxiomNthBranch ax_br index + arity = length $ coAxBranchTyVars branch + arg_roles = coAxBranchRoles branch + rtys = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys + ax_role = coAxiomRole ax -- to be used only with unbranched axioms -mkUnbranchedAxInstCo :: CoAxiom Unbranched -> [Type] -> Coercion -mkUnbranchedAxInstCo ax tys - = mkAxInstCo ax 0 tys +mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched -> [Type] -> Coercion +mkUnbranchedAxInstCo role ax tys + = mkAxInstCo role ax 0 tys mkAxInstLHS, mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> Type -- Instantiate the axiom with specified types, @@ -714,41 +854,57 @@ mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> Type mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0 -- | Apply a 'Coercion' to another 'Coercion'. +-- The second coercion must be Nominal, unless the first is Phantom. +-- If the first is Phantom, then the second can be either Phantom or Nominal. mkAppCo :: Coercion -> Coercion -> Coercion -mkAppCo (Refl ty1) (Refl ty2) = Refl (mkAppTy ty1 ty2) -mkAppCo (Refl (TyConApp tc tys)) co = TyConAppCo tc (map Refl tys ++ [co]) -mkAppCo (TyConAppCo tc cos) co = TyConAppCo tc (cos ++ [co]) -mkAppCo co1 co2 = AppCo co1 co2 +mkAppCo (Refl r ty1) (Refl _ ty2) + = Refl r (mkAppTy ty1 ty2) +mkAppCo (Refl r (TyConApp tc tys)) co2 + = TyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) + where + zip_roles (r1:_) [] = [applyRole r1 co2] + zip_roles (r1:rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys + zip_roles _ _ = panic "zip_roles" -- but the roles are infinite... +mkAppCo (TyConAppCo r tc cos) co + = case r of + Nominal -> TyConAppCo Nominal tc (cos ++ [co]) + Representational -> TyConAppCo Representational tc (cos ++ [co']) + where new_role = (tyConRolesX Representational tc) !! (length cos) + co' = applyRole new_role co + Phantom -> TyConAppCo Phantom tc (cos ++ [mkPhantomCo co]) + +mkAppCo co1 co2 = AppCo co1 co2 -- Note, mkAppCo is careful to maintain invariants regarding -- where Refl constructors appear; see the comments in the definition -- of Coercion and the Note [Refl invariant] in types/TypeRep.lhs. -- | Applies multiple 'Coercion's to another 'Coercion', from left to right. --- See also 'mkAppCo' +-- See also 'mkAppCo'. mkAppCos :: Coercion -> [Coercion] -> Coercion -mkAppCos co1 tys = foldl mkAppCo co1 tys +mkAppCos co1 cos = foldl mkAppCo co1 cos --- | Apply a type constructor to a list of coercions. -mkTyConAppCo :: TyCon -> [Coercion] -> Coercion -mkTyConAppCo tc cos +-- | Apply a type constructor to a list of coercions. It is the +-- caller's responsibility to get the roles correct on argument coercions. +mkTyConAppCo :: Role -> TyCon -> [Coercion] -> Coercion +mkTyConAppCo r tc cos -- Expand type synonyms | Just (tv_co_prs, rhs_ty, leftover_cos) <- tcExpandTyCon_maybe tc cos - = mkAppCos (liftCoSubst tv_co_prs rhs_ty) leftover_cos + = mkAppCos (liftCoSubst r tv_co_prs rhs_ty) leftover_cos | Just tys <- traverse isReflCo_maybe cos - = Refl (mkTyConApp tc tys) -- See Note [Refl invariant] + = Refl r (mkTyConApp tc tys) -- See Note [Refl invariant] - | otherwise = TyConAppCo tc cos + | otherwise = TyConAppCo r tc cos -- | Make a function 'Coercion' between two other 'Coercion's -mkFunCo :: Coercion -> Coercion -> Coercion -mkFunCo co1 co2 = mkTyConAppCo funTyCon [co1, co2] +mkFunCo :: Role -> Coercion -> Coercion -> Coercion +mkFunCo r co1 co2 = mkTyConAppCo r funTyCon [co1, co2] -- | Make a 'Coercion' which binds a variable within an inner 'Coercion' mkForAllCo :: Var -> Coercion -> Coercion -- note that a TyVar should be used here, not a CoVar (nor a TcTyVar) -mkForAllCo tv (Refl ty) = ASSERT( isTyVar tv ) Refl (mkForAllTy tv ty) -mkForAllCo tv co = ASSERT ( isTyVar tv ) ForAllCo tv co +mkForAllCo tv (Refl r ty) = ASSERT( isTyVar tv ) Refl r (mkForAllTy tv ty) +mkForAllCo tv co = ASSERT( isTyVar tv ) ForAllCo tv co ------------------------------- @@ -759,28 +915,40 @@ mkSymCo :: Coercion -> Coercion -- Do a few simple optimizations, but don't bother pushing occurrences -- of symmetry to the leaves; the optimizer will take care of that. -mkSymCo co@(Refl {}) = co -mkSymCo (UnsafeCo ty1 ty2) = UnsafeCo ty2 ty1 +mkSymCo co@(Refl {}) = co +mkSymCo (UnivCo r ty1 ty2) = UnivCo r ty2 ty1 mkSymCo (SymCo co) = co mkSymCo co = SymCo co -- | Create a new 'Coercion' by composing the two given 'Coercion's transitively. mkTransCo :: Coercion -> Coercion -> Coercion -mkTransCo (Refl _) co = co -mkTransCo co (Refl _) = co -mkTransCo co1 co2 = TransCo co1 co2 +mkTransCo (Refl {}) co = co +mkTransCo co (Refl {}) = co +mkTransCo co1 co2 = TransCo co1 co2 + +-- the Role is the desired one. It is the caller's responsibility to make +-- sure this request is reasonable +mkNthCoRole :: Role -> Int -> Coercion -> Coercion +mkNthCoRole role n co + = maybeSubCo2 role nth_role $ nth_co + where + nth_co = mkNthCo n co + nth_role = coercionRole nth_co mkNthCo :: Int -> Coercion -> Coercion -mkNthCo n (Refl ty) = ASSERT( ok_tc_app ty n ) - Refl (tyConAppArgN n ty) +mkNthCo n (Refl r ty) = ASSERT( ok_tc_app ty n ) + Refl r' (tyConAppArgN n ty) + where tc = tyConAppTyCon ty + r' = nthRole r tc n mkNthCo n co = ASSERT( ok_tc_app _ty1 n && ok_tc_app _ty2 n ) NthCo n co where Pair _ty1 _ty2 = coercionKind co + mkLRCo :: LeftOrRight -> Coercion -> Coercion -mkLRCo lr (Refl ty) = Refl (pickLR lr (splitAppTy ty)) -mkLRCo lr co = LRCo lr co +mkLRCo lr (Refl eq ty) = Refl eq (pickLR lr (splitAppTy ty)) +mkLRCo lr co = LRCo lr co ok_tc_app :: Type -> Int -> Bool ok_tc_app ty n = case splitTyConApp_maybe ty of @@ -797,15 +965,99 @@ mkInstCo co ty = InstCo co ty -- to implement the @unsafeCoerce#@ primitive. Optimise by pushing -- down through type constructors. mkUnsafeCo :: Type -> Type -> Coercion -mkUnsafeCo ty1 ty2 | ty1 `eqType` ty2 = Refl ty1 -mkUnsafeCo (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2 - = mkTyConAppCo tc1 (zipWith mkUnsafeCo tys1 tys2) - -mkUnsafeCo (FunTy a1 r1) (FunTy a2 r2) - = mkFunCo (mkUnsafeCo a1 a2) (mkUnsafeCo r1 r2) - -mkUnsafeCo ty1 ty2 = UnsafeCo ty1 ty2 +mkUnsafeCo = mkUnivCo Representational + +mkUnivCo :: Role -> Type -> Type -> Coercion +mkUnivCo role ty1 ty2 + | ty1 `eqType` ty2 = Refl role ty1 + | otherwise = UnivCo role ty1 ty2 + +-- input coercion is Nominal +mkSubCo :: Coercion -> Coercion +mkSubCo (Refl Nominal ty) = Refl Representational ty +mkSubCo (TyConAppCo Nominal tc cos) + = TyConAppCo Representational tc (applyRoles tc cos) +mkSubCo (UnivCo Nominal ty1 ty2) = UnivCo Representational ty1 ty2 +mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co ) + SubCo co + +-- takes a Nominal coercion and possibly casts it into a Representational one +maybeSubCo :: Role -> Coercion -> Coercion +maybeSubCo Nominal = id +maybeSubCo Representational = mkSubCo +maybeSubCo Phantom = pprPanic "maybeSubCo Phantom" . ppr + +maybeSubCo2_maybe :: Role -- desired role + -> Role -- current role + -> Coercion -> Maybe Coercion +maybeSubCo2_maybe Representational Nominal = Just . mkSubCo +maybeSubCo2_maybe Nominal Representational = const Nothing +maybeSubCo2_maybe Phantom Phantom = Just +maybeSubCo2_maybe Phantom _ = Just . mkPhantomCo +maybeSubCo2_maybe _ Phantom = const Nothing +maybeSubCo2_maybe _ _ = Just + +maybeSubCo2 :: Role -- desired role + -> Role -- current role + -> Coercion -> Coercion +maybeSubCo2 r1 r2 co + = case maybeSubCo2_maybe r1 r2 co of + Just co' -> co' + Nothing -> pprPanic "maybeSubCo2" (ppr co) + +-- if co is Nominal, returns it; otherwise, unwraps a SubCo; otherwise, fails +unSubCo_maybe :: Coercion -> Maybe Coercion +unSubCo_maybe (SubCo co) = Just co +unSubCo_maybe (Refl _ ty) = Just $ Refl Nominal ty +unSubCo_maybe (TyConAppCo Representational tc cos) + = do { cos' <- mapM unSubCo_maybe cos + ; return $ TyConAppCo Nominal tc cos' } +unSubCo_maybe (UnivCo Representational ty1 ty2) = Just $ UnivCo Nominal ty1 ty2 + -- We do *not* promote UnivCo Phantom, as that's unsafe. + -- UnivCo Nominal is no more unsafe than UnivCo Representational +unSubCo_maybe co + | Nominal <- coercionRole co = Just co +unSubCo_maybe _ = Nothing + +-- takes any coercion and turns it into a Phantom coercion +mkPhantomCo :: Coercion -> Coercion +mkPhantomCo co + | Just ty <- isReflCo_maybe co = Refl Phantom ty + | Pair ty1 ty2 <- coercionKind co = UnivCo Phantom ty1 ty2 + -- don't optimise here... wait for OptCoercion + +-- All input coercions are assumed to be Nominal, +-- or, if Role is Phantom, the Coercion can be Phantom, too. +applyRole :: Role -> Coercion -> Coercion +applyRole Nominal = id +applyRole Representational = mkSubCo +applyRole Phantom = mkPhantomCo + +-- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational +applyRoles :: TyCon -> [Coercion] -> [Coercion] +applyRoles tc cos + = zipWith applyRole (tyConRolesX Representational tc) cos + +-- the Role parameter is the Role of the TyConAppCo +-- defined here because this is intimiately concerned with the implementation +-- of TyConAppCo +tyConRolesX :: Role -> TyCon -> [Role] +tyConRolesX Representational tc = tyConRoles tc ++ repeat Nominal +tyConRolesX role _ = repeat role + +nthRole :: Role -> TyCon -> Int -> Role +nthRole Nominal _ _ = Nominal +nthRole Phantom _ _ = Phantom +nthRole Representational tc n + = (tyConRolesX Representational tc) !! n + +-- is one role "less" than another? +ltRole :: Role -> Role -> Bool +ltRole Phantom _ = False +ltRole Representational Phantom = True +ltRole Representational _ = False +ltRole Nominal Nominal = False +ltRole Nominal _ = True -- See note [Newtype coercions] in TyCon @@ -814,25 +1066,29 @@ mkUnsafeCo ty1 ty2 = UnsafeCo ty1 ty2 -- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and -- the type the appropriate right hand side of the @newtype@, with -- the free variables a subset of those 'TyVar's. -mkNewTypeCo :: Name -> TyCon -> [TyVar] -> Type -> CoAxiom Unbranched -mkNewTypeCo name tycon tvs rhs_ty +mkNewTypeCo :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched +mkNewTypeCo name tycon tvs roles rhs_ty = CoAxiom { co_ax_unique = nameUnique name , co_ax_name = name , co_ax_implicit = True -- See Note [Implicit axioms] in TyCon + , co_ax_role = Representational , co_ax_tc = tycon , co_ax_branches = FirstBranch branch } - where branch = CoAxBranch { cab_loc = getSrcSpan name - , cab_tvs = tvs - , cab_lhs = mkTyVarTys tvs - , cab_rhs = rhs_ty } + where branch = CoAxBranch { cab_loc = getSrcSpan name + , cab_tvs = tvs + , cab_lhs = mkTyVarTys tvs + , cab_roles = roles + , cab_rhs = rhs_ty + , cab_incomps = [] } -mkPiCos :: [Var] -> Coercion -> Coercion -mkPiCos vs co = foldr mkPiCo co vs +mkPiCos :: Role -> [Var] -> Coercion -> Coercion +mkPiCos r vs co = foldr (mkPiCo r) co vs -mkPiCo :: Var -> Coercion -> Coercion -mkPiCo v co | isTyVar v = mkForAllCo v co - | otherwise = mkFunCo (mkReflCo (varType v)) co +mkPiCo :: Role -> Var -> Coercion -> Coercion +mkPiCo r v co | isTyVar v = mkForAllCo v co + | otherwise = mkFunCo r (mkReflCo r (varType v)) co +-- The first coercion *must* be Nominal. mkCoCast :: Coercion -> Coercion -> Coercion -- (mkCoCast (c :: s1 ~# t1) (g :: (s1 ~# t1) ~# (s2 ~# t2) mkCoCast c g @@ -861,7 +1117,7 @@ instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion) instNewTyCon_maybe tc tys | Just (tvs, ty, co_tc) <- unwrapNewTyCon_maybe tc -- Check for newtype , tys `lengthIs` tyConArity tc -- Check saturated - = Just (substTyWith tvs tys ty, mkUnbranchedAxInstCo co_tc tys) + = Just (substTyWith tvs tys ty, mkUnbranchedAxInstCo Representational co_tc tys) | otherwise = Nothing @@ -884,25 +1140,21 @@ splitNewTypeRepCo_maybe _ topNormaliseNewType :: Type -> Maybe (Type, Coercion) topNormaliseNewType ty - = case topNormaliseNewTypeX emptyNameSet ty of + = case topNormaliseNewTypeX initRecTc ty of Just (_, co, ty) -> Just (ty, co) Nothing -> Nothing -topNormaliseNewTypeX :: NameSet -> Type -> Maybe (NameSet, Coercion, Type) +topNormaliseNewTypeX :: RecTcChecker -> Type -> Maybe (RecTcChecker, Coercion, Type) topNormaliseNewTypeX rec_nts ty | Just ty' <- coreView ty -- Expand predicates and synonyms = topNormaliseNewTypeX rec_nts ty' topNormaliseNewTypeX rec_nts (TyConApp tc tys) - | Just (rep_ty, co) <- instNewTyCon_maybe tc tys - , not (tc_name `elemNameSet` rec_nts) -- See Note [Expanding newtypes] in Type + | Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] in TyCon + , Just (rep_ty, co) <- instNewTyCon_maybe tc tys = case topNormaliseNewTypeX rec_nts' rep_ty of Nothing -> Just (rec_nts', co, rep_ty) Just (rec_nts', co', rep_ty') -> Just (rec_nts', co `mkTransCo` co', rep_ty') - where - tc_name = tyConName tc - rec_nts' | isRecursiveTyCon tc = addOneToNameSet rec_nts tc_name - | otherwise = rec_nts topNormaliseNewTypeX _ _ = Nothing \end{code} @@ -921,9 +1173,9 @@ coreEqCoercion co1 co2 = coreEqCoercion2 rn_env co1 co2 where rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2)) coreEqCoercion2 :: RnEnv2 -> Coercion -> Coercion -> Bool -coreEqCoercion2 env (Refl ty1) (Refl ty2) = eqTypeX env ty1 ty2 -coreEqCoercion2 env (TyConAppCo tc1 cos1) (TyConAppCo tc2 cos2) - = tc1 == tc2 && all2 (coreEqCoercion2 env) cos1 cos2 +coreEqCoercion2 env (Refl eq1 ty1) (Refl eq2 ty2) = eq1 == eq2 && eqTypeX env ty1 ty2 +coreEqCoercion2 env (TyConAppCo eq1 tc1 cos1) (TyConAppCo eq2 tc2 cos2) + = eq1 == eq2 && tc1 == tc2 && all2 (coreEqCoercion2 env) cos1 cos2 coreEqCoercion2 env (AppCo co11 co12) (AppCo co21 co22) = coreEqCoercion2 env co11 co21 && coreEqCoercion2 env co12 co22 @@ -939,8 +1191,8 @@ coreEqCoercion2 env (AxiomInstCo con1 ind1 cos1) (AxiomInstCo con2 ind2 cos2) && ind1 == ind2 && all2 (coreEqCoercion2 env) cos1 cos2 -coreEqCoercion2 env (UnsafeCo ty11 ty12) (UnsafeCo ty21 ty22) - = eqTypeX env ty11 ty21 && eqTypeX env ty12 ty22 +coreEqCoercion2 env (UnivCo r1 ty11 ty12) (UnivCo r2 ty21 ty22) + = r1 == r2 && eqTypeX env ty11 ty21 && eqTypeX env ty12 ty22 coreEqCoercion2 env (SymCo co1) (SymCo co2) = coreEqCoercion2 env co1 co2 @@ -956,6 +1208,9 @@ coreEqCoercion2 env (LRCo d1 co1) (LRCo d2 co2) coreEqCoercion2 env (InstCo co1 ty1) (InstCo co2 ty2) = coreEqCoercion2 env co1 co2 && eqTypeX env ty1 ty2 +coreEqCoercion2 env (SubCo co1) (SubCo co2) + = coreEqCoercion2 env co1 co2 + coreEqCoercion2 _ _ _ = False \end{code} @@ -1007,6 +1262,12 @@ extendTvSubst :: CvSubst -> TyVar -> Type -> CvSubst extendTvSubst (CvSubst in_scope tenv cenv) tv ty = CvSubst in_scope (extendVarEnv tenv tv ty) cenv +extendTvSubstAndInScope :: CvSubst -> TyVar -> Type -> CvSubst +extendTvSubstAndInScope (CvSubst in_scope tenv cenv) tv ty + = CvSubst (in_scope `extendInScopeSetSet` tyVarsOfType ty) + (extendVarEnv tenv tv ty) + cenv + extendCvSubstAndInScope :: CvSubst -> CoVar -> Coercion -> CvSubst -- Also extends the in-scope set extendCvSubstAndInScope (CvSubst in_scope tenv cenv) cv co @@ -1080,25 +1341,27 @@ subst_co subst co go_ty = Coercion.substTy subst go :: Coercion -> Coercion - go (Refl ty) = Refl $! go_ty ty - go (TyConAppCo tc cos) = let args = map go cos - in args `seqList` TyConAppCo tc args + go (Refl eq ty) = Refl eq $! go_ty ty + go (TyConAppCo eq tc cos) = let args = map go cos + in args `seqList` TyConAppCo eq tc args go (AppCo co1 co2) = mkAppCo (go co1) $! go co2 go (ForAllCo tv co) = case substTyVarBndr subst tv of (subst', tv') -> ForAllCo tv' $! subst_co subst' co go (CoVarCo cv) = substCoVar subst cv go (AxiomInstCo con ind cos) = AxiomInstCo con ind $! map go cos - go (UnsafeCo ty1 ty2) = (UnsafeCo $! go_ty ty1) $! go_ty ty2 + go (UnivCo r ty1 ty2) = (UnivCo r $! go_ty ty1) $! go_ty ty2 go (SymCo co) = mkSymCo (go co) go (TransCo co1 co2) = mkTransCo (go co1) (go co2) go (NthCo d co) = mkNthCo d (go co) go (LRCo lr co) = mkLRCo lr (go co) go (InstCo co ty) = mkInstCo (go co) $! go_ty ty + go (SubCo co) = mkSubCo (go co) substCoVar :: CvSubst -> CoVar -> Coercion substCoVar (CvSubst in_scope _ cenv) cv - | Just co <- lookupVarEnv cenv cv = co + | Just co <- lookupVarEnv cenv cv = ASSERT2( coercionRole co == Nominal, ppr co ) + co | Just cv1 <- lookupInScope in_scope cv = ASSERT( isCoVar cv1 ) CoVarCo cv1 | otherwise = WARN( True, ptext (sLit "substCoVar not in scope") <+> ppr cv $$ ppr in_scope) ASSERT( isCoVar cv ) CoVarCo cv @@ -1120,57 +1383,177 @@ lookupCoVar (CvSubst _ _ cenv) v = lookupVarEnv cenv v %* * %************************************************************************ +Note [Lifting coercions over types: liftCoSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The KPUSH rule deals with this situation + data T a = MkK (a -> Maybe a) + g :: T t1 ~ K t2 + x :: t1 -> Maybe t1 + + case (K @t1 x) |> g of + K (y:t2 -> Maybe t2) -> rhs + +We want to push the coercion inside the constructor application. +So we do this + + g' :: t1~t2 = Nth 0 g + + case K @t2 (x |> g' -> Maybe g') of + K (y:t2 -> Maybe t2) -> rhs + +The crucial operation is that we + * take the type of K's argument: a -> Maybe a + * and substitute g' for a +thus giving *coercion*. This is what liftCoSubst does. + +Note [Substituting kinds in liftCoSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to take care with kind polymorphism. Suppose + K :: forall k (a:k). (forall b:k. a -> b) -> T k a + +Now given (K @kk1 @ty1 v) |> g) where + g :: T kk1 ty1 ~ T kk2 ty2 +we want to compute + (forall b:k a->b) [ Nth 0 g/k, Nth 1 g/a ] +Notice that we MUST substitute for 'k'; this happens in +liftCoSubstTyVarBndr. But what should we substitute? +We need to take b's kind 'k' and return a Kind, not a Coercion! + +Happily we can do this because we know that all kind coercions +((Nth 0 g) in this case) are Refl. So we need a special purpose + subst_kind: LiftCoSubst -> Kind -> Kind +that expects a Refl coercion (or something equivalent to Refl) +when it looks up a kind variable. + \begin{code} +-- ---------------------------------------------------- +-- See Note [Lifting coercions over types: liftCoSubst] +-- ---------------------------------------------------- + data LiftCoSubst = LCS InScopeSet LiftCoEnv type LiftCoEnv = VarEnv Coercion -- Maps *type variables* to *coercions* -- That's the whole point of this function! -liftCoSubstWith :: [TyVar] -> [Coercion] -> Type -> Coercion -liftCoSubstWith tvs cos ty - = liftCoSubst (zipEqual "liftCoSubstWith" tvs cos) ty +liftCoSubstWith :: Role -> [TyVar] -> [Coercion] -> Type -> Coercion +liftCoSubstWith r tvs cos ty + = liftCoSubst r (zipEqual "liftCoSubstWith" tvs cos) ty -liftCoSubst :: [(TyVar,Coercion)] -> Type -> Coercion -liftCoSubst prs ty - | null prs = Refl ty +liftCoSubst :: Role -> [(TyVar,Coercion)] -> Type -> Coercion +liftCoSubst r prs ty + | null prs = Refl r ty | otherwise = ty_co_subst (LCS (mkInScopeSet (tyCoVarsOfCos (map snd prs))) - (mkVarEnv prs)) ty + (mkVarEnv prs)) r ty -- | The \"lifting\" operation which substitutes coercions for type -- variables in a type to produce a coercion. -- -- For the inverse operation, see 'liftCoMatch' -ty_co_subst :: LiftCoSubst -> Type -> Coercion -ty_co_subst subst ty - = go ty + +-- The Role parameter is the _desired_ role +ty_co_subst :: LiftCoSubst -> Role -> Type -> Coercion +ty_co_subst subst role ty + = go role ty where - go (TyVarTy tv) = liftCoSubstTyVar subst tv `orElse` Refl (TyVarTy tv) + go Phantom ty = lift_phantom ty + go role (TyVarTy tv) = liftCoSubstTyVar subst role tv + `orElse` Refl role (TyVarTy tv) -- A type variable from a non-cloned forall -- won't be in the substitution - go (AppTy ty1 ty2) = mkAppCo (go ty1) (go ty2) - go (TyConApp tc tys) = mkTyConAppCo tc (map go tys) + go role (AppTy ty1 ty2) = mkAppCo (go role ty1) (go Nominal ty2) + go role (TyConApp tc tys) = mkTyConAppCo role tc + (zipWith go (tyConRolesX role tc) tys) -- IA0_NOTE: Do we need to do anything -- about kind instantiations? I don't think -- so. see Note [Kind coercions] - go (FunTy ty1 ty2) = mkFunCo (go ty1) (go ty2) - go (ForAllTy v ty) = mkForAllCo v' $! (ty_co_subst subst' ty) + go role (FunTy ty1 ty2) = mkFunCo role (go role ty1) (go role ty2) + go role (ForAllTy v ty) = mkForAllCo v' $! (ty_co_subst subst' role ty) where (subst', v') = liftCoSubstTyVarBndr subst v - go ty@(LitTy {}) = mkReflCo ty + go role ty@(LitTy {}) = ASSERT( role == Nominal ) + mkReflCo role ty + + lift_phantom ty = mkUnivCo Phantom (liftCoSubstLeft subst ty) + (liftCoSubstRight subst ty) -liftCoSubstTyVar :: LiftCoSubst -> TyVar -> Maybe Coercion -liftCoSubstTyVar (LCS _ cenv) tv = lookupVarEnv cenv tv +\end{code} + +Note [liftCoSubstTyVar] +~~~~~~~~~~~~~~~~~~~~~~~ +This function can fail (i.e., return Nothing) for two separate reasons: + 1) The variable is not in the substutition + 2) The coercion found is of too low a role + +liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and +also in matchAxiom in OptCoercion. From liftCoSubst, the so-called lifting +lemma guarantees that the roles work out. If we fail for reason 2) in this +case, we really should panic -- something is deeply wrong. But, in matchAxiom, +failing for reason 2) is fine. matchAxiom is trying to find a set of coercions +that match, but it may fail, and this is healthy behavior. Bottom line: if +you find that liftCoSubst is doing weird things (like leaving out-of-scope +variables lying around), disable coercion optimization (bypassing matchAxiom) +and use maybeSubCo2 instead of maybeSubCo2_maybe. The panic will then happen, +and you may learn something useful. + +\begin{code} + +liftCoSubstTyVar :: LiftCoSubst -> Role -> TyVar -> Maybe Coercion +liftCoSubstTyVar (LCS _ cenv) r tv + = do { co <- lookupVarEnv cenv tv + ; let co_role = coercionRole co -- could theoretically take this as + -- a parameter, but painful + ; maybeSubCo2_maybe r co_role co } -- see Note [liftCoSubstTyVar] liftCoSubstTyVarBndr :: LiftCoSubst -> TyVar -> (LiftCoSubst, TyVar) -liftCoSubstTyVarBndr (LCS in_scope cenv) old_var +liftCoSubstTyVarBndr subst@(LCS in_scope cenv) old_var = (LCS (in_scope `extendInScopeSet` new_var) new_cenv, new_var) where new_cenv | no_change = delVarEnv cenv old_var - | otherwise = extendVarEnv cenv old_var (Refl (TyVarTy new_var)) + | otherwise = extendVarEnv cenv old_var (Refl Nominal (TyVarTy new_var)) + + no_change = no_kind_change && (new_var == old_var) + + new_var1 = uniqAway in_scope old_var - no_change = new_var == old_var - new_var = uniqAway in_scope old_var + old_ki = tyVarKind old_var + no_kind_change = isEmptyVarSet (tyVarsOfType old_ki) + new_var | no_kind_change = new_var1 + | otherwise = setTyVarKind new_var1 (subst_kind subst old_ki) + +-- map every variable to the type on the *left* of its mapped coercion +liftCoSubstLeft :: LiftCoSubst -> Type -> Type +liftCoSubstLeft (LCS in_scope cenv) ty + = Type.substTy (mkTvSubst in_scope (mapVarEnv (pFst . coercionKind) cenv)) ty + +-- same, but to the type on the right +liftCoSubstRight :: LiftCoSubst -> Type -> Type +liftCoSubstRight (LCS in_scope cenv) ty + = Type.substTy (mkTvSubst in_scope (mapVarEnv (pSnd . coercionKind) cenv)) ty + +subst_kind :: LiftCoSubst -> Kind -> Kind +-- See Note [Substituting kinds in liftCoSubst] +subst_kind subst@(LCS _ cenv) kind + = go kind + where + go (LitTy n) = n `seq` LitTy n + go (TyVarTy kv) = subst_kv kv + go (TyConApp tc tys) = let args = map go tys + in args `seqList` TyConApp tc args + + go (FunTy arg res) = (FunTy $! (go arg)) $! (go res) + go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) + go (ForAllTy tv ty) = case liftCoSubstTyVarBndr subst tv of + (subst', tv') -> + ForAllTy tv' $! (subst_kind subst' ty) + + subst_kv kv + | Just co <- lookupVarEnv cenv kv + , let co_kind = coercionKind co + = ASSERT2( pFst co_kind `eqKind` pSnd co_kind, ppr kv $$ ppr co ) + pFst co_kind + | otherwise + = TyVarTy kv \end{code} \begin{code} @@ -1223,10 +1606,10 @@ ty_co_match menv subst (AppTy ty1 ty2) co = do { subst' <- ty_co_match menv subst ty1 co1 ; ty_co_match menv subst' ty2 co2 } -ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo tc2 cos) +ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) | tc1 == tc2 = ty_co_matches menv subst tys cos -ty_co_match menv subst (FunTy ty1 ty2) (TyConAppCo tc cos) +ty_co_match menv subst (FunTy ty1 ty2) (TyConAppCo _ tc cos) | tc == funTyCon = ty_co_matches menv subst [ty1,ty2] cos ty_co_match menv subst (ForAllTy tv1 ty) (ForAllCo tv2 co) @@ -1242,11 +1625,14 @@ ty_co_matches :: MatchEnv -> LiftCoEnv -> [Type] -> [Coercion] -> Maybe LiftCoEn ty_co_matches menv = matchList (ty_co_match menv) pushRefl :: Coercion -> Maybe Coercion -pushRefl (Refl (AppTy ty1 ty2)) = Just (AppCo (Refl ty1) (Refl ty2)) -pushRefl (Refl (FunTy ty1 ty2)) = Just (TyConAppCo funTyCon [Refl ty1, Refl ty2]) -pushRefl (Refl (TyConApp tc tys)) = Just (TyConAppCo tc (map Refl tys)) -pushRefl (Refl (ForAllTy tv ty)) = Just (ForAllCo tv (Refl ty)) -pushRefl _ = Nothing +pushRefl (Refl Nominal (AppTy ty1 ty2)) + = Just (AppCo (Refl Nominal ty1) (Refl Nominal ty2)) +pushRefl (Refl r (FunTy ty1 ty2)) + = Just (TyConAppCo r funTyCon [Refl r ty1, Refl r ty2]) +pushRefl (Refl r (TyConApp tc tys)) + = Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys)) +pushRefl (Refl r (ForAllTy tv ty)) = Just (ForAllCo tv (Refl r ty)) +pushRefl _ = Nothing \end{code} %************************************************************************ @@ -1257,18 +1643,19 @@ pushRefl _ = Nothing \begin{code} seqCo :: Coercion -> () -seqCo (Refl ty) = seqType ty -seqCo (TyConAppCo tc cos) = tc `seq` seqCos cos -seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 -seqCo (ForAllCo tv co) = tv `seq` seqCo co -seqCo (CoVarCo cv) = cv `seq` () +seqCo (Refl eq ty) = eq `seq` seqType ty +seqCo (TyConAppCo eq tc cos) = eq `seq` tc `seq` seqCos cos +seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (ForAllCo tv co) = tv `seq` seqCo co +seqCo (CoVarCo cv) = cv `seq` () seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos -seqCo (UnsafeCo ty1 ty2) = seqType ty1 `seq` seqType ty2 -seqCo (SymCo co) = seqCo co -seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 -seqCo (NthCo _ co) = seqCo co -seqCo (LRCo _ co) = seqCo co -seqCo (InstCo co ty) = seqCo co `seq` seqType ty +seqCo (UnivCo r ty1 ty2) = r `seq` seqType ty1 `seq` seqType ty2 +seqCo (SymCo co) = seqCo co +seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (NthCo _ co) = seqCo co +seqCo (LRCo _ co) = seqCo co +seqCo (InstCo co ty) = seqCo co `seq` seqType ty +seqCo (SubCo co) = seqCo co seqCos :: [Coercion] -> () seqCos [] = () @@ -1285,7 +1672,7 @@ seqCos (co:cos) = seqCo co `seq` seqCos cos \begin{code} coercionType :: Coercion -> Type coercionType co = case coercionKind co of - Pair ty1 ty2 -> mkCoercionType ty1 ty2 + Pair ty1 ty2 -> mkCoercionType (coercionRole co) ty1 ty2 ------------------ -- | If it is the case that @@ -1297,11 +1684,11 @@ coercionType co = case coercionKind co of coercionKind :: Coercion -> Pair Type coercionKind co = go co where - go (Refl ty) = Pair ty ty - go (TyConAppCo tc cos) = mkTyConApp tc <$> (sequenceA $ map go cos) - go (AppCo co1 co2) = mkAppTy <$> go co1 <*> go co2 - go (ForAllCo tv co) = mkForAllTy tv <$> go co - go (CoVarCo cv) = toPair $ coVarKind cv + go (Refl _ ty) = Pair ty ty + go (TyConAppCo _ tc cos) = mkTyConApp tc <$> (sequenceA $ map go cos) + go (AppCo co1 co2) = mkAppTy <$> go co1 <*> go co2 + go (ForAllCo tv co) = mkForAllTy tv <$> go co + go (CoVarCo cv) = toPair $ coVarKind cv go (AxiomInstCo ax ind cos) | CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- coAxiomNthBranch ax ind , Pair tys1 tys2 <- sequenceA (map go cos) @@ -1309,12 +1696,13 @@ coercionKind co = go co -- exactly saturate the axiom branch Pair (substTyWith tvs tys1 (mkTyConApp (coAxiomTyCon ax) lhs)) (substTyWith tvs tys2 rhs) - go (UnsafeCo ty1 ty2) = Pair ty1 ty2 - go (SymCo co) = swap $ go co - go (TransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2) - go (NthCo d co) = tyConAppArgN d <$> go co - go (LRCo lr co) = (pickLR lr . splitAppTy) <$> go co - go (InstCo aco ty) = go_app aco [ty] + go (UnivCo _ ty1 ty2) = Pair ty1 ty2 + go (SymCo co) = swap $ go co + go (TransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2) + go (NthCo d co) = tyConAppArgN d <$> go co + go (LRCo lr co) = (pickLR lr . splitAppTy) <$> go co + go (InstCo aco ty) = go_app aco [ty] + go (SubCo co) = go co go_app :: Coercion -> [Type] -> Pair Type -- Collect up all the arguments and apply all at once @@ -1325,6 +1713,25 @@ coercionKind co = go co -- | Apply 'coercionKind' to multiple 'Coercion's coercionKinds :: [Coercion] -> Pair [Type] coercionKinds tys = sequenceA $ map coercionKind tys + +coercionRole :: Coercion -> Role +coercionRole = go + where + go (Refl r _) = r + go (TyConAppCo r _ _) = r + go (AppCo co _) = go co + go (ForAllCo _ co) = go co + go (CoVarCo cv) = coVarRole cv + go (AxiomInstCo ax _ _) = coAxiomRole ax + go (UnivCo r _ _) = r + go (SymCo co) = go co + go (TransCo co1 _) = go co1 -- same as go co2 + go (NthCo n co) = let Pair ty1 _ = coercionKind co + (tc, _) = splitTyConApp ty1 + in nthRole (coercionRole co) tc n + go (LRCo _ _) = Nominal + go (InstCo co _) = go co + go (SubCo _) = Representational \end{code} Note [Nested InstCos] diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index 4e9b27e6b9..b6fdb35dc7 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -5,59 +5,64 @@ FamInstEnv: Type checked family instance declarations \begin{code} -module FamInstEnv ( - Branched, Unbranched, - FamInst(..), FamFlavor(..), FamInstBranch(..), +{-# LANGUAGE GADTs #-} + +module FamInstEnv ( + FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, + famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, + pprFamInst, pprFamInstHdr, pprFamInsts, + mkImportedFamInst, - famInstAxiom, famInstBranchRoughMatch, - famInstsRepTyCons, famInstNthBranch, famInstSingleBranch, - famInstBranchLHS, famInstBranches, - toBranchedFamInst, toUnbranchedFamInst, - famInstTyCon, famInstRepTyCon_maybe, dataFamInstRepTyCon, - pprFamInst, pprFamInsts, - pprFamFlavor, - mkImportedFamInst, + FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, + extendFamInstEnv, deleteFromFamInstEnv, extendFamInstEnvList, + identicalFamInst, famInstEnvElts, familyInstances, orphNamesOfFamInst, - FamInstEnv, FamInstEnvs, - emptyFamInstEnvs, emptyFamInstEnv, famInstEnvElts, familyInstances, - extendFamInstEnvList, extendFamInstEnv, deleteFromFamInstEnv, - identicalFamInst, orphNamesOfFamInst, + -- * CoAxioms + mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom, + computeAxiomIncomps, FamInstMatch(..), - lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvConflicts', - - isDominatedBy, + lookupFamInstEnv, lookupFamInstEnvConflicts, + isDominatedBy, + -- Normalisation - topNormaliseType, normaliseType, normaliseTcApp + chooseBranch, topNormaliseType, normaliseType, normaliseTcApp, + + -- Flattening + flattenTys ) where #include "HsVersions.h" -import TcType ( orphNamesOfTypes ) import InstEnv import Unify import Type -import Coercion hiding ( substTy ) +import TcType ( orphNamesOfTypes ) import TypeRep import TyCon +import Coercion import CoAxiom import VarSet import VarEnv import Name -import NameSet import UniqFM import Outputable import Maybes +import TrieMap +import Unique import Util +import Var +import Pair +import SrcLoc +import NameSet import FastString \end{code} - %************************************************************************ %* * - Type checked family instance heads + Type checked family instance heads %* * %************************************************************************ @@ -69,76 +74,40 @@ Note [FamInsts and CoAxioms] * A CoAxiom is a System-FC thing: it can relate any two types * A FamInst is a Haskell source-language thing, corresponding - to a type/data family instance declaration. + to a type/data family instance declaration. - The FamInst contains a CoAxiom, which is the evidence for the instance - - The LHSs of the CoAxiom branches are always of form - F ty1 .. tyn where F is a type family - -* A FamInstBranch corresponds to a CoAxBranch -- it represents - one alternative in a family instance group. We could theoretically - not have FamInstBranches and just use the CoAxBranches within - the CoAxiom stored in the FamInst, but for one problem: we want to - cache the "rough match" top-level tycon names for quick matching. - This data is not stored in a CoAxBranch, so we use FamInstBranches - instead. - -Note [fi_group field] -~~~~~~~~~~~~~~~~~~~~~ -A FamInst stores whether or not it was declared with "type instance where" -for two reasons: - 1. for accurate pretty-printing; and - 2. because confluent overlap is disallowed between branches - declared in groups. -Note that this "group-ness" is properly associated with the FamInst, -which thinks about overlap, and not in the CoAxiom, which blindly -assumes that it is part of a consistent axiom set. - -A "group" with fi_group=True can have just one element, however. - -Note [Why we need fib_rhs] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -It may at first seem unnecessary to store the right-hand side of an equation -in a FamInstBranch. After all, FamInstBranches are used only for matching a -family application; the underlying CoAxiom is used to perform the actual -simplification. - -However, we do need to know the rhs field during conflict checking to support -confluent overlap. When two unbranched instances have overlapping left-hand -sides, we check if the right-hand sides are coincident in the region of overlap. -This check requires fib_rhs. See lookupFamInstEnvConflicts. + - The LHS of the CoAxiom is always of form F ty1 .. tyn + where F is a type family \begin{code} -data FamInst br -- See Note [FamInsts and CoAxioms], Note [Branched axioms] in CoAxiom - = FamInst { fi_axiom :: CoAxiom br -- The new coercion axiom introduced - -- by this family instance - , fi_flavor :: FamFlavor - , fi_group :: Bool -- True <=> declared with "type instance where" - -- See Note [fi_group field] - - -- Everything below here is a redundant, - -- cached version of the two things above, - -- except that the TyVars are freshened in the FamInstBranches - , fi_branches :: BranchList FamInstBranch br - -- Haskell-source-language view of - -- a CoAxBranch - , fi_fam :: Name -- Family name - -- INVARIANT: fi_fam = name of fi_axiom.co_ax_tc - } - -data FamInstBranch - = FamInstBranch - { fib_tvs :: [TyVar] -- Bound type variables +data FamInst -- See Note [FamInsts and CoAxioms] + = FamInst { fi_axiom :: CoAxiom Unbranched -- The new coercion axiom introduced + -- by this family instance + , fi_flavor :: FamFlavor + + -- Everything below here is a redundant, + -- cached version of the two things above + -- except that the TyVars are freshened + , fi_fam :: Name -- Family name + + -- Used for "rough matching"; same idea as for class instances + -- See Note [Rough-match field] in InstEnv + , fi_tcs :: [Maybe Name] -- Top of type args + -- INVARIANT: fi_tcs = roughMatchTcs fi_tys + + -- Used for "proper matching"; ditto + , fi_tvs :: [TyVar] -- Template tyvars for full match -- Like ClsInsts, these variables are always -- fresh. See Note [Template tyvars are fresh] -- in InstEnv - , fib_lhs :: [Type] -- type patterns - , fib_rhs :: Type -- RHS of family instance - -- See Note [Why we need fib_rhs] - , fib_tcs :: [Maybe Name] -- used for "rough matching" during typechecking - -- see Note [Rough-match field] in InstEnv - } + + , fi_tys :: [Type] -- and its arg types + -- INVARIANT: fi_tvs = coAxiomTyVars fi_axiom + + , fi_rhs :: Type -- the RHS, with its freshened vars + } data FamFlavor = SynFamilyInst -- A synonym family @@ -148,50 +117,35 @@ data FamFlavor \begin{code} -- Obtain the axiom of a family instance -famInstAxiom :: FamInst br -> CoAxiom br +famInstAxiom :: FamInst -> CoAxiom Unbranched famInstAxiom = fi_axiom -famInstTyCon :: FamInst br -> TyCon -famInstTyCon = co_ax_tc . fi_axiom - -famInstNthBranch :: FamInst br -> Int -> FamInstBranch -famInstNthBranch (FamInst { fi_branches = branches }) index - = ASSERT( 0 <= index && index < (length $ fromBranchList branches) ) - brListNth branches index - -famInstSingleBranch :: FamInst Unbranched -> FamInstBranch -famInstSingleBranch (FamInst { fi_branches = FirstBranch branch }) = branch +-- Split the left-hand side of the FamInst +famInstSplitLHS :: FamInst -> (TyCon, [Type]) +famInstSplitLHS (FamInst { fi_axiom = axiom, fi_tys = lhs }) + = (coAxiomTyCon axiom, lhs) -toBranchedFamInst :: FamInst br -> FamInst Branched -toBranchedFamInst (FamInst ax flav grp branches fam) - = FamInst (toBranchedAxiom ax) flav grp (toBranchedList branches) fam +-- Get the RHS of the FamInst +famInstRHS :: FamInst -> Type +famInstRHS = fi_rhs -toUnbranchedFamInst :: FamInst br -> FamInst Unbranched -toUnbranchedFamInst (FamInst ax flav grp branches fam) - = FamInst (toUnbranchedAxiom ax) flav grp (toUnbranchedList branches) fam - -famInstBranches :: FamInst br -> BranchList FamInstBranch br -famInstBranches = fi_branches - -famInstBranchLHS :: FamInstBranch -> [Type] -famInstBranchLHS = fib_lhs - -famInstBranchRoughMatch :: FamInstBranch -> [Maybe Name] -famInstBranchRoughMatch = fib_tcs +-- Get the family TyCon of the FamInst +famInstTyCon :: FamInst -> TyCon +famInstTyCon = coAxiomTyCon . famInstAxiom -- Return the representation TyCons introduced by data family instances, if any -famInstsRepTyCons :: [FamInst br] -> [TyCon] +famInstsRepTyCons :: [FamInst] -> [TyCon] famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis] -- Extracts the TyCon for this *data* (or newtype) instance -famInstRepTyCon_maybe :: FamInst br -> Maybe TyCon -famInstRepTyCon_maybe fi +famInstRepTyCon_maybe :: FamInst -> Maybe TyCon +famInstRepTyCon_maybe fi = case fi_flavor fi of DataFamilyInst tycon -> Just tycon SynFamilyInst -> Nothing -dataFamInstRepTyCon :: FamInst br -> TyCon -dataFamInstRepTyCon fi +dataFamInstRepTyCon :: FamInst -> TyCon +dataFamInstRepTyCon fi = case fi_flavor fi of DataFamilyInst tycon -> tycon SynFamilyInst -> pprPanic "dataFamInstRepTyCon" (ppr fi) @@ -204,44 +158,46 @@ dataFamInstRepTyCon fi %************************************************************************ \begin{code} -instance NamedThing (FamInst br) where +instance NamedThing FamInst where getName = coAxiomName . fi_axiom -instance Outputable (FamInst br) where +instance Outputable FamInst where ppr = pprFamInst -- Prints the FamInst as a family instance declaration -pprFamInst :: FamInst br -> SDoc -pprFamInst (FamInst { fi_branches = brs, fi_flavor = SynFamilyInst - , fi_group = True, fi_axiom = axiom }) - = hang (ptext (sLit "type instance where")) - 2 (vcat [pprCoAxBranchHdr axiom i | i <- brListIndices brs]) - -pprFamInst fi@(FamInst { fi_flavor = flavor - , fi_group = False, fi_axiom = ax }) - = pprFamFlavor flavor <+> pp_instance - <+> pprCoAxBranchHdr ax 0 +pprFamInst :: FamInst -> SDoc +pprFamInst famInst + = hang (pprFamInstHdr famInst) + 2 (vcat [ ifPprDebug (ptext (sLit "Coercion axiom:") <+> ppr ax) + , ifPprDebug (ptext (sLit "RHS:") <+> ppr (famInstRHS famInst)) + , ptext (sLit "--") <+> pprDefinedAt (getName famInst)]) + where + ax = fi_axiom famInst + +pprFamInstHdr :: FamInst -> SDoc +pprFamInstHdr fi@(FamInst {fi_flavor = flavor}) + = pprTyConSort <+> pp_instance <+> pprHead where + (fam_tc, tys) = famInstSplitLHS fi + -- For *associated* types, say "type T Int = blah" -- For *top level* type instances, say "type instance T Int = blah" pp_instance - | isTyConAssoc (famInstTyCon fi) = empty - | otherwise = ptext (sLit "instance") - -pprFamInst _ = panic "pprFamInst" - -pprFamFlavor :: FamFlavor -> SDoc -pprFamFlavor flavor - = case flavor of - SynFamilyInst -> ptext (sLit "type") - DataFamilyInst tycon - | isDataTyCon tycon -> ptext (sLit "data") - | isNewTyCon tycon -> ptext (sLit "newtype") - | isAbstractTyCon tycon -> ptext (sLit "data") - | otherwise -> ptext (sLit "WEIRD") <+> ppr tycon - -pprFamInsts :: [FamInst br] -> SDoc + | isTyConAssoc fam_tc = empty + | otherwise = ptext (sLit "instance") + + pprHead = pprTypeApp fam_tc tys + pprTyConSort = case flavor of + SynFamilyInst -> ptext (sLit "type") + DataFamilyInst tycon + | isDataTyCon tycon -> ptext (sLit "data") + | isNewTyCon tycon -> ptext (sLit "newtype") + | isAbstractTyCon tycon -> ptext (sLit "data") + | otherwise -> ptext (sLit "WEIRD") <+> ppr tycon + +pprFamInsts :: [FamInst] -> SDoc pprFamInsts finsts = vcat (map pprFamInst finsts) + \end{code} Note [Lazy axiom match] @@ -260,55 +216,39 @@ not in the parameter list) and we assert the consistency of names there also. \begin{code} - -- Make a family instance representation from the information found in an -- interface file. In particular, we get the rough match info from the iface -- (instead of computing it here). mkImportedFamInst :: Name -- Name of the family - -> Bool -- is this a group? - -> [[Maybe Name]] -- Rough match info, per branch - -> CoAxiom Branched -- Axiom introduced - -> FamInst Branched -- Resulting family instance -mkImportedFamInst fam group roughs axiom + -> [Maybe Name] -- Rough match info + -> CoAxiom Unbranched -- Axiom introduced + -> FamInst -- Resulting family instance +mkImportedFamInst fam mb_tcs axiom = FamInst { - fi_fam = fam, - fi_axiom = axiom, - fi_flavor = flavor, - fi_group = group, - fi_branches = branches } - where - -- Lazy match (See note [Lazy axiom match]) - CoAxiom { co_ax_branches = axBranches } - = ASSERT( fam == tyConName (coAxiomTyCon axiom) ) - axiom - - branches = toBranchList $ map mk_imp_fam_inst_branch $ - (roughs `zipLazy` fromBranchList axBranches) - -- Lazy zip (See note [Lazy axiom match]) - - mk_imp_fam_inst_branch (mb_tcs, ~(CoAxBranch { cab_tvs = tvs - , cab_lhs = lhs - , cab_rhs = rhs })) - -- Lazy match (See note [Lazy axiom match]) - = FamInstBranch { fib_tvs = tvs - , fib_lhs = lhs - , fib_rhs = rhs - , fib_tcs = mb_tcs } + fi_fam = fam, + fi_tcs = mb_tcs, + fi_tvs = tvs, + fi_tys = tys, + fi_rhs = rhs, + fi_axiom = axiom, + fi_flavor = flavor } + where + -- See Note [Lazy axiom match] + ~(CoAxiom { co_ax_branches = + ~(FirstBranch ~(CoAxBranch { cab_lhs = tys + , cab_tvs = tvs + , cab_rhs = rhs })) }) = axiom -- Derive the flavor for an imported FamInst rather disgustingly -- Maybe we should store it in the IfaceFamInst? - flavor - | FirstBranch (CoAxBranch { cab_rhs = rhs }) <- axBranches - , Just (tc, _) <- splitTyConApp_maybe rhs - , Just ax' <- tyConFamilyCoercion_maybe tc - , (toBranchedAxiom ax') == axiom - = DataFamilyInst tc - - | otherwise - = SynFamilyInst + flavor = case splitTyConApp_maybe rhs of + Just (tc, _) + | Just ax' <- tyConFamilyCoercion_maybe tc + , ax' == axiom + -> DataFamilyInst tc + _ -> SynFamilyInst \end{code} - %************************************************************************ %* * FamInstEnv @@ -316,7 +256,7 @@ mkImportedFamInst fam group roughs axiom %************************************************************************ Note [FamInstEnv] -~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~ A FamInstEnv maps a family name to the list of known instances for that family. The same FamInstEnv includes both 'data family' and 'type family' instances. @@ -331,9 +271,28 @@ Neverthless it is still useful to have data families in the FamInstEnv: - For finding the representation type...see FamInstEnv.topNormaliseType and its call site in Simplify - - In standalone deriving instance Eq (T [Int]) we need to find the + - In standalone deriving instance Eq (T [Int]) we need to find the representation type for T [Int] +Note [Varying number of patterns for data family axioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For data families, the number of patterns may vary between instances. +For example + data family T a b + data instance T Int a = T1 a | T2 + data instance T Bool [a] = T3 a + +Then we get a data type for each instance, and an axiom: + data TInt a = T1 a | T2 + data TBoolList a = T3 a + + axiom ax7 :: T Int ~ TInt -- Eta-reduced + axiom ax8 a :: T Bool [a] ~ TBoolList a + +These two axioms for T, one with one pattern, one with two. The reason +for this eta-reduction is decribed in TcInstDcls + Note [Eta reduction for data family axioms] + \begin{code} type FamInstEnv = UniqFM FamilyInstEnv -- Maps a family to its instances -- See Note [FamInstEnv] @@ -342,7 +301,7 @@ type FamInstEnvs = (FamInstEnv, FamInstEnv) -- External package inst-env, Home-package inst-env newtype FamilyInstEnv - = FamIE [FamInst Branched] -- The instances for a particular family, in any order + = FamIE [FamInst] -- The instances for a particular family, in any order instance Outputable FamilyInstEnv where ppr (FamIE fs) = ptext (sLit "FamIE") <+> vcat (map ppr fs) @@ -357,16 +316,16 @@ emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv) emptyFamInstEnv :: FamInstEnv emptyFamInstEnv = emptyUFM -famInstEnvElts :: FamInstEnv -> [FamInst Branched] +famInstEnvElts :: FamInstEnv -> [FamInst] famInstEnvElts fi = [elt | FamIE elts <- eltsUFM fi, elt <- elts] -familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst Branched] +familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst] familyInstances (pkg_fie, home_fie) fam = get home_fie ++ get pkg_fie where get env = case lookupUFM env fam of Just (FamIE insts) -> insts - Nothing -> [] + Nothing -> [] -- | Collects the names of the concrete types and type constructors that -- make up the LHS of a type family instance. For instance, @@ -375,28 +334,28 @@ familyInstances (pkg_fie, home_fie) fam -- `type instance Foo (F (G (H a))) b = ...` would yield [F,G,H] -- -- Used in the implementation of ":info" in GHCi. -orphNamesOfFamInst :: FamInst Branched -> NameSet +orphNamesOfFamInst :: FamInst -> NameSet orphNamesOfFamInst = orphNamesOfTypes . concat . brListMap cab_lhs . coAxiomBranches . fi_axiom -extendFamInstEnvList :: FamInstEnv -> [FamInst br] -> FamInstEnv +extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis -extendFamInstEnv :: FamInstEnv -> FamInst br -> FamInstEnv +extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm}) - = addToUFM_C add inst_env cls_nm (FamIE [ins_item_br]) + = addToUFM_C add inst_env cls_nm (FamIE [ins_item]) where - ins_item_br = toBranchedFamInst ins_item - add (FamIE items) _ = FamIE (ins_item_br:items) + add (FamIE items) _ = FamIE (ins_item:items) -deleteFromFamInstEnv :: FamInstEnv -> FamInst br -> FamInstEnv +deleteFromFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv deleteFromFamInstEnv inst_env fam_inst@(FamInst {fi_fam = fam_nm}) = adjustUFM adjust inst_env fam_nm where adjust :: FamilyInstEnv -> FamilyInstEnv - adjust (FamIE items) = FamIE (filterOut (identicalFamInst fam_inst) items) + adjust (FamIE items) + = FamIE (filterOut (identicalFamInst fam_inst) items) -identicalFamInst :: FamInst br1 -> FamInst br2 -> Bool +identicalFamInst :: FamInst -> FamInst -> Bool -- Same LHS, *and* the instance is defined in the same module -- Used for overriding in GHCi identicalFamInst (FamInst { fi_axiom = ax1 }) (FamInst { fi_axiom = ax2 }) @@ -416,7 +375,178 @@ identicalFamInst (FamInst { fi_axiom = ax1 }) (FamInst { fi_axiom = ax2 }) lhs1 = coAxBranchLHS br1 lhs2 = coAxBranchLHS br2 rn_env = rnBndrs2 (mkRnEnv2 emptyInScopeSet) tvs1 tvs2 - + +\end{code} + +%************************************************************************ +%* * + Compatibility +%* * +%************************************************************************ + +Note [Apartness] +~~~~~~~~~~~~~~~~ +In dealing with closed type families, we must be able to check that one type +will never reduce to another. This check is called /apartness/. The check +is always between a target (which may be an arbitrary type) and a pattern. +Here is how we do it: + +apart(target, pattern) = not (unify(flatten(target), pattern)) + +where flatten (implemented in flattenTys, below) converts all type-family +applications into fresh variables. (See Note [Flattening].) + +Note [Compatibility] +~~~~~~~~~~~~~~~~~~~~ +Two patterns are /compatible/ if either of the following conditions hold: +1) The patterns are apart. +2) The patterns unify with a substitution S, and their right hand sides +equal under that substitution. + +For open type families, only compatible instances are allowed. For closed +type families, the story is slightly more complicated. Consider the following: + +type family F a where + F Int = Bool + F a = Int + +g :: Show a => a -> F a +g x = length (show x) + +Should that type-check? No. We need to allow for the possibility that 'a' +might be Int and therefore 'F a' should be Bool. We can simplify 'F a' to Int +only when we can be sure that 'a' is not Int. + +To achieve this, after finding a possible match within the equations, we have to +go back to all previous equations and check that, under the +substitution induced by the match, other branches are surely apart. (See +[Apartness].) This is similar to what happens with class +instance selection, when we need to guarantee that there is only a match and +no unifiers. The exact algorithm is different here because the the +potentially-overlapping group is closed. + +As another example, consider this: + +type family G x +type instance where + G Int = Bool + G a = Double + +type family H y +-- no instances + +Now, we want to simplify (G (H Char)). We can't, because (H Char) might later +simplify to be Int. So, (G (H Char)) is stuck, for now. + +While everything above is quite sound, it isn't as expressive as we'd like. +Consider this: + +type family J a where + J Int = Int + J a = a + +Can we simplify (J b) to b? Sure we can. Yes, the first equation matches if +b is instantiated with Int, but the RHSs coincide there, so it's all OK. + +So, the rule is this: when looking up a branch in a closed type family, we +find a branch that matches the target, but then we make sure that the target +is apart from every previous *incompatible* branch. We don't check the +branches that are compatible with the matching branch, because they are either +irrelevant (clause 1 of compatible) or benign (clause 2 of compatible). + +\begin{code} + +compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool +compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) + (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) + = case tcUnifyTysFG instanceBindFun lhs1 lhs2 of + SurelyApart -> True + Unifiable subst + | Type.substTy subst rhs1 `eqType` Type.substTy subst rhs2 + -> True + _ -> False + +-- takes a CoAxiom with unknown branch incompatibilities and computes +-- the compatibilities +computeAxiomIncomps :: CoAxiom br -> CoAxiom br +computeAxiomIncomps ax@(CoAxiom { co_ax_branches = branches }) + = ax { co_ax_branches = go [] branches } + where + go :: [CoAxBranch] -> BranchList CoAxBranch br -> BranchList CoAxBranch br + go prev_branches (FirstBranch br) + = FirstBranch (br { cab_incomps = mk_incomps br prev_branches }) + go prev_branches (NextBranch br tail) + = let br' = br { cab_incomps = mk_incomps br prev_branches } in + NextBranch br' (go (br' : prev_branches) tail) + + mk_incomps :: CoAxBranch -> [CoAxBranch] -> [CoAxBranch] + mk_incomps br = filter (not . compatibleBranches br) + +\end{code} + +%************************************************************************ +%* * + Constructing axioms + These functions are here because tidyType / tcUnifyTysFG + are not available in CoAxiom +%* * +%************************************************************************ + +Note [Tidy axioms when we build them] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We print out axioms and don't want to print stuff like + F k k a b = ... +Instead we must tidy those kind variables. See Trac #7524. + +\begin{code} +-- all axiom roles are Nominal, as this is only used with type families +mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars + -> [Type] -- LHS patterns + -> Type -- RHS + -> SrcSpan + -> CoAxBranch +mkCoAxBranch tvs lhs rhs loc + = CoAxBranch { cab_tvs = tvs1 + , cab_lhs = tidyTypes env lhs + , cab_roles = map (const Nominal) tvs1 + , cab_rhs = tidyType env rhs + , cab_loc = loc + , cab_incomps = placeHolderIncomps } + where + (env, tvs1) = tidyTyVarBndrs emptyTidyEnv tvs + -- See Note [Tidy axioms when we build them] + +-- all of the following code is here to avoid mutual dependencies with +-- Coercion +mkBranchedCoAxiom :: Name -> TyCon -> [CoAxBranch] -> CoAxiom Branched +mkBranchedCoAxiom ax_name fam_tc branches + = computeAxiomIncomps $ + CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = Nominal + , co_ax_implicit = False + , co_ax_branches = toBranchList branches } + +mkUnbranchedCoAxiom :: Name -> TyCon -> CoAxBranch -> CoAxiom Unbranched +mkUnbranchedCoAxiom ax_name fam_tc branch + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = Nominal + , co_ax_implicit = False + , co_ax_branches = FirstBranch (branch { cab_incomps = [] }) } + +mkSingleCoAxiom :: Name -> [TyVar] -> TyCon -> [Type] -> Type -> CoAxiom Unbranched +mkSingleCoAxiom ax_name tvs fam_tc lhs_tys rhs_ty + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = Nominal + , co_ax_implicit = False + , co_ax_branches = FirstBranch (branch { cab_incomps = [] }) } + where + branch = mkCoAxBranch tvs lhs_tys rhs_ty (getSrcSpan ax_name) \end{code} %************************************************************************ @@ -442,93 +572,19 @@ desugared to we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'. -Note [Instance checking within groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Consider the following: - -type instance where - F Int = Bool - F a = Int - -g :: Show a => a -> F a -g x = length (show x) - -Should that type-check? No. We need to allow for the possibility -that 'a' might be Int and therefore 'F a' should be Bool. We can -simplify 'F a' to Int only when we can be sure that 'a' is not Int. - -To achieve this, after finding a possible match within an instance group, we -have to go back to all previous FamInstBranchess and check that, under the -substitution induced by the match, other matches are not possible. This is -similar to what happens with class instance selection, when we need to -guarantee that there is only a match and no unifiers. The exact algorithm is -different here because the the potentially-overlapping group is closed. - -ALTERNATE APPROACH: As we are processing the branches, we could check if an -instance unifies but does not match. If this happens, there is no possible -match and we can fail right away. This might be more efficient. - -Note [Early failure optimisation for instance groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As we're searching through the instances for a match, it is -possible that we find an branch within an instance that matches, but -a previous branch still unifies. In this case, we can abort the -search, because any other instance that matches will necessarily -overlap with the instance group we're currently searching. Because -overlap among instance groups is disallowed, we know that that -no such other instance exists. - -Note [Confluence checking within groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC allows type family instances to have overlapping patterns as long as the -right-hand sides are coincident in the region of overlap. Can we extend this -notion of confluent overlap to branched instances? Not in any obvious way. - -Consider this: - -type instance where - F Int = Int - F a = a - -Without confluence checking (in other words, as implemented), we cannot now -simplify an application of (F b) -- b might unify with Int later on, so this -application is stuck. However, it would seem easy to just check that, in the -region of overlap, (i.e. b |-> Int), the right-hand sides coincide, so we're -OK. The problem happens when we are simplifying an application (F (G a)), -where (G a) is stuck. What, now, is the region of overlap? We can't soundly -simplify (F (G a)) without knowing that the right-hand sides are confluent -in the region of overlap, but we also can't in any obvious way identify the -region of overlap. We don't want to do analysis on the instances of G, because -that is not sound in a world with open type families. (If G were known to be -closed, there might be a way forward here.) To find the region of overlap, -it is conceivable that we might convert (G a) to some fresh type variable and -then unify, but we must be careful to convert every (G a) to the same fresh -type variable. And then, what if there is an (H a) lying around? It all seems -rather subtle, error-prone, confusing, and probably won't help anyone. So, -we're not doing it. - -So, why is this not a problem with non-branched confluent overlap? Because -we don't need to verify that an application is apart from anything. The -non-branched confluent overlap check happens when we add the instance to the -environment -- we're unifying among patterns, which cannot contain type family -appplications. So, we're safe there and can continue supporting that feature. - \begin{code} + -- when matching a type family application, we get a FamInst, --- a 0-based index of the branch that matched, and the list of types --- the axiom should be applied to -data FamInstMatch = FamInstMatch { fim_instance :: FamInst Branched - , fim_index :: BranchIndex +-- and the list of types the axiom should be applied to +data FamInstMatch = FamInstMatch { fim_instance :: FamInst , fim_tys :: [Type] } + -- See Note [Over-saturated matches] instance Outputable FamInstMatch where ppr (FamInstMatch { fim_instance = inst - , fim_index = ind , fim_tys = tys }) - = ptext (sLit "match with") <+> parens (ppr inst) - <> brackets (ppr ind) <+> ppr tys + = ptext (sLit "match with") <+> parens (ppr inst) <+> ppr tys lookupFamInstEnv :: FamInstEnvs @@ -537,48 +593,14 @@ lookupFamInstEnv -- Precondition: the tycon is saturated (or over-saturated) lookupFamInstEnv - = lookup_fam_inst_env match True - where - match :: MatchFun - match seen (FamInstBranch { fib_tvs = tpl_tvs - , fib_lhs = tpl_tys }) - _ match_tys - = ASSERT( tyVarsOfTypes match_tys `disjointVarSet` tpl_tv_set ) - -- Unification will break badly if the variables overlap - -- They shouldn't because we allocate separate uniques for them - case tcMatchTys tpl_tv_set tpl_tys match_tys of - -- success - Just subst - | checkConflict seen match_tys - -> (Nothing, StopSearching) -- we found an incoherence, so stop searching - -- see Note [Early failure optimisation for instance groups] - - | otherwise - -> (Just subst, KeepSearching) - - -- failure; instance not relevant - Nothing -> (Nothing, KeepSearching) - where - tpl_tv_set = mkVarSet tpl_tvs - - -- see Note [Instance checking within groups] - checkConflict :: [FamInstBranch] -- the previous branches in the instance that matched - -> [Type] -- the types in the tyfam application we are matching - -> Bool -- is there a conflict? - checkConflict [] _ = False - checkConflict ((FamInstBranch { fib_lhs = tpl_tys }) : rest) match_tys - -- see Note [Confluence checking within groups] - | SurelyApart <- tcApartTys instanceBindFun tpl_tys match_tys - = checkConflict rest match_tys - | otherwise - = True + = lookup_fam_inst_env match + where + match _ tpl_tvs tpl_tys tys = tcMatchTys tpl_tvs tpl_tys tys lookupFamInstEnvConflicts :: FamInstEnvs - -> Bool -- True <=> we are checking part of a group with other branches - -> TyCon -- The TyCon of the family - -> FamInstBranch -- the putative new instance branch - -> [FamInstMatch] -- Conflicting branches + -> FamInst -- Putative new instance + -> [FamInstMatch] -- Conflicting matches (don't look at the fim_tys field) -- E.g. when we are about to add -- f : type instance F [a] = a->a -- we do (lookupFamInstConflicts f [b]) @@ -586,67 +608,26 @@ lookupFamInstEnvConflicts -- -- Precondition: the tycon is saturated (or over-saturated) -lookupFamInstEnvConflicts envs grp tc - (FamInstBranch { fib_lhs = tys, fib_rhs = rhs }) - = lookup_fam_inst_env my_unify False envs tc tys +lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom }) + = lookup_fam_inst_env my_unify envs fam tys where - my_unify :: MatchFun - my_unify _ (FamInstBranch { fib_tvs = tpl_tvs, fib_lhs = tpl_tys - , fib_rhs = tpl_rhs }) old_grp match_tys - = ASSERT( tyVarsOfTypes tys `disjointVarSet` mkVarSet tpl_tvs ) + (fam, tys) = famInstSplitLHS fam_inst + -- In example above, fam tys' = F [b] + + my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _ + = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs, + (ppr fam <+> ppr tys) $$ + (ppr tpl_tvs <+> ppr tpl_tys) ) -- Unification will break badly if the variables overlap -- They shouldn't because we allocate separate uniques for them - case tcUnifyTys instanceBindFun tpl_tys match_tys of - Just subst - | isDataFamilyTyCon tc - || grp - || old_grp - || rhs_conflict tpl_rhs rhs subst - -> (Just subst, KeepSearching) - | otherwise -- confluent overlap - -> (Nothing, KeepSearching) - -- irrelevant instance - Nothing -> (Nothing, KeepSearching) - - -- checks whether two RHSs are distinct, under a unifying substitution - -- Note [Family instance overlap conflicts] - rhs_conflict :: Type -> Type -> TvSubst -> Bool - rhs_conflict rhs1 rhs2 subst - = not (rhs1' `eqType` rhs2') - where - rhs1' = substTy subst rhs1 - rhs2' = substTy subst rhs2 - --- This variant is called when we want to check if the conflict is only in the --- home environment (see FamInst.addLocalFamInst) -lookupFamInstEnvConflicts' :: FamInstEnv -> Bool -> TyCon - -> FamInstBranch -> [FamInstMatch] -lookupFamInstEnvConflicts' env - = lookupFamInstEnvConflicts (emptyFamInstEnv, env) -\end{code} + if compatibleBranches (coAxiomSingleBranch old_axiom) (new_branch) + then Nothing + else Just noSubst + -- Note [Family instance overlap conflicts] -Note [lookup_fam_inst_env' implementation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To reduce code duplication, both lookups during simplification and conflict -checking are routed through lookup_fam_inst_env', which looks for a -matching/unifying branch compared to some target. In the simplification -case, the search is for a match for a target application; in the conflict- -checking case, the search is for a unifier for a putative new instance branch. - -The two uses are differentiated by different MatchFuns, which look at a given -branch to see if it is relevant and whether the search should continue. The -the branch is relevant (i.e. matches or unifies), Just subst is -returned; if the instance is not relevant, Nothing is returned. The MatchFun -also indicates what the search algorithm should do next: it could -KeepSearching or StopSearching. - -When to StopSearching? See Note [Early failure optimisation for instance groups] - -For class instances, these two variants of lookup are combined into one -function (cf, @InstEnv@). We don't do that for family instances as the -results of matching and unification are used in two different contexts. -Moreover, matching is the wildly more frequently used operation in the case of -indexed synonyms and we don't want to slow that down by needless unification. + noSubst = panic "lookupFamInstEnvConflicts noSubst" + new_branch = coAxiomSingleBranch new_axiom +\end{code} Note [Family instance overlap conflicts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -654,95 +635,83 @@ Note [Family instance overlap conflicts] conflict (as these instances imply injective type mappings). - In the case of type family instances, overlap is admitted as long as - the neither instance declares an instance group and the right-hand - sides of the overlapping rules coincide under the overlap substitution. - For example: + the right-hand sides of the overlapping rules coincide under the + overlap substitution. eg type instance F a Int = a type instance F Int b = b - These two overlap on (F Int Int) but then both RHSs are Int, + These two overlap on (F Int Int) but then both RHSs are Int, so all is well. We require that they are syntactically equal; anything else would be difficult to test for at this stage. \begin{code} ------------------------------------------------------------ -data ContSearch = KeepSearching - | StopSearching - -- Might be a one-way match or a unifier -type MatchFun = [FamInstBranch] -- the previous branches in the instance - -> FamInstBranch -- the individual branch to check - -> Bool -- is this branch a part of a group? - -> [Type] -- the types to match against - -> (Maybe TvSubst, ContSearch) - -type OneSidedMatch = Bool -- Are optimisations that are only valid for - -- one sided matches allowed? +type MatchFun = FamInst -- The FamInst template + -> TyVarSet -> [Type] -- fi_tvs, fi_tys of that FamInst + -> [Type] -- Target to match against + -> Maybe TvSubst lookup_fam_inst_env' -- The worker, local to this module :: MatchFun - -> OneSidedMatch -> FamInstEnv -> TyCon -> [Type] -- What we are looking for -> [FamInstMatch] -lookup_fam_inst_env' match_fun _one_sided ie fam tys - | isFamilyTyCon fam +lookup_fam_inst_env' match_fun ie fam match_tys + | isOpenFamilyTyCon fam , Just (FamIE insts) <- lookupUFM ie fam - = ASSERT2( n_tys >= arity, ppr fam <+> ppr tys ) - if arity < n_tys then -- Family type applications must be saturated - -- See Note [Over-saturated matches] - map wrap_extra_tys (find match_fun (take arity tys) insts) - else - find match_fun tys insts -- The common case - + = find insts -- The common case | otherwise = [] where - arity = tyConArity fam - n_tys = length tys - extra_tys = drop arity tys - wrap_extra_tys fim@(FamInstMatch { fim_tys = match_tys }) - = fim { fim_tys = match_tys ++ extra_tys } - - -find :: MatchFun -> [Type] -> [FamInst Branched] -> [FamInstMatch] -find _ _ [] = [] -find match_fun match_tys (inst@(FamInst { fi_branches = branches, fi_group = is_group }) : rest) - = case findBranch [] (fromBranchList branches) 0 of - (Just match, StopSearching) -> [match] - (Just match, KeepSearching) -> match : find match_fun match_tys rest - (Nothing, StopSearching) -> [] - (Nothing, KeepSearching) -> find match_fun match_tys rest - where - rough_tcs = roughMatchTcs match_tys - - findBranch :: [FamInstBranch] -- the branches that have already been checked - -> [FamInstBranch] -- still looking through these - -> BranchIndex -- index of teh first of the "still looking" list - -> (Maybe FamInstMatch, ContSearch) - findBranch _ [] _ = (Nothing, KeepSearching) - findBranch seen (branch@(FamInstBranch { fib_tvs = tvs, fib_tcs = mb_tcs }) : rest) ind + + find [] = [] + find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, + fi_tys = tpl_tys }) : rest) + -- Fast check for no match, uses the "rough match" fields | instanceCantMatch rough_tcs mb_tcs - = findBranch seen rest (ind+1) -- branch won't unify later; no need to add to 'seen' + = find rest + + -- Proper check + | Just subst <- match_fun item (mkVarSet tpl_tvs) tpl_tys match_tys1 + = (FamInstMatch { fim_instance = item + , fim_tys = substTyVars subst tpl_tvs `chkAppend` match_tys2 }) + : find rest + + -- No match => try next | otherwise - = case match_fun seen branch is_group match_tys of - (Nothing, KeepSearching) -> findBranch (branch : seen) rest (ind+1) - (Nothing, StopSearching) -> (Nothing, StopSearching) - (Just subst, cont) -> (Just match, cont) - where - match = FamInstMatch { fim_instance = inst - , fim_index = ind - , fim_tys = substTyVars subst tvs } + = find rest + + where + (rough_tcs, match_tys1, match_tys2) = split_tys tpl_tys + + -- Precondition: the tycon is saturated (or over-saturated) + + -- Deal with over-saturation + -- See Note [Over-saturated matches] + split_tys tpl_tys + | isSynFamilyTyCon fam + = pre_rough_split_tys + + | otherwise + = let (match_tys1, match_tys2) = splitAtList tpl_tys match_tys + rough_tcs = roughMatchTcs match_tys1 + in (rough_tcs, match_tys1, match_tys2) + + (pre_match_tys1, pre_match_tys2) = splitAt (tyConArity fam) match_tys + pre_rough_split_tys + = (roughMatchTcs pre_match_tys1, pre_match_tys1, pre_match_tys2) lookup_fam_inst_env -- The worker, local to this module :: MatchFun - -> OneSidedMatch -> FamInstEnvs -> TyCon -> [Type] -- What we are looking for - -> [FamInstMatch] -- What was found + -> [FamInstMatch] -- Successful matches -- Precondition: the tycon is saturated (or over-saturated) -lookup_fam_inst_env match_fun one_sided (pkg_ie, home_ie) fam tys = - lookup_fam_inst_env' match_fun one_sided home_ie fam tys ++ - lookup_fam_inst_env' match_fun one_sided pkg_ie fam tys + +lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys = + lookup_fam_inst_env' match_fun home_ie fam tys ++ + lookup_fam_inst_env' match_fun pkg_ie fam tys + \end{code} Note [Over-saturated matches] @@ -755,11 +724,19 @@ The type instance gives rise to a newtype TyCon (at a higher kind which you can't do in Haskell!): newtype FPair a b = FP (Either (a->b)) -Then looking up (F (Int,Bool) Char) will return a FamInstMatch +Then looking up (F (Int,Bool) Char) will return a FamInstMatch (FPair, [Int,Bool,Char]) The "extra" type argument [Char] just stays on the end. +Because of eta-reduction of data family instances (see +Note [Eta reduction for data family axioms] in TcInstDecls), we must +handle data families and type families separately here. All instances +of a type family must have the same arity, so we can precompute the split +between the match_tys and the overflow tys. This is done in pre_rough_split_tys. +For data instances, though, we need to re-split for each instance, because +the breakdown might be different. + \begin{code} -- checks if one LHS is dominated by a list of other branches @@ -780,6 +757,76 @@ isDominatedBy branch branches = isJust $ tcMatchTys (mkVarSet tvs) tys lhs \end{code} +%************************************************************************ +%* * + Choosing an axiom application +%* * +%************************************************************************ + +The lookupFamInstEnv function does a nice job for *open* type families, +but we also need to handle closed ones when normalising a type: + +\begin{code} + +-- The TyCon can be oversaturated. This works on both open and closed families +chooseAxiom :: FamInstEnvs -> Role -> TyCon -> [Type] -> Maybe (Coercion, Type) +chooseAxiom envs role tc tys + | isOpenFamilyTyCon tc + , [FamInstMatch { fim_instance = fam_inst + , fim_tys = inst_tys }] <- lookupFamInstEnv envs tc tys + = let ax = famInstAxiom fam_inst + co = mkUnbranchedAxInstCo role ax inst_tys + ty = pSnd (coercionKind co) + in Just (co, ty) + + | Just ax <- isClosedSynFamilyTyCon_maybe tc + , Just (ind, inst_tys) <- chooseBranch ax tys + = let co = mkAxInstCo role ax ind inst_tys + ty = pSnd (coercionKind co) + in Just (co, ty) + + | otherwise + = Nothing + +-- The axiom can be oversaturated. (Closed families only.) +chooseBranch :: CoAxiom Branched -> [Type] -> Maybe (BranchIndex, [Type]) +chooseBranch axiom tys + = do { let num_pats = coAxiomNumPats axiom + (target_tys, extra_tys) = splitAt num_pats tys + branches = coAxiomBranches axiom + ; (ind, inst_tys) <- findBranch (fromBranchList branches) 0 target_tys + ; return (ind, inst_tys ++ extra_tys) } + +-- The axiom must *not* be oversaturated +findBranch :: [CoAxBranch] -- branches to check + -> BranchIndex -- index of current branch + -> [Type] -- target types + -> Maybe (BranchIndex, [Type]) +findBranch (CoAxBranch { cab_tvs = tpl_tvs, cab_lhs = tpl_lhs, cab_incomps = incomps } + : rest) ind target_tys + = case tcMatchTys (mkVarSet tpl_tvs) tpl_lhs target_tys of + Just subst -- matching worked. now, check for apartness. + | all (isSurelyApart + . tcUnifyTysFG instanceBindFun flattened_target + . coAxBranchLHS) incomps + -> -- matching worked & we're apart from all incompatible branches. success + Just (ind, substTyVars subst tpl_tvs) + + -- failure. keep looking + _ -> findBranch rest (ind+1) target_tys + + where isSurelyApart SurelyApart = True + isSurelyApart _ = False + + flattened_target = flattenTys in_scope target_tys + in_scope = mkInScopeSet (unionVarSets $ + map (tyVarsOfTypes . coAxBranchLHS) incomps) + +-- fail if no branches left +findBranch [] _ _ = Nothing + +\end{code} + %************************************************************************ %* * @@ -792,8 +839,8 @@ topNormaliseType :: FamInstEnvs -> Type -> Maybe (Coercion, Type) --- Get rid of *outermost* (or toplevel) --- * type functions +-- Get rid of *outermost* (or toplevel) +-- * type functions -- * newtypes -- using appropriate coercions. -- By "outer" we mean that toplevelNormaliseType guarantees to return @@ -802,11 +849,12 @@ topNormaliseType :: FamInstEnvs -- (F ty) is a redex. -- Its a bit like Type.repType, but handles type families too +-- The coercion returned is always an R coercion topNormaliseType env ty - = go emptyNameSet ty + = go initRecTc ty where - go :: NameSet -> Type -> Maybe (Coercion, Type) + go :: RecTcChecker -> Type -> Maybe (Coercion, Type) go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms = go rec_nts ty' @@ -815,8 +863,8 @@ topNormaliseType env ty = add_co nt_co rec_nts' nt_rhs go rec_nts (TyConApp tc tys) - | isFamilyTyCon tc -- Expand open tycons - , (co, ty) <- normaliseTcApp env tc tys + | isFamilyTyCon tc -- Expand family tycons + , (co, ty) <- normaliseTcApp env Representational tc tys -- Note that normaliseType fully normalises 'tys', -- wrt type functions but *not* newtypes -- It has do to so to be sure that nested calls like @@ -827,65 +875,161 @@ topNormaliseType env ty go _ _ = Nothing - add_co co rec_nts ty + add_co co rec_nts ty = case go rec_nts ty of Nothing -> Just (co, ty) Just (co', ty') -> Just (mkTransCo co co', ty') - + --------------- -normaliseTcApp :: FamInstEnvs -> TyCon -> [Type] -> (Coercion, Type) -normaliseTcApp env tc tys +normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type) +normaliseTcApp env role tc tys | isFamilyTyCon tc - , tyConArity tc <= length tys -- Unsaturated data families are possible - , [FamInstMatch { fim_instance = fam_inst - , fim_index = fam_ind - , fim_tys = inst_tys }] <- lookupFamInstEnv env tc ntys - = let -- A matching family instance exists - ax = famInstAxiom fam_inst - co = mkAxInstCo ax fam_ind inst_tys - rhs = mkAxInstRHS ax fam_ind inst_tys + , Just (co, rhs) <- chooseAxiom env role tc ntys + = let -- A reduction is possible first_coi = mkTransCo tycon_coi co - (rest_coi,nty) = normaliseType env rhs + (rest_coi,nty) = normaliseType env role rhs fix_coi = mkTransCo first_coi rest_coi in (fix_coi, nty) | otherwise -- No unique matching family instance exists; - -- we do not do anything (including for newtypes) + -- we do not do anything = (tycon_coi, TyConApp tc ntys) where - -- Normalise the arg types so that they'll match + -- Normalise the arg types so that they'll match -- when we lookup in in the instance envt - (cois, ntys) = mapAndUnzip (normaliseType env) tys - tycon_coi = mkTyConAppCo tc cois + (cois, ntys) = zipWithAndUnzip (normaliseType env) (tyConRolesX role tc) tys + tycon_coi = mkTyConAppCo role tc cois --------------- normaliseType :: FamInstEnvs -- environment with family instances + -> Role -- desired role of output coercion -> Type -- old type -> (Coercion, Type) -- (coercion,new type), where -- co :: old-type ~ new_type -- Normalise the input type, by eliminating *all* type-function redexes -- Returns with Refl if nothing happens --- Does nothing to newtypes - -normaliseType env ty - | Just ty' <- coreView ty = normaliseType env ty' -normaliseType env (TyConApp tc tys) - = normaliseTcApp env tc tys -normaliseType _env ty@(LitTy {}) = (Refl ty, ty) -normaliseType env (AppTy ty1 ty2) - = let (coi1,nty1) = normaliseType env ty1 - (coi2,nty2) = normaliseType env ty2 + +normaliseType env role ty + | Just ty' <- coreView ty = normaliseType env role ty' +normaliseType env role (TyConApp tc tys) + = normaliseTcApp env role tc tys +normaliseType _env role ty@(LitTy {}) = (Refl role ty, ty) +normaliseType env role (AppTy ty1 ty2) + = let (coi1,nty1) = normaliseType env role ty1 + (coi2,nty2) = normaliseType env Nominal ty2 in (mkAppCo coi1 coi2, mkAppTy nty1 nty2) -normaliseType env (FunTy ty1 ty2) - = let (coi1,nty1) = normaliseType env ty1 - (coi2,nty2) = normaliseType env ty2 - in (mkFunCo coi1 coi2, mkFunTy nty1 nty2) -normaliseType env (ForAllTy tyvar ty1) - = let (coi,nty1) = normaliseType env ty1 +normaliseType env role (FunTy ty1 ty2) + = let (coi1,nty1) = normaliseType env role ty1 + (coi2,nty2) = normaliseType env role ty2 + in (mkFunCo role coi1 coi2, mkFunTy nty1 nty2) +normaliseType env role (ForAllTy tyvar ty1) + = let (coi,nty1) = normaliseType env role ty1 in (mkForAllCo tyvar coi, ForAllTy tyvar nty1) -normaliseType _ ty@(TyVarTy _) - = (Refl ty,ty) +normaliseType _ role ty@(TyVarTy _) + = (Refl role ty,ty) +\end{code} + +%************************************************************************ +%* * + Flattening +%* * +%************************************************************************ + +Note [Flattening] +~~~~~~~~~~~~~~~~~ + +As described in +http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf +we sometimes need to flatten core types before unifying them. Flattening +means replacing all top-level uses of type functions with fresh variables, +taking care to preserve sharing. That is, the type (Either (F a b) (F a b)) should +flatten to (Either c c), never (Either c d). + +Defined here because of module dependencies. + +\begin{code} + +type FlattenMap = TypeMap TyVar + +-- See Note [Flattening] +flattenTys :: InScopeSet -> [Type] -> [Type] +flattenTys in_scope tys = snd $ coreFlattenTys all_in_scope emptyTypeMap tys + where + -- when we hit a type function, we replace it with a fresh variable + -- but, we need to make sure that this fresh variable isn't mentioned + -- *anywhere* in the types we're flattening, even if locally-bound in + -- a forall. That way, we can ensure consistency both within and outside + -- of that forall. + all_in_scope = in_scope `extendInScopeSetSet` allTyVarsInTys tys + +coreFlattenTys :: InScopeSet -> FlattenMap -> [Type] -> (FlattenMap, [Type]) +coreFlattenTys in_scope = go [] + where + go rtys m [] = (m, reverse rtys) + go rtys m (ty : tys) + = let (m', ty') = coreFlattenTy in_scope m ty in + go (ty' : rtys) m' tys + +coreFlattenTy :: InScopeSet -> FlattenMap -> Type -> (FlattenMap, Type) +coreFlattenTy in_scope = go + where + go m ty@(TyVarTy {}) = (m, ty) + go m (AppTy ty1 ty2) = let (m1, ty1') = go m ty1 + (m2, ty2') = go m1 ty2 in + (m2, AppTy ty1' ty2') + go m (TyConApp tc tys) + | isFamilyTyCon tc + = let (m', tv) = coreFlattenTyFamApp in_scope m tc tys in + (m', mkTyVarTy tv) + + | otherwise + = let (m', tys') = coreFlattenTys in_scope m tys in + (m', mkTyConApp tc tys') + + go m (FunTy ty1 ty2) = let (m1, ty1') = go m ty1 + (m2, ty2') = go m1 ty2 in + (m2, FunTy ty1' ty2') + + -- Note to RAE: this will have to be changed with kind families + go m (ForAllTy tv ty) = let (m', ty') = go m ty in + (m', ForAllTy tv ty') + + go m ty@(LitTy {}) = (m, ty) + +coreFlattenTyFamApp :: InScopeSet -> FlattenMap + -> TyCon -- type family tycon + -> [Type] -- args + -> (FlattenMap, TyVar) +coreFlattenTyFamApp in_scope m fam_tc fam_args + = case lookupTypeMap m fam_ty of + Just tv -> (m, tv) + -- we need fresh variables here, but this is called far from + -- any good source of uniques. So, we generate one from thin + -- air, using the arbitrary prime number 71 as a seed + Nothing -> let tyvar_unique = deriveUnique (getUnique fam_tc) 71 + tyvar_name = mkSysTvName tyvar_unique (fsLit "fl") + tv = uniqAway in_scope $ mkTyVar tyvar_name (typeKind fam_ty) + m' = extendTypeMap m fam_ty tv in + (m', tv) + where fam_ty = TyConApp fam_tc fam_args + +allTyVarsInTys :: [Type] -> VarSet +allTyVarsInTys [] = emptyVarSet +allTyVarsInTys (ty:tys) = allTyVarsInTy ty `unionVarSet` allTyVarsInTys tys + +allTyVarsInTy :: Type -> VarSet +allTyVarsInTy = go + where + go (TyVarTy tv) = unitVarSet tv + go (AppTy ty1 ty2) = (go ty1) `unionVarSet` (go ty2) + go (TyConApp _ tys) = allTyVarsInTys tys + go (FunTy ty1 ty2) = (go ty1) `unionVarSet` (go ty2) + go (ForAllTy tv ty) = (go (tyVarKind tv)) `unionVarSet` + unitVarSet tv `unionVarSet` + (go ty) -- don't remove tv + go (LitTy {}) = emptyVarSet + \end{code} diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 18d67d8053..31a1bfb8df 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -582,14 +582,16 @@ lookupInstEnv (pkg_ie, home_ie) cls tys -- misleading (complaining of multiple matches when some should be -- overlapped away) - -- Safe Haskell: We restrict code compiled in 'Safe' mode from - -- overriding code compiled in any other mode. The rational is - -- that code compiled in 'Safe' mode is code that is untrusted - -- by the ghc user. So we shouldn't let that code change the - -- behaviour of code the user didn't compile in 'Safe' mode - -- since that's the code they trust. So 'Safe' instances can only - -- overlap instances from the same module. A same instance origin - -- policy for safe compiled instances. + -- NOTE [Safe Haskell isSafeOverlap] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- We restrict code compiled in 'Safe' mode from overriding code + -- compiled in any other mode. The rationale is that code compiled + -- in 'Safe' mode is code that is untrusted by the ghc user. So + -- we shouldn't let that code change the behaviour of code the + -- user didn't compile in 'Safe' mode since that's the code they + -- trust. So 'Safe' instances can only overlap instances from the + -- same module. A same instance origin policy for safe compiled + -- instances. check_safe match@(inst,_) others = case isSafeOverlap (is_flag inst) of -- most specific isn't from a Safe module so OK diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index 0082a33377..ff0ad013ab 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -40,10 +40,10 @@ module Kind ( isAnyKind, isAnyKindCon, okArrowArgKind, okArrowResultKind, - isSubOpenTypeKind, + isSubOpenTypeKind, isSubOpenTypeKindKey, isSubKind, isSubKindCon, tcIsSubKind, tcIsSubKindCon, - defaultKind, + defaultKind, defaultKind_maybe, -- ** Functions on variables kiVarsOfKind, kiVarsOfKinds @@ -60,6 +60,7 @@ import TyCon import VarSet import PrelNames import Outputable +import Maybes( orElse ) import Util \end{code} @@ -172,13 +173,8 @@ returnsConstraintKind _ = False -- arg -> res okArrowArgKindCon, okArrowResultKindCon :: TyCon -> Bool -okArrowArgKindCon kc - | isLiftedTypeKindCon kc = True - | isUnliftedTypeKindCon kc = True - | isConstraintKindCon kc = True - | otherwise = False - -okArrowResultKindCon = okArrowArgKindCon +okArrowArgKindCon = isSubOpenTypeKindCon +okArrowResultKindCon = isSubOpenTypeKindCon okArrowArgKind, okArrowResultKind :: Kind -> Bool okArrowArgKind (TyConApp kc []) = okArrowArgKindCon kc @@ -198,14 +194,17 @@ isSubOpenTypeKind :: Kind -> Bool isSubOpenTypeKind (TyConApp kc []) = isSubOpenTypeKindCon kc isSubOpenTypeKind _ = False -isSubOpenTypeKindCon kc - = isOpenTypeKindCon kc - || isUnliftedTypeKindCon kc - || isLiftedTypeKindCon kc - || isConstraintKindCon kc -- Needed for error (Num a) "blah" - -- and so that (Ord a -> Eq a) is well-kinded - -- and so that (# Eq a, Ord b #) is well-kinded - -- See Note [Kind Constraint and kind *] +isSubOpenTypeKindCon kc = isSubOpenTypeKindKey (tyConUnique kc) + +isSubOpenTypeKindKey :: Unique -> Bool +isSubOpenTypeKindKey uniq + = uniq == openTypeKindTyConKey + || uniq == unliftedTypeKindTyConKey + || uniq == liftedTypeKindTyConKey + || uniq == constraintKindTyConKey -- Needed for error (Num a) "blah" + -- and so that (Ord a -> Eq a) is well-kinded + -- and so that (# Eq a, Ord b #) is well-kinded + -- See Note [Kind Constraint and kind *] -- | Is this a kind (i.e. a type-of-types)? isKind :: Kind -> Bool @@ -271,7 +270,8 @@ tcIsSubKindCon kc1 kc2 | otherwise = isSubKindCon kc1 kc2 ------------------------- -defaultKind :: Kind -> Kind +defaultKind :: Kind -> Kind +defaultKind_maybe :: Kind -> Maybe Kind -- ^ Used when generalising: default OpenKind and ArgKind to *. -- See "Type#kind_subtyping" for more information on what that means @@ -289,9 +289,11 @@ defaultKind :: Kind -> Kind -- This defaulting is done in TcMType.zonkTcTyVarBndr. -- -- The test is really whether the kind is strictly above '*' -defaultKind (TyConApp kc _args) - | isOpenTypeKindCon kc = ASSERT( null _args ) liftedTypeKind -defaultKind k = k +defaultKind_maybe (TyConApp kc _args) + | isOpenTypeKindCon kc = ASSERT( null _args ) Just liftedTypeKind +defaultKind_maybe _ = Nothing + +defaultKind k = defaultKind_maybe k `orElse` k -- Returns the free kind variables in a kind kiVarsOfKind :: Kind -> VarSet diff --git a/compiler/types/OptCoercion.lhs b/compiler/types/OptCoercion.lhs index c85746b60c..9f965ece26 100644 --- a/compiler/types/OptCoercion.lhs +++ b/compiler/types/OptCoercion.lhs @@ -21,14 +21,16 @@ import TyCon import CoAxiom import Var import VarSet +import FamInstEnv ( flattenTys ) import VarEnv import StaticFlags ( opt_NoOptCoercion ) import Outputable import Pair -import Maybes( allMaybes ) +import Maybes import FastString import Util import Unify +import ListSetOps import InstEnv \end{code} @@ -61,7 +63,7 @@ optCoercion :: CvSubst -> Coercion -> NormalCo -- *and* optimises it to reduce its size optCoercion env co | opt_NoOptCoercion = substCo env co - | otherwise = opt_co env False co + | otherwise = opt_co env False Nothing co type NormalCo = Coercion -- Invariants: @@ -74,9 +76,11 @@ type NormalNonIdCo = NormalCo -- Extra invariant: not the identity opt_co, opt_co' :: CvSubst -> Bool -- True <=> return (sym co) + -> Maybe Role -- Nothing <=> don't change; otherwise, change + -- INVARIANT: the change is always a *downgrade* -> Coercion -> NormalCo -opt_co = opt_co' +opt_co = opt_co' {- opt_co env sym co = pprTrace "opt_co {" (ppr sym <+> ppr co $$ ppr env) $ @@ -102,73 +106,111 @@ opt_co env sym co | otherwise = substCo env co -} -opt_co' env _ (Refl ty) = Refl (substTy env ty) -opt_co' env sym (SymCo co) = opt_co env (not sym) co -opt_co' env sym (TyConAppCo tc cos) = mkTyConAppCo tc (map (opt_co env sym) cos) -opt_co' env sym (AppCo co1 co2) = mkAppCo (opt_co env sym co1) (opt_co env sym co2) -opt_co' env sym (ForAllCo tv co) = case substTyVarBndr env tv of - (env', tv') -> mkForAllCo tv' (opt_co env' sym co) +opt_co' env _ mrole (Refl r ty) = Refl (mrole `orElse` r) (substTy env ty) +opt_co' env sym mrole co + | mrole == Just Phantom + || coercionRole co == Phantom + , Pair ty1 ty2 <- coercionKind co + = if sym + then opt_univ env Phantom ty2 ty1 + else opt_univ env Phantom ty1 ty2 + +opt_co' env sym mrole (SymCo co) = opt_co env (not sym) mrole co +opt_co' env sym mrole (TyConAppCo r tc cos) + = case mrole of + Nothing -> mkTyConAppCo r tc (map (opt_co env sym Nothing) cos) + Just r' -> mkTyConAppCo r' tc (zipWith (opt_co env sym) + (map Just (tyConRolesX r' tc)) cos) +opt_co' env sym mrole (AppCo co1 co2) = mkAppCo (opt_co env sym mrole co1) + (opt_co env sym Nothing co2) +opt_co' env sym mrole (ForAllCo tv co) + = case substTyVarBndr env tv of + (env', tv') -> mkForAllCo tv' (opt_co env' sym mrole co) -- Use the "mk" functions to check for nested Refls -opt_co' env sym (CoVarCo cv) +opt_co' env sym mrole (CoVarCo cv) | Just co <- lookupCoVar env cv - = opt_co (zapCvSubstEnv env) sym co + = opt_co (zapCvSubstEnv env) sym mrole co | Just cv1 <- lookupInScope (getCvInScope env) cv - = ASSERT( isCoVar cv1 ) wrapSym sym (CoVarCo cv1) + = ASSERT( isCoVar cv1 ) wrapRole mrole cv_role $ wrapSym sym (CoVarCo cv1) -- cv1 might have a substituted kind! | otherwise = WARN( True, ptext (sLit "opt_co: not in scope:") <+> ppr cv $$ ppr env) ASSERT( isCoVar cv ) - wrapSym sym (CoVarCo cv) + wrapRole mrole cv_role $ wrapSym sym (CoVarCo cv) + where cv_role = coVarRole cv -opt_co' env sym (AxiomInstCo con ind cos) +opt_co' env sym mrole (AxiomInstCo con ind cos) -- Do *not* push sym inside top-level axioms -- e.g. if g is a top-level axiom -- g a : f a ~ a -- then (sym (g ty)) /= g (sym ty) !! - = wrapSym sym $ AxiomInstCo con ind (map (opt_co env False) cos) + = wrapRole mrole (coAxiomRole con) $ + wrapSym sym $ + AxiomInstCo con ind (map (opt_co env False Nothing) cos) -- Note that the_co does *not* have sym pushed into it -opt_co' env sym (UnsafeCo ty1 ty2) - | ty1' `eqType` ty2' = Refl ty1' - | sym = mkUnsafeCo ty2' ty1' - | otherwise = mkUnsafeCo ty1' ty2' +opt_co' env sym mrole (UnivCo r oty1 oty2) + = opt_univ env role a b where - ty1' = substTy env ty1 - ty2' = substTy env ty2 + (a,b) = if sym then (oty2,oty1) else (oty1,oty2) + role = mrole `orElse` r -opt_co' env sym (TransCo co1 co2) +opt_co' env sym mrole (TransCo co1 co2) | sym = opt_trans in_scope opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g | otherwise = opt_trans in_scope opt_co1 opt_co2 where - opt_co1 = opt_co env sym co1 - opt_co2 = opt_co env sym co2 + opt_co1 = opt_co env sym mrole co1 + opt_co2 = opt_co env sym mrole co2 in_scope = getCvInScope env -opt_co' env sym (NthCo n co) - | TyConAppCo tc cos <- co' +-- NthCo roles are fiddly! +opt_co' env sym mrole (NthCo n (TyConAppCo _ _ cos)) + = opt_co env sym mrole (getNth cos n) +opt_co' env sym mrole (NthCo n co) + | TyConAppCo _ _tc cos <- co' , isDecomposableTyCon tc -- Not synonym families = ASSERT( n < length cos ) - cos !! n + ASSERT( _tc == tc ) + let resultCo = cos !! n + resultRole = coercionRole resultCo in + case (mrole, resultRole) of + -- if we just need an R coercion, try to propagate the SubCo again: + (Just Representational, Nominal) -> opt_co (zapCvSubstEnv env) False mrole resultCo + _ -> resultCo + | otherwise - = NthCo n co' - where - co' = opt_co env sym co + = wrap_role $ NthCo n co' -opt_co' env sym (LRCo lr co) + where + wrap_role wrapped = wrapRole mrole (coercionRole wrapped) wrapped + + tc = tyConAppTyCon $ pFst $ coercionKind co + co' = opt_co env sym mrole' co + mrole' = case mrole of + Just Representational + | Representational <- nthRole Representational tc n + -> Just Representational + _ -> Nothing + +opt_co' env sym mrole (LRCo lr co) + | Just pr_co <- splitAppCo_maybe co + = opt_co env sym mrole (pickLR lr pr_co) | Just pr_co <- splitAppCo_maybe co' - = pickLR lr pr_co + = if mrole == Just Representational + then opt_co (zapCvSubstEnv env) False mrole (pickLR lr pr_co) + else pickLR lr pr_co | otherwise - = LRCo lr co' + = wrapRole mrole Nominal $ LRCo lr co' where - co' = opt_co env sym co + co' = opt_co env sym Nothing co -opt_co' env sym (InstCo co ty) +opt_co' env sym mrole (InstCo co ty) -- See if the first arg is already a forall -- ...then we can just extend the current substitution | Just (tv, co_body) <- splitForAllCo_maybe co - = opt_co (extendTvSubst env tv ty') sym co_body + = opt_co (extendTvSubst env tv ty') sym mrole co_body -- See if it is a forall after optimization -- If so, do an inefficient one-variable substitution @@ -177,9 +219,37 @@ opt_co' env sym (InstCo co ty) | otherwise = InstCo co' ty' where - co' = opt_co env sym co + co' = opt_co env sym mrole co ty' = substTy env ty +opt_co' env sym _ (SubCo co) = opt_co env sym (Just Representational) co + +------------- +opt_univ :: CvSubst -> Role -> Type -> Type -> Coercion +opt_univ env role oty1 oty2 + | Just (tc1, tys1) <- splitTyConApp_maybe oty1 + , Just (tc2, tys2) <- splitTyConApp_maybe oty2 + , tc1 == tc2 + = mkTyConAppCo role tc1 (zipWith3 (opt_univ env) (tyConRolesX role tc1) tys1 tys2) + + | Just (l1, r1) <- splitAppTy_maybe oty1 + , Just (l2, r2) <- splitAppTy_maybe oty2 + , typeKind l1 `eqType` typeKind l2 -- kind(r1) == kind(r2) by consequence + = let role' = if role == Phantom then Phantom else Nominal in + -- role' is to comform to mkAppCo's precondition + mkAppCo (opt_univ env role l1 l2) (opt_univ env role' r1 r2) + + | Just (tv1, ty1) <- splitForAllTy_maybe oty1 + , Just (tv2, ty2) <- splitForAllTy_maybe oty2 + , tyVarKind tv1 `eqType` tyVarKind tv2 -- rule out a weird unsafeCo + = case substTyVarBndr2 env tv1 tv2 of { (env1, env2, tv') -> + let ty1' = substTy env1 ty1 + ty2' = substTy env2 ty2 in + mkForAllCo tv' (opt_univ (zapCvSubstEnv2 env1 env2) role ty1' ty2') } + + | otherwise + = mkUnivCo role (substTy env oty1) (substTy env oty2) + ------------- opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] opt_transList is = zipWith (opt_trans is) @@ -239,27 +309,28 @@ opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) mkInstCo (opt_trans is co1 co2) ty1 -- Push transitivity down through matching top-level constructors. -opt_trans_rule is in_co1@(TyConAppCo tc1 cos1) in_co2@(TyConAppCo tc2 cos2) +opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2) | tc1 == tc2 - = fireTransRule "PushTyConApp" in_co1 in_co2 $ - TyConAppCo tc1 (opt_transList is cos1 cos2) + = ASSERT( r1 == r2 ) + fireTransRule "PushTyConApp" in_co1 in_co2 $ + TyConAppCo r1 tc1 (opt_transList is cos1 cos2) opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) = fireTransRule "TrPushApp" in_co1 in_co2 $ mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) -- Eta rules -opt_trans_rule is co1@(TyConAppCo tc cos1) co2 +opt_trans_rule is co1@(TyConAppCo r tc cos1) co2 | Just cos2 <- etaTyConAppCo_maybe tc co2 = ASSERT( length cos1 == length cos2 ) fireTransRule "EtaCompL" co1 co2 $ - TyConAppCo tc (opt_transList is cos1 cos2) + TyConAppCo r tc (opt_transList is cos1 cos2) -opt_trans_rule is co1 co2@(TyConAppCo tc cos2) +opt_trans_rule is co1 co2@(TyConAppCo r tc cos2) | Just cos1 <- etaTyConAppCo_maybe tc co1 = ASSERT( length cos1 == length cos2 ) fireTransRule "EtaCompR" co1 co2 $ - TyConAppCo tc (opt_transList is cos1 cos2) + TyConAppCo r tc (opt_transList is cos1 cos2) opt_trans_rule is co1@(AppCo co1a co1b) co2 | Just (co2a,co2b) <- etaAppCo_maybe co2 @@ -336,18 +407,19 @@ opt_trans_rule is co1 co2 , all (`elemVarSet` pivot_tvs) qtvs = fireTransRule "TrPushAxSym" co1 co2 $ if sym2 - then liftCoSubstWith qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs -- TrPushAxSym - else liftCoSubstWith qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs -- TrPushSymAx + then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs -- TrPushAxSym + else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs -- TrPushSymAx where co1_is_axiom_maybe = isAxiom_maybe co1 co2_is_axiom_maybe = isAxiom_maybe co2 + role = coercionRole co1 -- should be the same as coercionRole co2! opt_trans_rule _ co1 co2 -- Identity rule | Pair ty1 _ <- coercionKind co1 , Pair _ ty2 <- coercionKind co2 , ty1 `eqType` ty2 = fireTransRule "RedTypeDirRefl" co1 co2 $ - Refl ty2 + Refl (coercionRole co1) ty2 opt_trans_rule _ _ _ = Nothing @@ -377,31 +449,36 @@ seems that (axEqual[1] <*> <Int> <Int>) :: (Equal * Int Int ~ False) and that al OK. But, all is not OK: we want to use the first branch of the axiom in this case, not the second. The problem is that the parameters of the first branch can unify with the supplied coercions, thus meaning that the first branch should be taken. See also -Note [Instance checking within groups] in types/FamInstEnv.lhs. +Note [Branched instance checking] in types/FamInstEnv.lhs. \begin{code} -- | Check to make sure that an AxInstCo is internally consistent. --- Returns the number of the conflicting branch, if it exists +-- Returns the conflicting branch, if it exists -- See Note [Conflict checking with AxiomInstCo] -checkAxInstCo :: Coercion -> Maybe Int +checkAxInstCo :: Coercion -> Maybe CoAxBranch -- defined here to avoid dependencies in Coercion +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in CoreLint checkAxInstCo (AxiomInstCo ax ind cos) = let branch = coAxiomNthBranch ax ind tvs = coAxBranchTyVars branch + incomps = coAxBranchIncomps branch tys = map (pFst . coercionKind) cos subst = zipOpenTvSubst tvs tys - lhs' = Type.substTys subst (coAxBranchLHS branch) in - check_no_conflict lhs' (ind-1) + target = Type.substTys subst (coAxBranchLHS branch) + in_scope = mkInScopeSet $ + unionVarSets (map (tyVarsOfTypes . coAxBranchLHS) incomps) + flattened_target = flattenTys in_scope target in + check_no_conflict flattened_target incomps where - check_no_conflict :: [Type] -> Int -> Maybe Int - check_no_conflict _ (-1) = Nothing - check_no_conflict lhs' j - | SurelyApart <- tcApartTys instanceBindFun lhs' lhsj - = check_no_conflict lhs' (j-1) + check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch + check_no_conflict _ [] = Nothing + check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest) + -- See Note [Apartness] in FamInstEnv + | SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp + = check_no_conflict flat rest | otherwise - = Just j - where - (CoAxBranch { cab_lhs = lhsj }) = coAxiomNthBranch ax j + = Just b checkAxInstCo _ = Nothing ----------- @@ -409,6 +486,24 @@ wrapSym :: Bool -> Coercion -> Coercion wrapSym sym co | sym = SymCo co | otherwise = co +wrapRole :: Maybe Role -- desired + -> Role -- current + -> Coercion -> Coercion +wrapRole Nothing _ = id +wrapRole (Just desired) current = maybeSubCo2 desired current + +----------- +-- takes two tyvars and builds env'ts to map them to the same tyvar +substTyVarBndr2 :: CvSubst -> TyVar -> TyVar + -> (CvSubst, CvSubst, TyVar) +substTyVarBndr2 env tv1 tv2 + = case substTyVarBndr env tv1 of + (env1, tv1') -> (env1, extendTvSubstAndInScope env tv2 (mkTyVarTy tv1'), tv1') + +zapCvSubstEnv2 :: CvSubst -> CvSubst -> CvSubst +zapCvSubstEnv2 env1 env2 = mkCvSubst (is1 `unionInScope` is2) [] + where is1 = getCvInScope env1 + is2 = getCvInScope env2 ----------- isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion]) isAxiom_maybe (SymCo co) @@ -423,12 +518,13 @@ matchAxiom :: Bool -- True = match LHS, False = match RHS -- If we succeed in matching, then *all the quantified type variables are bound* -- E.g. if tvs = [a,b], lhs/rhs = [b], we'll fail matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co - = let (CoAxBranch { cab_tvs = qtvs - , cab_lhs = lhs - , cab_rhs = rhs }) = coAxiomNthBranch ax ind in + = let (CoAxBranch { cab_tvs = qtvs + , cab_roles = roles + , cab_lhs = lhs + , cab_rhs = rhs }) = coAxiomNthBranch ax ind in case liftCoMatch (mkVarSet qtvs) (if sym then (mkTyConApp tc lhs) else rhs) co of Nothing -> Nothing - Just subst -> allMaybes (map (liftCoSubstTyVar subst) qtvs) + Just subst -> allMaybes (zipWith (liftCoSubstTyVar subst) roles qtvs) ------------- compatible_co :: Coercion -> Coercion -> Bool @@ -462,7 +558,8 @@ etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion) etaAppCo_maybe co | Just (co1,co2) <- splitAppCo_maybe co = Just (co1,co2) - | Pair ty1 ty2 <- coercionKind co + | Nominal <- coercionRole co + , Pair ty1 ty2 <- coercionKind co , Just (_,t1) <- splitAppTy_maybe ty1 , Just (_,t2) <- splitAppTy_maybe ty2 , typeKind t1 `eqType` typeKind t2 -- Note [Eta for AppCo] @@ -474,7 +571,7 @@ etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] -- If possible, split a coercion -- g :: T s1 .. sn ~ T t1 .. tn -- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ] -etaTyConAppCo_maybe tc (TyConAppCo tc2 cos2) +etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2) = ASSERT( tc == tc2 ) Just cos2 etaTyConAppCo_maybe tc co @@ -486,7 +583,7 @@ etaTyConAppCo_maybe tc co , let n = length tys1 = ASSERT( tc == tc1 ) ASSERT( n == length tys2 ) - Just (decomposeCo n co) + Just (decomposeCo n co) -- NB: n might be <> tyConArity tc -- e.g. data family T a :: * -> * -- g :: T a b ~ T c d diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 2ad8db01b0..47e64301b0 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -13,7 +13,7 @@ module TyCon( AlgTyConRhs(..), visibleDataCons, TyConParent(..), isNoParent, - SynTyConRhs(..), + SynTyConRhs(..), Role(..), -- ** Constructing TyCons mkAlgTyCon, @@ -34,7 +34,7 @@ module TyCon( isFunTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, - isSynTyCon, isOpenSynFamilyTyCon, + isSynTyCon, isDecomposableTyCon, isForeignTyCon, isPromotedDataCon, isPromotedTyCon, @@ -45,7 +45,9 @@ module TyCon( isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, isEnumerationTyCon, isNewTyCon, isAbstractTyCon, - isFamilyTyCon, isSynFamilyTyCon, isDataFamilyTyCon, + isFamilyTyCon, isOpenFamilyTyCon, + isSynFamilyTyCon, isDataFamilyTyCon, + isOpenSynFamilyTyCon, isClosedSynFamilyTyCon_maybe, isUnLiftedTyCon, isGadtSyntaxTyCon, isDistinctTyCon, isDistinctAlgRhs, isTyConAssoc, tyConAssoc_maybe, @@ -63,6 +65,7 @@ module TyCon( tyConFamilySize, tyConStupidTheta, tyConArity, + tyConRoles, tyConParent, tyConTuple_maybe, tyConClass_maybe, tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, @@ -81,7 +84,10 @@ module TyCon( -- * Primitive representations of Types PrimRep(..), PrimElemRep(..), tyConPrimRep, - primRepSizeW, primElemRepSizeB + primRepSizeW, primElemRepSizeB, + + -- * Recursion breaking + RecTcChecker, initRecTc, checkRecTc ) where #include "HsVersions.h" @@ -95,6 +101,7 @@ import BasicTypes import DynFlags import ForeignCall import Name +import NameSet import CoAxiom import PrelNames import Maybes @@ -133,17 +140,19 @@ Note [Type synonym families] * Translation of type family decl: type family F a :: * translates to - a SynTyCon 'F', whose SynTyConRhs is SynFamilyTyCon + a SynTyCon 'F', whose SynTyConRhs is OpenSynFamilyTyCon -* Translation of type family decl: - type family F a :: * + type family G a :: * where + G Int = Bool + G Bool = Char + G a = () translates to - a SynTyCon 'F', whose SynTyConRhs is SynFamilyTyCon + a SynTyCon 'G', whose SynTyConRhs is ClosedSynFamilyTyCon, with the + appropriate CoAxiom representing the equations * In the future we might want to support - * closed type families (esp when we have proper kinds) * injective type families (allow decomposition) - but we don't at the moment [2010] + but we don't at the moment [2013] Note [Data type families] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -263,6 +272,28 @@ This is important. In an instance declaration we expect data T p [x] = T1 x | T2 p type F [x] q (Tree y) = (x,y,q) +Note [TyCon Role signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Every tycon has a role signature, assigning a role to each of the tyConTyVars +(or of equal length to the tyConArity, if there are no tyConTyVars). An +example demonstrates these best: say we have a tycon T, with parameters a@N, +b@R, and c@P. Then, to prove representational equality between T a1 b1 c1 and +T a2 b2 c2, we need to have nominal equality between a1 and a2, representational +equality between b1 and b2, and nothing in particular (i.e., phantom equality) +between c1 and c2. This might happen, say, with the following declaration: + + data T a b c where + MkT :: b -> T Int b c + +Data and class tycons have their roles inferred (see inferRoles in TcTyDecls), +as do vanilla synonym tycons. Family tycons have all parameters at role N, +though it is conceivable that we could relax this restriction. (->)'s and +tuples' parameters are at role R. Each primitive tycon declares its roles; +it's worth noting that (~#)'s parameters are at role N. Promoted data +constructors' type arguments are at role R. All kind arguments are at role +N. + %************************************************************************ %* * \subsection{The data type} @@ -313,6 +344,10 @@ data TyCon -- 3. The family instance types if present -- -- Note that it does /not/ scope over the data constructors. + tc_roles :: [Role], -- ^ The role for each type variable + -- This list has the same length as tyConTyVars + -- See also Note [TyCon Role signatures] + tyConCType :: Maybe CType, -- The C type that should be used -- for this type when using the FFI -- and CAPI @@ -364,8 +399,9 @@ data TyCon tyConArity :: Arity, tyConTyVars :: [TyVar], -- Bound tyvars + tc_roles :: [Role], - synTcRhs :: SynTyConRhs Type, -- ^ Contains information about the + synTcRhs :: SynTyConRhs, -- ^ Contains information about the -- expansion of the synonym synTcParent :: TyConParent -- ^ Gives the family declaration 'TyCon' @@ -380,8 +416,8 @@ data TyCon tyConUnique :: Unique, tyConName :: Name, tc_kind :: Kind, - tyConArity :: Arity, -- SLPJ Oct06: I'm not sure what the significance - -- of the arity of a primtycon is! + tyConArity :: Arity, + tc_roles :: [Role], primTyConRep :: PrimRep, -- ^ Many primitive tycons are unboxed, but some are -- boxed (represented by pointers). This 'PrimRep' @@ -401,6 +437,7 @@ data TyCon tyConUnique :: Unique, -- ^ Same Unique as the data constructor tyConName :: Name, -- ^ Same Name as the data constructor tyConArity :: Arity, + tc_roles :: [Role], -- ^ Roles: N for kind vars, R for type vars tc_kind :: Kind, -- ^ Translated type of the data constructor dataCon :: DataCon -- ^ Corresponding data constructor } @@ -488,6 +525,7 @@ data AlgTyConRhs -- Watch out! If any newtypes become transparent -- again check Trac #1072. } + \end{code} Note [AbstractTyCon and type equality] @@ -573,18 +611,23 @@ isNoParent _ = False -------------------- -- | Information pertaining to the expansion of a type synonym (@type@) -data SynTyConRhs ty +data SynTyConRhs = -- | An ordinary type synonyn. SynonymTyCon - ty -- This 'Type' is the rhs, and may mention from 'tyConTyVars'. + Type -- This 'Type' is the rhs, and may mention from 'tyConTyVars'. -- It acts as a template for the expansion when the 'TyCon' -- is applied to some types. - -- | A type synonym family e.g. @type family F x y :: * -> *@ - | SynFamilyTyCon { - synf_open :: Bool, -- See Note [Closed type families] - synf_injective :: Bool - } + -- | An open type synonym family e.g. @type family F x y :: * -> *@ + | OpenSynFamilyTyCon + + -- | A closed type synonym family e.g. @type family F x where { F Int = Bool }@ + | ClosedSynFamilyTyCon + (CoAxiom Branched) -- The one axiom for this family + + -- | A closed type synonym family declared in an hs-boot file with + -- type family F a where .. + | AbstractClosedSynFamilyTyCon \end{code} Note [Closed type families] @@ -592,8 +635,9 @@ Note [Closed type families] * In an open type family you can add new instances later. This is the usual case. -* In a closed type family you can only put instnaces where the family - is defined. GHC doesn't support syntax for this yet. +* In a closed type family you can only put equations where the family + is defined. + Note [Promoted data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -673,10 +717,12 @@ which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s]) Note [Newtype eta] ~~~~~~~~~~~~~~~~~~ Consider - newtype Parser m a = MkParser (Foogle m a) + newtype Parser a = MkParser (IO a) derriving( Monad ) Are these two types equal (to Core)? - Monad (Parser m) - Monad (Foogle m) + Monad Parser + Monad IO +which we need to make the derived instance for Monad Parser. + Well, yes. But to see that easily we eta-reduce the RHS type of Parser, in this case to ([], Froogle), so that even unsaturated applications of Parser will work right. This eta reduction is done when the type @@ -865,6 +911,7 @@ mkAlgTyCon :: Name -> Kind -- ^ Kind of the resulting 'TyCon' -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'. -- Arity is inferred from the length of this list + -> [Role] -- ^ The roles for each TyVar -> Maybe CType -- ^ The C type this type corresponds to -- when using the CAPI FFI -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' @@ -874,13 +921,14 @@ mkAlgTyCon :: Name -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? -> Maybe TyCon -- ^ Promoted version -> TyCon -mkAlgTyCon name kind tyvars cType stupid rhs parent is_rec gadt_syn prom_tc +mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_tc = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, tc_kind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, + tc_roles = roles, tyConCType = cType, algTcStupidTheta = stupid, algTcRhs = rhs, @@ -891,9 +939,9 @@ mkAlgTyCon name kind tyvars cType stupid rhs parent is_rec gadt_syn prom_tc } -- | Simpler specialization of 'mkAlgTyCon' for classes -mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> TyCon -mkClassTyCon name kind tyvars rhs clas is_rec - = mkAlgTyCon name kind tyvars Nothing [] rhs (ClassTyCon clas) +mkClassTyCon :: Name -> Kind -> [TyVar] -> [Role] -> AlgTyConRhs -> Class -> RecFlag -> TyCon +mkClassTyCon name kind tyvars roles rhs clas is_rec + = mkAlgTyCon name kind tyvars roles Nothing [] rhs (ClassTyCon clas) is_rec False Nothing -- Class TyCons are not pormoted @@ -924,14 +972,14 @@ mkTupleTyCon name kind arity tyvars con sort prom_tc mkForeignTyCon :: Name -> Maybe FastString -- ^ Name of the foreign imported thing, maybe -> Kind - -> Arity -> TyCon -mkForeignTyCon name ext_name kind arity +mkForeignTyCon name ext_name kind = PrimTyCon { tyConName = name, tyConUnique = nameUnique name, tc_kind = kind, - tyConArity = arity, + tyConArity = 0, + tc_roles = [], primTyConRep = PtrRep, -- they all do isUnLifted = False, tyConExtName = ext_name @@ -939,41 +987,43 @@ mkForeignTyCon name ext_name kind arity -- | Create an unlifted primitive 'TyCon', such as @Int#@ -mkPrimTyCon :: Name -> Kind -> Arity -> PrimRep -> TyCon -mkPrimTyCon name kind arity rep - = mkPrimTyCon' name kind arity rep True +mkPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon +mkPrimTyCon name kind roles rep + = mkPrimTyCon' name kind roles rep True -- | Kind constructors mkKindTyCon :: Name -> Kind -> TyCon mkKindTyCon name kind - = mkPrimTyCon' name kind 0 VoidRep True + = mkPrimTyCon' name kind [] VoidRep True -- | Create a lifted primitive 'TyCon' such as @RealWorld@ -mkLiftedPrimTyCon :: Name -> Kind -> Arity -> PrimRep -> TyCon -mkLiftedPrimTyCon name kind arity rep - = mkPrimTyCon' name kind arity rep False +mkLiftedPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon +mkLiftedPrimTyCon name kind roles rep + = mkPrimTyCon' name kind roles rep False -mkPrimTyCon' :: Name -> Kind -> Arity -> PrimRep -> Bool -> TyCon -mkPrimTyCon' name kind arity rep is_unlifted +mkPrimTyCon' :: Name -> Kind -> [Role] -> PrimRep -> Bool -> TyCon +mkPrimTyCon' name kind roles rep is_unlifted = PrimTyCon { tyConName = name, tyConUnique = nameUnique name, tc_kind = kind, - tyConArity = arity, + tyConArity = length roles, + tc_roles = roles, primTyConRep = rep, isUnLifted = is_unlifted, tyConExtName = Nothing } -- | Create a type synonym 'TyCon' -mkSynTyCon :: Name -> Kind -> [TyVar] -> SynTyConRhs Type -> TyConParent -> TyCon -mkSynTyCon name kind tyvars rhs parent +mkSynTyCon :: Name -> Kind -> [TyVar] -> [Role] -> SynTyConRhs -> TyConParent -> TyCon +mkSynTyCon name kind tyvars roles rhs parent = SynTyCon { tyConName = name, tyConUnique = nameUnique name, tc_kind = kind, tyConArity = length tyvars, tyConTyVars = tyvars, + tc_roles = roles, synTcRhs = rhs, synTcParent = parent } @@ -982,15 +1032,18 @@ mkSynTyCon name kind tyvars rhs parent -- Somewhat dodgily, we give it the same Name -- as the data constructor itself; when we pretty-print -- the TyCon we add a quote; see the Outputable TyCon instance -mkPromotedDataCon :: DataCon -> Name -> Unique -> Kind -> Arity -> TyCon -mkPromotedDataCon con name unique kind arity +mkPromotedDataCon :: DataCon -> Name -> Unique -> Kind -> [Role] -> TyCon +mkPromotedDataCon con name unique kind roles = PromotedDataCon { tyConName = name, tyConUnique = unique, tyConArity = arity, + tc_roles = roles, tc_kind = kind, dataCon = con } + where + arity = length roles -- | Create a promoted type constructor 'TyCon' -- Somewhat dodgily, we give it the same Name @@ -1149,21 +1202,38 @@ isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon { is_enum = res }}) = res isEnumerationTyCon (TupleTyCon {tyConArity = arity}) = arity == 0 isEnumerationTyCon _ = False --- | Is this a 'TyCon', synonym or otherwise, that may have further instances appear? +-- | Is this a 'TyCon', synonym or otherwise, that defines a family? isFamilyTyCon :: TyCon -> Bool -isFamilyTyCon (SynTyCon {synTcRhs = SynFamilyTyCon {}}) = True -isFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True +isFamilyTyCon (SynTyCon {synTcRhs = OpenSynFamilyTyCon }) = True +isFamilyTyCon (SynTyCon {synTcRhs = ClosedSynFamilyTyCon {} }) = True +isFamilyTyCon (SynTyCon {synTcRhs = AbstractClosedSynFamilyTyCon {} }) = True +isFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True isFamilyTyCon _ = False +-- | Is this a 'TyCon', synonym or otherwise, that defines an family with +-- instances? +isOpenFamilyTyCon :: TyCon -> Bool +isOpenFamilyTyCon (SynTyCon {synTcRhs = OpenSynFamilyTyCon }) = True +isOpenFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon }) = True +isOpenFamilyTyCon _ = False + -- | Is this a synonym 'TyCon' that can have may have further instances appear? isSynFamilyTyCon :: TyCon -> Bool -isSynFamilyTyCon (SynTyCon {synTcRhs = SynFamilyTyCon {}}) = True +isSynFamilyTyCon (SynTyCon {synTcRhs = OpenSynFamilyTyCon {}}) = True +isSynFamilyTyCon (SynTyCon {synTcRhs = ClosedSynFamilyTyCon {}}) = True +isSynFamilyTyCon (SynTyCon {synTcRhs = AbstractClosedSynFamilyTyCon {}}) = True isSynFamilyTyCon _ = False isOpenSynFamilyTyCon :: TyCon -> Bool -isOpenSynFamilyTyCon (SynTyCon {synTcRhs = SynFamilyTyCon { synf_open = is_open } }) = is_open +isOpenSynFamilyTyCon (SynTyCon {synTcRhs = OpenSynFamilyTyCon }) = True isOpenSynFamilyTyCon _ = False +-- leave out abstract closed families here +isClosedSynFamilyTyCon_maybe :: TyCon -> Maybe (CoAxiom Branched) +isClosedSynFamilyTyCon_maybe + (SynTyCon {synTcRhs = ClosedSynFamilyTyCon ax}) = Just ax +isClosedSynFamilyTyCon_maybe _ = Nothing + -- | Is this a synonym 'TyCon' that can have may have further instances appear? isDataFamilyTyCon :: TyCon -> Bool isDataFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True @@ -1372,6 +1442,23 @@ algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs algTyConRhs (TupleTyCon {dataCon = con, tyConArity = arity}) = DataTyCon { data_cons = [con], is_enum = arity == 0 } algTyConRhs other = pprPanic "algTyConRhs" (ppr other) + +-- | Get the list of roles for the type parameters of a TyCon +tyConRoles :: TyCon -> [Role] +-- See also Note [TyCon Role signatures] +tyConRoles tc + = case tc of + { FunTyCon {} -> const_role Representational + ; AlgTyCon { tc_roles = roles } -> roles + ; TupleTyCon {} -> const_role Representational + ; SynTyCon { tc_roles = roles } -> roles + ; PrimTyCon { tc_roles = roles } -> roles + ; PromotedDataCon { tc_roles = roles } -> roles + ; PromotedTyCon {} -> const_role Nominal + } + where + const_role r = replicate (tyConArity tc) r + \end{code} \begin{code} @@ -1423,7 +1510,7 @@ synTyConDefn_maybe (SynTyCon {tyConTyVars = tyvars, synTcRhs = SynonymTyCon ty}) synTyConDefn_maybe _ = Nothing -- | Extract the information pertaining to the right hand side of a type synonym (@type@) declaration. -synTyConRhs_maybe :: TyCon -> Maybe (SynTyConRhs Type) +synTyConRhs_maybe :: TyCon -> Maybe SynTyConRhs synTyConRhs_maybe (SynTyCon {synTcRhs = rhs}) = Just rhs synTyConRhs_maybe _ = Nothing \end{code} @@ -1549,3 +1636,55 @@ instance Data.Data TyCon where dataTypeOf _ = mkNoRepType "TyCon" \end{code} + +%************************************************************************ +%* * + Walking over recursive TyCons +%* * +%************************************************************************ + +Note [Expanding newtypes and products] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When expanding a type to expose a data-type constructor, we need to be +careful about newtypes, lest we fall into an infinite loop. Here are +the key examples: + + newtype Id x = MkId x + newtype Fix f = MkFix (f (Fix f)) + newtype T = MkT (T -> T) + + Type Expansion + -------------------------- + T T -> T + Fix Maybe Maybe (Fix Maybe) + Id (Id Int) Int + Fix Id NO NO NO + +Notice that we can expand T, even though it's recursive. +And we can expand Id (Id Int), even though the Id shows up +twice at the outer level. + +So, when expanding, we keep track of when we've seen a recursive +newtype at outermost level; and bale out if we see it again. + +We sometimes want to do the same for product types, so that the +strictness analyser doesn't unbox infinitely deeply. + +The function that manages this is checkRecTc. + +\begin{code} +newtype RecTcChecker = RC NameSet + +initRecTc :: RecTcChecker +initRecTc = RC emptyNameSet + +checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker +-- Nothing => Recursion detected +-- Just rec_tcs => Keep going +checkRecTc (RC rec_nts) tc + | not (isRecursiveTyCon tc) = Just (RC rec_nts) + | tc_name `elemNameSet` rec_nts = Nothing + | otherwise = Just (RC (addOneToNameSet rec_nts tc_name)) + where + tc_name = tyConName tc +\end{code} diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index f6e48277d9..8596dde439 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -22,7 +22,7 @@ module Type ( -- ** Constructing and deconstructing types mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, - mkAppTy, mkAppTys, mkNakedAppTys, splitAppTy, splitAppTys, + mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTy_maybe, repSplitAppTy_maybe, mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe, @@ -48,7 +48,7 @@ module Type ( -- Pred types mkFamilyTyConApp, isDictLikeTy, - mkEqPred, mkPrimEqPred, + mkEqPred, mkPrimEqPred, mkReprPrimEqPred, mkClassPred, noParenPred, isClassPred, isEqPred, isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, @@ -159,14 +159,13 @@ import Class import TyCon import TysPrim import {-# SOURCE #-} TysWiredIn ( eqTyCon, typeNatKind, typeSymbolKind ) -import PrelNames ( eqTyConKey, ipClassNameKey, +import PrelNames ( eqTyConKey, ipClassNameKey, openTypeKindTyConKey, constraintKindTyConKey, liftedTypeKindTyConKey ) import CoAxiom -- others import Unique ( Unique, hasKey ) import BasicTypes ( Arity, RepArity ) -import NameSet import StaticFlags import Util import Outputable @@ -350,11 +349,6 @@ mkAppTys ty1 [] = ty1 mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2) mkAppTys ty1 tys2 = foldl AppTy ty1 tys2 -mkNakedAppTys :: Type -> [Type] -> Type -mkNakedAppTys ty1 [] = ty1 -mkNakedAppTys (TyConApp tc tys1) tys2 = mkNakedTyConApp tc (tys1 ++ tys2) -mkNakedAppTys ty1 tys2 = foldl AppTy ty1 tys2 - ------------- splitAppTy_maybe :: Type -> Maybe (Type, Type) -- ^ Attempt to take a type application apart, whether it is a @@ -595,31 +589,6 @@ The reason is that we then get better (shorter) type signatures in interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. -Note [Expanding newtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~ -When expanding a type to expose a data-type constructor, we need to be -careful about newtypes, lest we fall into an infinite loop. Here are -the key examples: - - newtype Id x = MkId x - newtype Fix f = MkFix (f (Fix f)) - newtype T = MkT (T -> T) - - Type Expansion - -------------------------- - T T -> T - Fix Maybe Maybe (Fix Maybe) - Id (Id Int) Int - Fix Id NO NO NO - -Notice that we can expand T, even though it's recursive. -And we can expand Id (Id Int), even though the Id shows up -twice at the outer level. - -So, when expanding, we keep track of when we've seen a recursive -newtype at outermost level; and bale out if we see it again. - - Representation types ~~~~~~~~~~~~~~~~~~~~ @@ -654,9 +623,9 @@ flattenRepType (UnaryRep ty) = [ty] -- It's useful in the back end of the compiler. repType :: Type -> RepType repType ty - = go emptyNameSet ty + = go initRecTc ty where - go :: NameSet -> Type -> RepType + go :: RecTcChecker -> Type -> RepType go rec_nts ty -- Expand predicates and synonyms | Just ty' <- coreView ty = go rec_nts ty' @@ -667,10 +636,7 @@ repType ty go rec_nts (TyConApp tc tys) -- Expand newtypes | isNewTyCon tc , tys `lengthAtLeast` tyConArity tc - , let tc_name = tyConName tc - rec_nts' | isRecursiveTyCon tc = addOneToNameSet rec_nts tc_name - | otherwise = rec_nts - , not (tc_name `elemNameSet` rec_nts) -- See Note [Expanding newtypes] + , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] in TyCon = go rec_nts' (newTyConInstRhs tc tys) | isUnboxedTupleTyCon tc @@ -846,9 +812,25 @@ noParenPred :: PredType -> Bool noParenPred p = not (isIPPred p) && isClassPred p || isEqPred p isPredTy :: Type -> Bool -isPredTy ty - | isSuperKind ty = False - | otherwise = isConstraintKind (typeKind ty) + -- NB: isPredTy is used when printing types, which can happen in debug printing + -- during type checking of not-fully-zonked types. So it's not cool to say + -- isConstraintKind (typeKind ty) because absent zonking the type might + -- be ill-kinded, and typeKind crashes + -- Hence the rather tiresome story here +isPredTy ty = go ty [] + where + go :: Type -> [KindOrType] -> Bool + go (AppTy ty1 ty2) args = go ty1 (ty2 : args) + go (TyConApp tc tys) args = go_k (tyConKind tc) (tys ++ args) + go (TyVarTy tv) args = go_k (tyVarKind tv) args + go _ _ = False + + go_k :: Kind -> [KindOrType] -> Bool + -- True <=> kind is k1 -> .. -> kn -> Constraint + go_k k [] = isConstraintKind k + go_k (FunTy _ k1) (_ :args) = go_k k1 args + go_k (ForAllTy kv k1) (k2:args) = go_k (substKiWith [kv] [k2] k1) args + go_k _ _ = False -- Typeable * Int :: Constraint isKindTy :: Type -> Bool isKindTy = isSuperKind . typeKind @@ -898,6 +880,13 @@ mkPrimEqPred ty1 ty2 TyConApp eqPrimTyCon [k, ty1, ty2] where k = typeKind ty1 + +mkReprPrimEqPred :: Type -> Type -> Type +mkReprPrimEqPred ty1 ty2 + = WARN( not (k `eqKind` typeKind ty2), ppr ty1 $$ ppr ty2 ) + TyConApp eqReprPrimTyCon [k, ty1, ty2] + where + k = typeKind ty1 \end{code} --------------------- Dictionary types --------------------------------- @@ -1234,7 +1223,7 @@ cmpTypeX env t1 t2 | Just t1' <- coreView t1 = cmpTypeX env t1' t2 -- So the RHS has a data type cmpTypeX env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 `compare` rnOccR env tv2 -cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTypeX env (tyVarKind tv1) (tyVarKind tv1) +cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTypeX env (tyVarKind tv1) (tyVarKind tv2) `thenCmp` cmpTypeX (rnBndr2 env tv1 tv2) t1 t2 cmpTypeX env (AppTy s1 t1) (AppTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2 cmpTypeX env (FunTy s1 t1) (FunTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2 @@ -1275,7 +1264,13 @@ cmpTypesX _ _ [] = GT cmpTc :: TyCon -> TyCon -> Ordering -- Here we treat * and Constraint as equal -- See Note [Kind Constraint and kind *] in Kinds.lhs -cmpTc tc1 tc2 = nu1 `compare` nu2 +-- +-- Also we treat OpenTypeKind as equal to either * or # +-- See Note [Comparison with OpenTypeKind] +cmpTc tc1 tc2 + | u1 == openTypeKindTyConKey, isSubOpenTypeKindKey u2 = EQ + | u2 == openTypeKindTyConKey, isSubOpenTypeKindKey u1 = EQ + | otherwise = nu1 `compare` nu2 where u1 = tyConUnique tc1 nu1 = if u1==constraintKindTyConKey then liftedTypeKindTyConKey else u1 @@ -1283,6 +1278,18 @@ cmpTc tc1 tc2 = nu1 `compare` nu2 nu2 = if u2==constraintKindTyConKey then liftedTypeKindTyConKey else u2 \end{code} +Note [Comparison with OpenTypeKind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In PrimOpWrappers we have things like + PrimOpWrappers.mkWeak# = /\ a b c. Prim.mkWeak# a b c +where + Prim.mkWeak# :: forall (a:Open) b c. a -> b -> c + -> State# RealWorld -> (# State# RealWorld, Weak# b #) +Now, eta reduction will turn the definition into + PrimOpWrappers.mkWeak# = Prim.mkWeak# +which is kind-of OK, but now the types aren't really equal. So HACK HACK +we pretend (in Core) that Open is equal to * or #. I hate this. + Note [cmpTypeX] ~~~~~~~~~~~~~~~ diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index f7fdd595aa..e557a6cbb5 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -33,7 +33,7 @@ module TypeRep ( PredType, ThetaType, -- Synonyms -- Functions over types - mkNakedTyConApp, mkTyConTy, mkTyVarTy, mkTyVarTys, + mkTyConTy, mkTyVarTy, mkTyVarTys, isLiftedTypeKind, isSuperKind, isTypeVar, isKindVar, -- Pretty-printing @@ -140,7 +140,7 @@ data Type Var -- Type or kind variable Type -- ^ A polymorphic type - | LitTy TyLit -- ^ Type literals are simillar to type constructors. + | LitTy TyLit -- ^ Type literals are similar to type constructors. deriving (Data.Data, Data.Typeable) @@ -280,14 +280,6 @@ mkTyVarTy = TyVarTy mkTyVarTys :: [TyVar] -> [Type] mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy -mkNakedTyConApp :: TyCon -> [Type] -> Type --- Builds a TyConApp --- * without being strict in TyCon, --- * the TyCon should never be a saturated FunTyCon --- Type.mkTyConApp is the usual one -mkNakedTyConApp tc tys - = TyConApp (ASSERT( not (isFunTyCon tc && length tys == 2) ) tc) tys - -- | Create the plain type constructor type which has been applied to no type arguments at all. mkTyConTy :: TyCon -> Type mkTyConTy tycon = TyConApp tycon [] @@ -686,7 +678,7 @@ pprTcApp p pp tc tys sep (punctuate comma (map (pp TopPrec) ty_args))) | not opt_PprStyle_Debug - , getUnique tc `elem` [eqTyConKey, eqPrimTyConKey] + , getUnique tc `elem` [eqTyConKey, eqPrimTyConKey, eqReprPrimTyConKey] -- We need to special case the type equality TyCons because , [_, ty1,ty2] <- tys -- with kind polymorphism it has 3 args, so won't get printed infix -- With -dppr-debug switch this off so we can see the kind diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs index 2410a02f37..35f4ef5576 100644 --- a/compiler/types/Unify.lhs +++ b/compiler/types/Unify.lhs @@ -25,7 +25,7 @@ module Unify ( tcUnifyTys, BindFlag(..), niFixTvSubst, niSubstTvSet, - ApartResult(..), tcApartTys + UnifyResultM(..), UnifyResult, tcUnifyTysFG ) where @@ -356,63 +356,48 @@ typesCantMatch prs = any (\(s,t) -> cant_match s t) prs %* * %************************************************************************ -Note [Unification and apartness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The workhorse function behind unification actually is testing for apartness, -not unification. Here, two types are apart if it is never possible to unify -them or any types they are safely coercible to.(* see below) There are three -possibilities here: +Note [Fine-grained unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" -- +no substitution to finite types makes these match. But, a substitution to +*infinite* types can unify these two types: [x |-> [[[...]]], y |-> [[[...]]] ]. +Why do we care? Consider these two type family instances: - - two types might be NotApart, which means a substitution can be found between - them, +type instance F x x = Int +type instance F [y] y = Bool - Example: (Either a Int) and (Either Bool b) are NotApart, with - [a |-> Bool, b |-> Int] +If we also have - - they might be MaybeApart, which means that we're not sure, but a substitution - cannot be found +type instance Looper = [Looper] - Example: Int and F a (for some type family F) are MaybeApart +then the instances potentially overlap. The solution is to use unification +over infinite terms. This is possible (see [1] for lots of gory details), but +a full algorithm is a little more power than we need. Instead, we make a +conservative approximation and just omit the occurs check. - - they might be SurelyApart, in which case we can guarantee that they never - unify +[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf - Example: (Either Int a) and (Either Bool b) are SurelyApart +tcUnifyTys considers an occurs-check problem as the same as general unification +failure. -In the NotApart case, the apartness finding function also returns a -substitution, which we can then use to unify the types. It is necessary for -the unification algorithm to depend on the apartness algorithm, because -apartness is finer-grained than unification. +tcUnifyTysFG ("fine-grained") returns one of three results: success, occurs-check +failure ("MaybeApart"), or general failure ("SurelyApart"). -Note [Unifying with type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We wish to separate out the case where unification fails on a type family -from other unification failure. What does "fail on a type family" look like? -According to the TyConApp invariant, a type family application must always -be in a TyConApp. This TyConApp may not be buried within the left-hand-side -of an AppTy. - -Furthermore, we wish to proceed with unification if we are unifying -(F a b) with (F Int Bool). Here, unification should succeed with -[a |-> Int, b |-> Bool]. So, here is what we do: - - - If we are unifying two TyConApps, check the heads for equality and - proceed iff they are equal. - - - Otherwise, if either (or both) type is a TyConApp headed by a type family, - we know they cannot fully unify. But, they might unify later, depending - on the type family. So, we return "maybeApart". +Note [The substitution in MaybeApart] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why? +Because consider unifying these: -Note that we never want to unify, say, (a Int) with (F Int), because doing so -leads to an unsaturated type family. So, we don't have to worry about any -unification between type families and AppTys. +(a, a, a) ~ (Int, F Bool, Bool) -But wait! There is one more possibility. What about nullary type families? -If G is a nullary type family, we *do* want to unify (a) with (G). This is -handled in uVar, which is triggered before we look at TyConApps. Ah. All is -well again. +If we go left-to-right, we start with [a |-> Int]. Then, on the middle terms, +we apply the subst we have so far and discover that Int is maybeApart from +F Bool. But, we can't stop there! Because if we continue, we discover that +Int is SurelyApart from Bool, and therefore the types are apart. This has +practical consequences for the ability for closed type family applications +to reduce. See test case indexed-types/should_compile/Overlap14. -Note [Apartness with skolems] +Note [Unifying with skolems] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we discover that two types unify if and only if a skolem variable is substituted, we can't properly unify the types. But, that skolem variable @@ -428,19 +413,25 @@ tcUnifyTys :: (TyVar -> BindFlag) -- second call to tcUnifyTys in FunDeps.checkClsFD -- tcUnifyTys bind_fn tys1 tys2 - | NotApart subst <- tcApartTys bind_fn tys1 tys2 + | Unifiable subst <- tcUnifyTysFG bind_fn tys1 tys2 = Just subst | otherwise = Nothing -data ApartResult = NotApart TvSubst -- the subst that unifies the types - | MaybeApart - | SurelyApart - -tcApartTys :: (TyVar -> BindFlag) - -> [Type] -> [Type] - -> ApartResult -tcApartTys bind_fn tys1 tys2 +-- This type does double-duty. It is used in the UM (unifier monad) and to +-- return the final result. +type UnifyResult = UnifyResultM TvSubst +data UnifyResultM a = Unifiable a -- the subst that unifies the types + | MaybeApart a -- the subst has as much as we know + -- it must be part of an most general unifier + -- See Note [The substitution in MaybeApart] + | SurelyApart + +-- See Note [Fine-grained unification] +tcUnifyTysFG :: (TyVar -> BindFlag) + -> [Type] -> [Type] + -> UnifyResult +tcUnifyTysFG bind_fn tys1 tys2 = initUM bind_fn $ do { subst <- unifyList emptyTvSubstEnv tys1 tys2 @@ -512,14 +503,8 @@ unify subst ty1 ty2 | Just ty1' <- tcView ty1 = unify subst ty1' ty2 unify subst ty1 ty2 | Just ty2' <- tcView ty2 = unify subst ty1 ty2' unify subst (TyConApp tyc1 tys1) (TyConApp tyc2 tys2) - | tyc1 == tyc2 = unify_tys subst tys1 tys2 - | isSynFamilyTyCon tyc1 || isSynFamilyTyCon tyc2 = maybeApart - --- See Note [Unifying with type families] -unify _ (TyConApp tyc _) _ - | isSynFamilyTyCon tyc = maybeApart -unify _ _ (TyConApp tyc _) - | isSynFamilyTyCon tyc = maybeApart + | tyc1 == tyc2 + = unify_tys subst tys1 tys2 unify subst (FunTy ty1a ty1b) (FunTy ty2a ty2b) = do { subst' <- unify subst ty1a ty2a @@ -607,13 +592,14 @@ uUnrefined subst tv1 ty2 (TyVarTy tv2) ; b2 <- tvBindFlag tv2 ; let ty1 = TyVarTy tv1 ; case (b1, b2) of - (Skolem, Skolem) -> maybeApart -- See Note [Apartness with skolems] + (Skolem, Skolem) -> maybeApart subst' -- See Note [Unification with skolems] (BindMe, _) -> return (extendVarEnv subst' tv1 ty2) (_, BindMe) -> return (extendVarEnv subst' tv2 ty1) } uUnrefined subst tv1 ty2 ty2' -- ty2 is not a type variable | tv1 `elemVarSet` niSubstTvSet subst (tyVarsOfType ty2') - = surelyApart -- Occurs check + = maybeApart subst -- Occurs check + -- See Note [Fine-grained unification] | otherwise = do { subst' <- unify subst k1 k2 ; bindTv subst' tv1 ty2 } -- Bind tyvar to the synonym if poss @@ -625,7 +611,7 @@ bindTv :: TvSubstEnv -> TyVar -> Type -> UM TvSubstEnv bindTv subst tv ty -- ty is not a type variable = do { b <- tvBindFlag tv ; case b of - Skolem -> maybeApart -- See Note [Apartness with skolems] + Skolem -> maybeApart subst -- See Note [Unification with skolems] BindMe -> return $ extendVarEnv subst tv ty } \end{code} @@ -652,33 +638,30 @@ data BindFlag %************************************************************************ \begin{code} -data UnifFailure = UFMaybeApart - | UFSurelyApart - newtype UM a = UM { unUM :: (TyVar -> BindFlag) - -> Either UnifFailure a } + -> UnifyResultM a } instance Monad UM where - return a = UM (\_tvs -> Right a) - fail _ = UM (\_tvs -> Left UFSurelyApart) -- failed pattern match + return a = UM (\_tvs -> Unifiable a) + fail _ = UM (\_tvs -> SurelyApart) -- failed pattern match m >>= k = UM (\tvs -> case unUM m tvs of - Right v -> unUM (k v) tvs - Left f -> Left f) - -initUM :: (TyVar -> BindFlag) -> UM TvSubst -> ApartResult -initUM badtvs um - = case unUM um badtvs of - Right subst -> NotApart subst - Left UFMaybeApart -> MaybeApart - Left UFSurelyApart -> SurelyApart + Unifiable v -> unUM (k v) tvs + MaybeApart v -> + case unUM (k v) tvs of + Unifiable v' -> MaybeApart v' + other -> other + SurelyApart -> SurelyApart) + +initUM :: (TyVar -> BindFlag) -> UM TvSubst -> UnifyResult +initUM badtvs um = unUM um badtvs tvBindFlag :: TyVar -> UM BindFlag -tvBindFlag tv = UM (\tv_fn -> Right (tv_fn tv)) +tvBindFlag tv = UM (\tv_fn -> Unifiable (tv_fn tv)) -maybeApart :: UM a -maybeApart = UM (\_tv_fn -> Left UFMaybeApart) +maybeApart :: TvSubstEnv -> UM TvSubstEnv +maybeApart subst = UM (\_tv_fn -> MaybeApart subst) surelyApart :: UM a -surelyApart = UM (\_tv_fn -> Left UFSurelyApart) +surelyApart = UM (\_tv_fn -> SurelyApart) \end{code} diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index e07577776a..d14c326d34 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -784,3 +784,144 @@ instance Binary FunctionOrData where 1 -> return IsData _ -> panic "Binary FunctionOrData" +instance Binary TupleSort where + put_ bh BoxedTuple = putByte bh 0 + put_ bh UnboxedTuple = putByte bh 1 + put_ bh ConstraintTuple = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return BoxedTuple + 1 -> do return UnboxedTuple + _ -> do return ConstraintTuple + +instance Binary Activation where + put_ bh NeverActive = do + putByte bh 0 + put_ bh AlwaysActive = do + putByte bh 1 + put_ bh (ActiveBefore aa) = do + putByte bh 2 + put_ bh aa + put_ bh (ActiveAfter ab) = do + putByte bh 3 + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do return NeverActive + 1 -> do return AlwaysActive + 2 -> do aa <- get bh + return (ActiveBefore aa) + _ -> do ab <- get bh + return (ActiveAfter ab) + +instance Binary InlinePragma where + put_ bh (InlinePragma a b c d) = do + put_ bh a + put_ bh b + put_ bh c + put_ bh d + + get bh = do + a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (InlinePragma a b c d) + +instance Binary RuleMatchInfo where + put_ bh FunLike = putByte bh 0 + put_ bh ConLike = putByte bh 1 + get bh = do + h <- getByte bh + if h == 1 then return ConLike + else return FunLike + +instance Binary InlineSpec where + put_ bh EmptyInlineSpec = putByte bh 0 + put_ bh Inline = putByte bh 1 + put_ bh Inlinable = putByte bh 2 + put_ bh NoInline = putByte bh 3 + + get bh = do h <- getByte bh + case h of + 0 -> return EmptyInlineSpec + 1 -> return Inline + 2 -> return Inlinable + _ -> return NoInline + +instance Binary DefMethSpec where + put_ bh NoDM = putByte bh 0 + put_ bh VanillaDM = putByte bh 1 + put_ bh GenericDM = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return NoDM + 1 -> return VanillaDM + _ -> return GenericDM + +instance Binary RecFlag where + put_ bh Recursive = do + putByte bh 0 + put_ bh NonRecursive = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do return Recursive + _ -> do return NonRecursive + +instance Binary OverlapFlag where + put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b + put_ bh (OverlapOk b) = putByte bh 1 >> put_ bh b + put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b + get bh = do + h <- getByte bh + b <- get bh + case h of + 0 -> return $ NoOverlap b + 1 -> return $ OverlapOk b + 2 -> return $ Incoherent b + _ -> panic ("get OverlapFlag " ++ show h) + +instance Binary FixityDirection where + put_ bh InfixL = do + putByte bh 0 + put_ bh InfixR = do + putByte bh 1 + put_ bh InfixN = do + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return InfixL + 1 -> do return InfixR + _ -> do return InfixN + +instance Binary Fixity where + put_ bh (Fixity aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (Fixity aa ab) + +instance Binary WarningTxt where + put_ bh (WarningTxt w) = do + putByte bh 0 + put_ bh w + put_ bh (DeprecatedTxt d) = do + putByte bh 1 + put_ bh d + + get bh = do + h <- getByte bh + case h of + 0 -> do w <- get bh + return (WarningTxt w) + _ -> do d <- get bh + return (DeprecatedTxt d) + diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs index 36b1b1e63e..25f98021f4 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.lhs @@ -120,6 +120,10 @@ import GHC.IO ( IO(..) ) import Foreign.Safe +#if STAGE >= 2 +import GHC.Conc.Sync (sharedCAF) +#endif + #if defined(__GLASGOW_HASKELL__) import GHC.Base ( unpackCString# ) #endif @@ -225,14 +229,63 @@ data FastStringTable = {-# UNPACK #-} !Int (MutableArray# RealWorld [FastString]) -{-# NOINLINE string_table #-} string_table :: IORef FastStringTable -string_table = - unsafePerformIO $ do - tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED [] s1# of - (# s2#, arr# #) -> - (# s2#, FastStringTable 0 arr# #) - newIORef tab +{-# NOINLINE string_table #-} +string_table = unsafePerformIO $ do + tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED [] s1# of + (# s2#, arr# #) -> + (# s2#, FastStringTable 0 arr# #) + ref <- newIORef tab + -- use the support wired into the RTS to share this CAF among all images of + -- libHSghc +#if STAGE < 2 + return ref +#else + sharedCAF ref getOrSetLibHSghcFastStringTable + +-- from the RTS; thus we cannot use this mechanism when STAGE<2; the previous +-- RTS might not have this symbol +foreign import ccall unsafe "getOrSetLibHSghcFastStringTable" + getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a) +#endif + +{- + +We include the FastString table in the `sharedCAF` mechanism because we'd like +FastStrings created by a Core plugin to have the same uniques as corresponding +strings created by the host compiler itself. For example, this allows plugins +to lookup known names (eg `mkTcOcc "MySpecialType"`) in the GlobalRdrEnv or +even re-invoke the parser. + +In particular, the following little sanity test was failing in a plugin +prototyping safe newtype-coercions: GHC.NT.Type.NT was imported, but could not +be looked up /by the plugin/. + + let rdrName = mkModuleName "GHC.NT.Type" `mkRdrQual` mkTcOcc "NT" + putMsgS $ showSDoc dflags $ ppr $ lookupGRE_RdrName rdrName $ mg_rdr_env guts + +`mkTcOcc` involves the lookup (or creation) of a FastString. Since the +plugin's FastString.string_table is empty, constructing the RdrName also +allocates new uniques for the FastStrings "GHC.NT.Type" and "NT". These +uniques are almost certainly unequal to the ones that the host compiler +originally assigned to those FastStrings. Thus the lookup fails since the +domain of the GlobalRdrEnv is affected by the RdrName's OccName's FastString's +unique. + +The old `reinitializeGlobals` mechanism is enough to provide the plugin with +read-access to the table, but it insufficient in the general case where the +plugin may allocate FastStrings. This mutates the supply for the FastStrings' +unique, and that needs to be propagated back to the compiler's instance of the +global variable. Such propagation is beyond the `reinitializeGlobals` +mechanism. + +Maintaining synchronization of the two instances of this global is rather +difficult because of the uses of `unsafePerformIO` in this module. Not +synchronizing them risks breaking the rather major invariant that two +FastStrings with the same unique have the same string. Thus we use the +lower-level `sharedCAF` mechanism that relies on Globals.c. + +-} lookupTbl :: FastStringTable -> Int -> IO [FastString] lookupTbl (FastStringTable _ arr#) (I# i#) = diff --git a/compiler/utils/Maybes.lhs b/compiler/utils/Maybes.lhs index 8a612fbb60..859908e266 100644 --- a/compiler/utils/Maybes.lhs +++ b/compiler/utils/Maybes.lhs @@ -14,6 +14,7 @@ module Maybes ( mapCatMaybes, allMaybes, firstJust, firstJusts, + whenIsJust, expectJust, maybeToBool, @@ -68,6 +69,10 @@ mapCatMaybes _ [] = [] mapCatMaybes f (x:xs) = case f x of Just y -> y : mapCatMaybes f xs Nothing -> mapCatMaybes f xs + +whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () +whenIsJust (Just x) f = f x +whenIsJust Nothing _ = return () \end{code} \begin{code} diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index bd2a955469..da8ffb3f10 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -90,6 +90,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Char import qualified Data.Map as M +import Data.Int import qualified Data.IntMap as IM import Data.Set (Set) import qualified Data.Set as Set @@ -421,7 +422,10 @@ rational :: Rational -> SDoc empty = docToSDoc $ Pretty.empty char c = docToSDoc $ Pretty.char c + text s = docToSDoc $ Pretty.text s +{-# INLINE text #-} -- Inline so that the RULE Pretty.text will fire + ftext s = docToSDoc $ Pretty.ftext s ptext s = docToSDoc $ Pretty.ptext s ztext s = docToSDoc $ Pretty.ztext s @@ -616,6 +620,12 @@ instance Outputable Bool where ppr True = ptext (sLit "True") ppr False = ptext (sLit "False") +instance Outputable Int32 where + ppr n = integer $ fromIntegral n + +instance Outputable Int64 where + ppr n = integer $ fromIntegral n + instance Outputable Int where ppr n = int n diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs index 213a63e0c8..617e691ddf 100644 --- a/compiler/utils/Platform.hs +++ b/compiler/utils/Platform.hs @@ -13,6 +13,7 @@ module Platform ( isARM, osElfTarget, platformUsesFrameworks, + platformBinariesAreStaticLibs, ) where @@ -135,3 +136,10 @@ osUsesFrameworks _ = False platformUsesFrameworks :: Platform -> Bool platformUsesFrameworks = osUsesFrameworks . platformOS +osBinariesAreStaticLibs :: OS -> Bool +osBinariesAreStaticLibs OSiOS = True +osBinariesAreStaticLibs _ = False + +platformBinariesAreStaticLibs :: Platform -> Bool +platformBinariesAreStaticLibs = osBinariesAreStaticLibs . platformOS + diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs index e4f748a05d..0c8e5fa1d0 100644 --- a/compiler/utils/Pretty.lhs +++ b/compiler/utils/Pretty.lhs @@ -557,7 +557,9 @@ isEmpty _ = False char c = textBeside_ (Chr c) (_ILIT(1)) Empty text s = case iUnbox (length s) of {sl -> textBeside_ (Str s) sl Empty} -{-# NOINLINE [1] text #-} -- Give the RULE a chance to fire +{-# NOINLINE [0] text #-} -- Give the RULE a chance to fire + -- It must wait till after phase 1 when + -- the unpackCString first is manifested ftext :: FastString -> Doc ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty} diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 680300abd4..862af99443 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -20,7 +20,7 @@ and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order of arguments of combining function. \begin{code} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveTraversable, GeneralizedNewtypeDeriving #-} {-# OPTIONS -Wall #-} module UniqFM ( diff --git a/compiler/utils/UniqSet.lhs b/compiler/utils/UniqSet.lhs index ccbd25a4ce..1653f2dc43 100644 --- a/compiler/utils/UniqSet.lhs +++ b/compiler/utils/UniqSet.lhs @@ -31,6 +31,7 @@ module UniqSet ( isEmptyUniqSet, lookupUniqSet, uniqSetToList, + partitionUniqSet ) where import UniqFM @@ -67,6 +68,7 @@ mapUniqSet :: (a -> b) -> UniqSet a -> UniqSet b elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool elemUniqSet_Directly :: Unique -> UniqSet a -> Bool filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a +partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a) sizeUniqSet :: UniqSet a -> Int isEmptyUniqSet :: UniqSet a -> Bool @@ -106,6 +108,7 @@ mapUniqSet = mapUFM elementOfUniqSet = elemUFM elemUniqSet_Directly = elemUFM_Directly filterUniqSet = filterUFM +partitionUniqSet = partitionUFM sizeUniqSet = sizeUFM isEmptyUniqSet = isNullUFM diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 90a2077c71..5c82c757aa 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -14,11 +14,11 @@ module Util ( -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, - zipLazy, stretchZipWith, + zipLazy, stretchZipWith, zipWithAndUnzip, unzipWith, - mapFst, mapSnd, + mapFst, mapSnd, chkAppend, mapAndUnzip, mapAndUnzip3, mapAccumL2, nOfThem, filterOut, partitionWith, splitEithers, @@ -259,6 +259,13 @@ splitEithers (e : es) = case e of Left x -> (x:xs, ys) Right y -> (xs, y:ys) where (xs,ys) = splitEithers es + +chkAppend :: [a] -> [a] -> [a] +-- Checks for the second arguemnt being empty +-- Used in situations where that situation is common +chkAppend xs ys + | null ys = xs + | otherwise = xs ++ ys \end{code} A paranoid @zip@ (and some @zipWith@ friends) that checks the lists @@ -344,6 +351,14 @@ mapAndUnzip3 f (x:xs) in (r1:rs1, r2:rs2, r3:rs3) +zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d]) +zipWithAndUnzip f (a:as) (b:bs) + = let (r1, r2) = f a b + (rs1, rs2) = zipWithAndUnzip f as bs + in + (r1:rs1, r2:rs2) +zipWithAndUnzip _ _ _ = ([],[]) + mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b]) mapAccumL2 f s1 s2 xs = (s1', s2', ys) where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of @@ -559,7 +574,15 @@ splitAtList (_:xs) (y:ys) = (y:ys', ys'') -- drop from the end of a list dropTail :: Int -> [a] -> [a] -dropTail n = reverse . drop n . reverse +-- Specification: dropTail n = reverse . drop n . reverse +-- Better implemention due to Joachim Breitner +-- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html +dropTail n xs + = go (drop n xs) xs + where + go (_:ys) (x:xs) = x : go ys xs + go _ _ = [] -- Stop when ys runs out + -- It'll always run out before xs does snocView :: [a] -> Maybe ([a],a) -- Split off the last element @@ -1088,7 +1111,7 @@ charToC w = hashString :: String -> Int32 hashString = foldl' f golden where f m c = fromIntegral (ord c) * magic + hashInt32 m - magic = 0xdeadbeef + magic = fromIntegral (0xdeadbeef :: Word32) golden :: Int32 golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32 diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index b939f4beb6..012ae37039 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -27,7 +27,6 @@ import DynFlags import Outputable import Util ( zipLazy ) import MonadUtils -import FamInstEnv ( toBranchedFamInst ) import Control.Monad @@ -93,7 +92,7 @@ vectModule guts@(ModGuts { mg_tcs = tycons -- and dfuns , mg_binds = Rec tc_binds : (binds_top ++ binds_imp) , mg_fam_inst_env = fam_inst_env - , mg_fam_insts = fam_insts ++ (map toBranchedFamInst new_fam_insts) + , mg_fam_insts = fam_insts ++ new_fam_insts } } diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs index 2d415aab36..3358ceafab 100644 --- a/compiler/vectorise/Vectorise/Env.hs +++ b/compiler/vectorise/Vectorise/Env.hs @@ -174,7 +174,7 @@ extendImportedVarsEnv ps genv -- |Extend the list of type family instances. -- -extendFamEnv :: [FamInst Unbranched] -> GlobalEnv -> GlobalEnv +extendFamEnv :: [FamInst] -> GlobalEnv -> GlobalEnv extendFamEnv new genv = genv { global_fam_inst_env = (g_fam_inst, extendFamInstEnvList l_fam_inst new) } where (g_fam_inst, l_fam_inst) = global_fam_inst_env genv diff --git a/compiler/vectorise/Vectorise/Generic/PADict.hs b/compiler/vectorise/Vectorise/Generic/PADict.hs index f70e796daa..7e70f2dd11 100644 --- a/compiler/vectorise/Vectorise/Generic/PADict.hs +++ b/compiler/vectorise/Vectorise/Generic/PADict.hs @@ -68,37 +68,35 @@ buildPADict vect_tc prepr_ax pdata_tc pdatas_tc repr ; pr_cls <- builtin prClass ; return $ mkClassPred pr_cls [r] } - ; super_tys <- sequence [mk_super_ty | not (null tvs)] + ; super_tys <- sequence [mk_super_ty | not (null tvs)] ; super_args <- mapM (newLocalVar (fsLit "pr")) super_tys - ; let all_args = super_args ++ args + ; let val_args = super_args ++ args + all_args = tvs ++ val_args -- ...it is constant otherwise ; super_consts <- sequence [prDictOfPReprInstTyCon inst_ty prepr_ax [] | null tvs] -- Get ids for each of the methods in the dictionary, including superclass ; paMethodBuilders <- buildPAScAndMethods - ; method_ids <- mapM (method all_args dfun_name) paMethodBuilders + ; method_ids <- mapM (method val_args dfun_name) paMethodBuilders -- Expression to build the dictionary. ; pa_dc <- builtin paDataCon - ; let dict = mkLams (tvs ++ all_args) - $ mkConApp pa_dc - $ Type inst_ty - : map Var super_args ++ super_consts -- the superclass dictionary is either lambda-bound or constant - ++ map (method_call all_args) method_ids + ; let dict = mkLams all_args (mkConApp pa_dc con_args) + con_args = Type inst_ty + : map Var super_args -- the superclass dictionary is either + ++ super_consts -- lambda-bound or constant + ++ map (method_call val_args) method_ids -- Build the type of the dictionary function. ; pa_cls <- builtin paClass ; let dfun_ty = mkForAllTys tvs - $ mkFunTys (map varType all_args) + $ mkFunTys (map varType val_args) (mkClassPred pa_cls [inst_ty]) -- Set the unfolding for the inliner. ; raw_dfun <- newExportedVar dfun_name dfun_ty - ; let dfun_unf = mkDFunUnfolding dfun_ty $ - map (const $ DFunLamArg 0) super_args - ++ map DFunPolyArg super_consts - ++ map (DFunPolyArg . Var) method_ids + ; let dfun_unf = mkDFunUnfolding all_args pa_dc con_args dfun = raw_dfun `setIdUnfolding` dfun_unf `setInlinePragma` dfunInlinePragma diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs index af815c9294..269119c6dd 100644 --- a/compiler/vectorise/Vectorise/Generic/PAMethods.hs +++ b/compiler/vectorise/Vectorise/Generic/PAMethods.hs @@ -32,13 +32,13 @@ import Control.Monad import Outputable -buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM (FamInst Unbranched) +buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst buildPReprTyCon orig_tc vect_tc repr = do name <- mkLocalisedName mkPReprTyConOcc (tyConName orig_tc) rhs_ty <- sumReprType repr prepr_tc <- builtin preprTyCon let axiom = mkSingleCoAxiom name tyvars prepr_tc instTys rhs_ty - liftDs $ newFamInst SynFamilyInst False axiom + liftDs $ newFamInst SynFamilyInst axiom where tyvars = tyConTyVars vect_tc instTys = [mkTyConApp vect_tc . mkTyVarTys $ tyConTyVars vect_tc] @@ -218,7 +218,7 @@ buildToArrPRepr vect_tc repr_co pdata_tc _ r pdata_co <- mkBuiltinCo pdataTyCon let co = mkAppCo pdata_co . mkSymCo - $ mkUnbranchedAxInstCo repr_co ty_args + $ mkUnbranchedAxInstCo Nominal repr_co ty_args scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg) @@ -282,7 +282,7 @@ buildFromArrPRepr vect_tc repr_co pdata_tc _ r pdata_co <- mkBuiltinCo pdataTyCon let co = mkAppCo pdata_co - $ mkUnbranchedAxInstCo repr_co var_tys + $ mkUnbranchedAxInstCo Nominal repr_co var_tys let scrut = mkCast (Var arg) co @@ -368,7 +368,7 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r pdatas_co <- mkBuiltinCo pdatasTyCon let co = mkAppCo pdatas_co . mkSymCo - $ mkUnbranchedAxInstCo repr_co ty_args + $ mkUnbranchedAxInstCo Nominal repr_co ty_args let scrut = unwrapFamInstScrut pdatas_tc ty_args (Var varg) (vars, result) <- to_sum r @@ -458,7 +458,7 @@ buildFromArrPReprs vect_tc repr_co _ pdatas_tc r -- Build the coercion between PRepr and the instance type pdatas_co <- mkBuiltinCo pdatasTyCon let co = mkAppCo pdatas_co - $ mkUnbranchedAxInstCo repr_co var_tys + $ mkUnbranchedAxInstCo Nominal repr_co var_tys let scrut = mkCast (Var varg) co diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs index 893f1559be..37358c9bdf 100644 --- a/compiler/vectorise/Vectorise/Generic/PData.hs +++ b/compiler/vectorise/Vectorise/Generic/PData.hs @@ -14,7 +14,6 @@ import Vectorise.Generic.Description import Vectorise.Utils import Vectorise.Env( GlobalEnv( global_fam_inst_env ) ) -import Coercion( mkSingleCoAxiom ) import BasicTypes import BuildTyCl import DataCon @@ -31,7 +30,7 @@ import Control.Monad -- buildPDataTyCon ------------------------------------------------------------ -- | Build the PData instance tycon for a given type constructor. -buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM (FamInst Unbranched) +buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst buildPDataTyCon orig_tc vect_tc repr = fixV $ \fam_inst -> do let repr_tc = dataFamInstRepTyCon fam_inst @@ -42,7 +41,7 @@ buildPDataTyCon orig_tc vect_tc repr where orig_name = tyConName orig_tc -buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM (FamInst Unbranched) +buildDataFamInst :: Name -> TyCon -> TyCon -> AlgTyConRhs -> VM FamInst buildDataFamInst name' fam_tc vect_tc rhs = do { axiom_name <- mkDerivedName mkInstTyCoOcc name' @@ -53,6 +52,7 @@ buildDataFamInst name' fam_tc vect_tc rhs pat_tys = [mkTyConApp vect_tc tys'] rep_tc = buildAlgTyCon name' tyvars' + (map (const Nominal) tyvars') Nothing [] -- no stupid theta rhs @@ -60,7 +60,7 @@ buildDataFamInst name' fam_tc vect_tc rhs False -- Not promotable False -- not GADT syntax (FamInstTyCon ax fam_tc pat_tys) - ; liftDs $ newFamInst (DataFamilyInst rep_tc) False ax } + ; liftDs $ newFamInst (DataFamilyInst rep_tc) ax } where tyvars = tyConTyVars vect_tc rec_flag = boolToRecFlag (isRecursiveTyCon vect_tc) @@ -92,7 +92,7 @@ buildPDataDataCon orig_name vect_tc repr_tc repr -- buildPDatasTyCon ----------------------------------------------------------- -- | Build the PDatas instance tycon for a given type constructor. -buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM (FamInst Unbranched) +buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst buildPDatasTyCon orig_tc vect_tc repr = fixV $ \fam_inst -> do let repr_tc = dataFamInstRepTyCon fam_inst diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs index ceb62eef80..84b29ceb61 100644 --- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs +++ b/compiler/vectorise/Vectorise/Monad/InstEnv.hs @@ -67,7 +67,7 @@ lookupInst cls tys -- lookupFamInst :: TyCon -> [Type] -> VM FamInstMatch lookupFamInst tycon tys - = ASSERT( isFamilyTyCon tycon ) + = ASSERT( isOpenFamilyTyCon tycon ) do { instEnv <- readGEnv global_fam_inst_env ; case lookupFamInstEnv instEnv tycon tys of [match] -> return match diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 0ae0f936b3..34008efbbd 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -162,7 +162,7 @@ vectTypeEnv :: [TyCon] -- Type constructors defined in this mo -> [CoreVect] -- All 'VECTORISE [SCALAR] type' declarations in this module -> [CoreVect] -- All 'VECTORISE class' declarations in this module -> VM ( [TyCon] -- old TyCons ++ new TyCons - , [FamInst Unbranched] -- New type family instances. + , [FamInst] -- New type family instances. , [(Var, CoreExpr)]) -- New top level bindings. vectTypeEnv tycons vectTypeDecls vectClassDecls = do { traceVt "** vectTypeEnv" $ ppr tycons @@ -354,7 +354,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls origName = tyConName origTyCon vectName = tyConName vectTyCon - mkSyn canonName ty = mkSynTyCon canonName (typeKind ty) [] (SynonymTyCon ty) NoParentTyCon + mkSyn canonName ty = mkSynTyCon canonName (typeKind ty) [] [] (SynonymTyCon ty) NoParentTyCon defDataCons | isAbstract = return () diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs index 588cd39ec0..935ea32c69 100644 --- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs +++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs @@ -62,6 +62,7 @@ vectTyConDecl tycon name' False -- include unfoldings on dictionary selectors name' -- new name: "V:Class" (tyConTyVars tycon) -- keep original type vars + (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety theta' -- superclasses (snd . classTvsFds $ cls) -- keep the original functional dependencies [] -- no associated types (for the moment) @@ -100,6 +101,7 @@ vectTyConDecl tycon name' ; return $ buildAlgTyCon name' -- new name (tyConTyVars tycon) -- keep original type vars + (map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety Nothing [] -- no stupid theta rhs' -- new constructor defs diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs index d088f45355..cb7b34e36a 100644 --- a/compiler/vectorise/Vectorise/Utils/Base.hs +++ b/compiler/vectorise/Vectorise/Utils/Base.hs @@ -39,8 +39,6 @@ import DataCon import MkId import DynFlags import FastString -import Util -import Panic #include "HsVersions.h" @@ -130,12 +128,12 @@ splitPrimTyCon ty -- Coercion Construction ----------------------------------------------------- --- |Make a coersion to some builtin type. +-- |Make a representational coersion to some builtin type. -- mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion mkBuiltinCo get_tc = do { tc <- builtin get_tc - ; return $ mkTyConAppCo tc [] + ; return $ mkTyConAppCo Representational tc [] } @@ -211,10 +209,8 @@ pdataReprTyCon :: Type -> VM (TyCon, [Type]) pdataReprTyCon ty = do { FamInstMatch { fim_instance = famInst - , fim_index = index , fim_tys = tys } <- builtin pdataTyCon >>= (`lookupFamInst` [ty]) - ; ASSERT( index == 0 ) - return (dataFamInstRepTyCon famInst, tys) + ; return (dataFamInstRepTyCon famInst, tys) } -- |Get the representation tycon of the 'PData' data family for a given type constructor. diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs index 8029dfb466..01fbede4bd 100644 --- a/compiler/vectorise/Vectorise/Utils/PADict.hs +++ b/compiler/vectorise/Vectorise/Utils/PADict.hs @@ -119,7 +119,7 @@ prDictOfPReprInst :: Type -> VM CoreExpr prDictOfPReprInst ty = do { (FamInstMatch { fim_instance = prepr_fam, fim_tys = prepr_args }) <- preprSynTyCon ty - ; prDictOfPReprInstTyCon ty (famInstAxiom (toUnbranchedFamInst prepr_fam)) prepr_args + ; prDictOfPReprInstTyCon ty (famInstAxiom prepr_fam) prepr_args } -- |Given a type @ty@, its PRepr synonym tycon and its type arguments, @@ -145,7 +145,7 @@ prDictOfPReprInstTyCon _ty prepr_ax prepr_args pr_co <- mkBuiltinCo prTyCon let co = mkAppCo pr_co $ mkSymCo - $ mkUnbranchedAxInstCo prepr_ax prepr_args + $ mkUnbranchedAxInstCo Nominal prepr_ax prepr_args return $ mkCast dict co -- |Get the PR dictionary for a type. The argument must be a representation diff --git a/configure.ac b/configure.ac index 9d83660519..8d8136f756 100644 --- a/configure.ac +++ b/configure.ac @@ -328,6 +328,7 @@ then CC="${mingwbin}gcc.exe" LD="${mingwbin}ld.exe" NM="${mingwbin}nm.exe" + RANLIB="${mingwbin}ranlib.exe" OBJDUMP="${mingwbin}objdump.exe" fp_prog_ar="${mingwbin}ar.exe" @@ -553,8 +554,6 @@ dnl ** look to see if we have a C compiler using an llvm back end. dnl FP_CC_LLVM_BACKEND -FP_PROG_LD_HashSize31 -FP_PROG_LD_ReduceMemoryOverheads FP_PROG_LD_IS_GNU FP_PROG_LD_BUILD_ID FP_PROG_LD_NO_COMPACT_UNWIND @@ -901,8 +900,7 @@ if grep ' ' compiler/ghc.cabal.in 2>&1 >/dev/null; then AC_MSG_ERROR([compiler/ghc.cabal.in contains tab characters; please remove them]) fi -AC_CONFIG_FILES([mk/config.mk mk/install.mk mk/project.mk compiler/ghc.cabal ghc/ghc-bin.cabal utils/runghc/runghc.cabal ghc.spec settings docs/users_guide/ug-book.xml docs/users_guide/ug-ent.xml docs/index.html libraries/prologue.txt distrib/ghc.iss distrib/configure.ac]) -AC_CONFIG_COMMANDS([mk/stamp-h],[echo timestamp > mk/stamp-h]) +AC_CONFIG_FILES([mk/config.mk mk/install.mk mk/project.mk compiler/ghc.cabal ghc/ghc-bin.cabal utils/runghc/runghc.cabal settings docs/users_guide/ug-book.xml docs/users_guide/ug-ent.xml docs/index.html libraries/prologue.txt distrib/configure.ac]) AC_OUTPUT # We got caught by diff --git a/distrib/compare/Utils.hs b/distrib/compare/Utils.hs index 720f533aaa..bc4fd204fd 100644 --- a/distrib/compare/Utils.hs +++ b/distrib/compare/Utils.hs @@ -11,11 +11,15 @@ die :: Errors -> IO a die errs = do mapM_ (hPutStrLn stderr) errs exitFailure +warn :: Errors -> IO () +warn warnings = mapM_ (hPutStrLn stderr) warnings + dieOnErrors :: Either Errors a -> IO a dieOnErrors (Left errs) = die errs dieOnErrors (Right x) = return x type Errors = [String] +type Warnings = [String] maybeRead :: Read a => String -> Maybe a maybeRead str = case reads str of diff --git a/distrib/compare/compare.hs b/distrib/compare/compare.hs index 23b983f0ac..81055c2826 100644 --- a/distrib/compare/compare.hs +++ b/distrib/compare/compare.hs @@ -52,7 +52,8 @@ doDirectory ignoreSizeChanges p1 p2 mkFileInfo fp@('g':'h':'c':'-':x:xs) | isDigit x = return [(("ghc-", "VERSION", dropWhile isVersionChar xs), fp)] | otherwise = die ["No version number in " ++ show fp] - mkFileInfo fp = die ["Unrecognised filename " ++ show fp] + mkFileInfo fp = do warn ["Unrecognised filename " ++ show fp] + return [] fss1' <- mapM mkFileInfo fs1 fss2' <- mapM mkFileInfo fs2 let fs1' = sort $ concat fss1' diff --git a/distrib/configure.ac.in b/distrib/configure.ac.in index 6b20f849d4..4a6944fe17 100644 --- a/distrib/configure.ac.in +++ b/distrib/configure.ac.in @@ -72,8 +72,6 @@ AC_SUBST([LdCmd]) FP_GCC_VERSION AC_PROG_CPP -FP_PROG_LD_HashSize31 -FP_PROG_LD_ReduceMemoryOverheads FP_PROG_LD_IS_GNU FP_PROG_LD_BUILD_ID FP_PROG_LD_NO_COMPACT_UNWIND diff --git a/distrib/ghc.iss.in b/distrib/ghc.iss.in deleted file mode 100644 index 151fefcfee..0000000000 --- a/distrib/ghc.iss.in +++ /dev/null @@ -1,97 +0,0 @@ -; Inno Setup documentation: http://www.jrsoftware.org/ishelp/ - -[Setup] -AppName=GHC -AppVerName=GHC @ProjectVersion@ -DefaultDirName={sd}\ghc\ghc-@ProjectVersion@ -UsePreviousAppDir=no -DefaultGroupName=GHC -UninstallDisplayIcon={app}\bin\ghci.exe -Compression=lzma -SolidCompression=yes -PrivilegesRequired=none -ChangesAssociations=yes -ChangesEnvironment=yes -LicenseFile=distrib/windows-installer-licences.txt - -; tasks can be disabled selectively -[Tasks] -Name: fileassoc; Description: "Associate with .hs/.lhs files" -Name: fileassoc\default; Description: "Make this version of GHCi the default" -Name: fileassoc\addon; Description: "Add versioned GHCi to right-click menu" -Name: fileassoc\icon; Description: "Add icon" -Name: path; Description: "Add bin directories to PATH" - -; install main payload, license file and icon -[Files] -Source: "bindistprep\ghc-@ProjectVersion@\*"; DestDir: "{app}"; Flags: recursesubdirs -Source: "distrib\windows-installer-licences.txt"; DestDir: "{app}\doc" -Source: "distrib\hsicon.ico"; DestDir: "{app}\icons" - -; Start Menu shortcuts -[Icons] -Name: "{group}\@ProjectVersion@\GHCi"; Filename: "{app}\bin\ghci.exe"; WorkingDir: "{app}\bin" -Name: "{group}\@ProjectVersion@\GHC Documentation"; Filename: "{app}\doc\html\index.html" -Name: "{group}\@ProjectVersion@\GHC Library Documentation"; Filename: "{app}\doc\html\libraries\index.html" -Name: "{group}\@ProjectVersion@\GHC Flag Reference"; Filename: "{app}\doc\html\users_guide\flag-reference.html" - -[Registry] -; set up file associations -; this does _not_ entirely follow the "play nice" proposal (cf. ticket #916) -; future version should -Root: HKCR; Subkey: ".hs"; ValueType: string; ValueName: ""; ValueData: "ghc_haskell"; Flags: uninsdeletevalue; Tasks: fileassoc -Root: HKCR; Subkey: ".lhs"; ValueType: string; ValueName: ""; ValueData: "ghc_haskell"; Flags: uninsdeletevalue; Tasks: fileassoc -Root: HKCR; Subkey: "ghc_haskell"; ValueType: string; ValueName: ""; ValueData: "Haskell Source File"; Flags: uninsdeletekeyifempty; Tasks: fileassoc - -; make this GHCi the default action -Root: HKCR; Subkey: "ghc_haskell\shell\open\command"; ValueType: string; ValueName: ""; ValueData: """{app}\bin\ghci.exe"" ""%1"""; Flags: uninsdeletevalue; Tasks: fileassoc\default - -; add versioned GHCi entry to right-click menu -Root: HKCR; Subkey: "ghc_haskell\shell\Open with GHCi @ProjectVersion@"; ValueType: none; ValueName: ""; ValueData: ""; Flags: uninsdeletekey; Tasks: fileassoc\addon -Root: HKCR; Subkey: "ghc_haskell\shell\Open with GHCi @ProjectVersion@\command"; ValueType: string; ValueName: ""; ValueData: """{app}\bin\ghci.exe"" ""%1"""; Flags: uninsdeletevalue; Tasks: fileassoc\addon - -; associate file type with icon -Root: HKCR; Subkey: "ghc_haskell\DefaultIcon"; ValueType: string; ValueName: ""; ValueData: "{app}\icons\hsicon.ico"; Tasks: fileassoc\icon - -; these flags were always set in the past, by the installer -; some programs may rely on them to find GHC -Root: HKCU; Subkey: "Software\Haskell\GHC\ghc-@ProjectVersion@"; ValueType: string; ValueName: "InstallDir"; ValueData: "{app}"; Flags: uninsdeletekey -Root: HKCU; Subkey: "Software\Haskell\GHC"; ValueType: string; ValueName: "InstallDir"; ValueData: "{app}"; Flags: uninsdeletevalue - -; set the PATH variable, for both GHC and Cabal -Root: HKCU; Subkey: "Environment"; ValueName: "Path"; ValueType: "string"; ValueData: "{app}\bin;{olddata}"; Check: NotOnPathAlready('{app}\bin'); Flags: preservestringtype; Tasks: path -Root: HKCU; Subkey: "Environment"; ValueName: "Path"; ValueType: "string"; ValueData: "{pf}\Haskell\bin;{olddata}"; Check: NotOnPathAlready('{pf}\Haskell\bin'); Flags: preservestringtype; Tasks: path - - -; stolen from Gtk2Hs, I'm sure they like us :-) -; @dcoutts++ -[Code] - -function NotOnPathAlready(NewValue : String): Boolean; -var - Path: String; -begin - // Log('Checking if Gtk2Hs\bin dir is already on the %PATH%'); - if RegQueryStringValue(HKEY_CURRENT_USER, 'Environment', 'Path', Path) then - begin // Successfully read the value - // Log('HKCU\Environment\PATH = ' + Path); - NewValue := ExpandConstant(NewValue); - // Log('Looking for Gtk2Hs\bin dir in %PATH%: ' + BinDir + ' in ' + Path); - if Pos(LowerCase(NewValue), Lowercase(Path)) = 0 then - begin - // Log('Did not find Gtk2Hs\bin dir in %PATH% so will add it'); - Result := True; - end - else - begin - // Log('Found Gtk2Hs bin dir in %PATH% so will not add it again'); - Result := False; - end - end - else // The key probably doesn't exist - begin - // Log('Could not access HKCU\Environment\PATH so assume it is ok to add it'); - Result := True; - end; -end; - diff --git a/distrib/windows-installer-licences.txt b/distrib/windows-installer-licences.txt deleted file mode 100644 index b7a5b03430..0000000000 --- a/distrib/windows-installer-licences.txt +++ /dev/null @@ -1,704 +0,0 @@ - -Components of this bundle are distributed under various licences, -including the following: - ------------------------------------------------------------------------- - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. -3. Neither the names of the copyright holders nor the names of its - contributors may be used to endorse or promote products derived from - this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED -TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - ------------------------------------------------------------------------- - -The authors intend this Report to belong to the entire Haskell -community, and so we grant permission to copy and distribute it for -any purpose, provided that it is reproduced in its entirety, -including this Notice. Modified versions of this Report may also be -copied and distributed for any purpose, provided that the modified -version is clearly presented as such, and that it does not claim to -be a definition of the Haskell 98 Language or the Haskell 98 Foreign -Function Interface. - ------------------------------------------------------------------------- - -Permission is hereby granted, free of charge, to any person obtaining -a copy of this software and associated documentation files (the -``Software''), to deal in the Software without restriction, including -without limitation the rights to use, copy, modify, merge, publish, -distribute, sublicense, and/or sell copies of the Software, and to -permit persons to whom the Software is furnished to do so, subject to -the following conditions: - -The above copyright notice and this permission notice shall be included -in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, -EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY -CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, -TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - ------------------------------------------------------------------------- - - The "Artistic License" - - Preamble - -The intent of this document is to state the conditions under which a -Package may be copied, such that the Copyright Holder maintains some -semblance of artistic control over the development of the package, -while giving the users of the package the right to use and distribute -the Package in a more-or-less customary fashion, plus the right to make -reasonable modifications. - -Definitions: - - "Package" refers to the collection of files distributed by the - Copyright Holder, and derivatives of that collection of files - created through textual modification. - - "Standard Version" refers to such a Package if it has not been - modified, or has been modified in accordance with the wishes - of the Copyright Holder as specified below. - - "Copyright Holder" is whoever is named in the copyright or - copyrights for the package. - - "You" is you, if you're thinking about copying or distributing - this Package. - - "Reasonable copying fee" is whatever you can justify on the - basis of media cost, duplication charges, time of people involved, - and so on. (You will not be required to justify it to the - Copyright Holder, but only to the computing community at large - as a market that must bear the fee.) - - "Freely Available" means that no fee is charged for the item - itself, though there may be fees involved in handling the item. - It also means that recipients of the item may redistribute it - under the same conditions they received it. - -1. You may make and give away verbatim copies of the source form of the -Standard Version of this Package without restriction, provided that you -duplicate all of the original copyright notices and associated disclaimers. - -2. You may apply bug fixes, portability fixes and other modifications -derived from the Public Domain or from the Copyright Holder. A Package -modified in such a way shall still be considered the Standard Version. - -3. You may otherwise modify your copy of this Package in any way, provided -that you insert a prominent notice in each changed file stating how and -when you changed that file, and provided that you do at least ONE of the -following: - - a) place your modifications in the Public Domain or otherwise make them - Freely Available, such as by posting said modifications to Usenet or - an equivalent medium, or placing the modifications on a major archive - site such as uunet.uu.net, or by allowing the Copyright Holder to include - your modifications in the Standard Version of the Package. - - b) use the modified Package only within your corporation or organization. - - c) rename any non-standard executables so the names do not conflict - with standard executables, which must also be provided, and provide - a separate manual page for each non-standard executable that clearly - documents how it differs from the Standard Version. - - d) make other distribution arrangements with the Copyright Holder. - -4. You may distribute the programs of this Package in object code or -executable form, provided that you do at least ONE of the following: - - a) distribute a Standard Version of the executables and library files, - together with instructions (in the manual page or equivalent) on where - to get the Standard Version. - - b) accompany the distribution with the machine-readable source of - the Package with your modifications. - - c) give non-standard executables non-standard names, and clearly - document the differences in manual pages (or equivalent), together - with instructions on where to get the Standard Version. - - d) make other distribution arrangements with the Copyright Holder. - -5. You may charge a reasonable copying fee for any distribution of this -Package. You may charge any fee you choose for support of this -Package. You may not charge a fee for this Package itself. However, -you may distribute this Package in aggregate with other (possibly -commercial) programs as part of a larger (possibly commercial) software -distribution provided that you do not advertise this Package as a -product of your own. You may embed this Package's interpreter within -an executable of yours (by linking); this shall be construed as a mere -form of aggregation, provided that the complete Standard Version of the -interpreter is so embedded. - -6. The scripts and library files supplied as input to or produced as -output from the programs of this Package do not automatically fall -under the copyright of this Package, but belong to whoever generated -them, and may be sold commercially, and may be aggregated with this -Package. If such scripts or library files are aggregated with this -Package via the so-called "undump" or "unexec" methods of producing a -binary executable image, then distribution of such an image shall -neither be construed as a distribution of this Package nor shall it -fall under the restrictions of Paragraphs 3 and 4, provided that you do -not represent such an executable image as a Standard Version of this -Package. - -7. C subroutines (or comparably compiled subroutines in other -languages) supplied by you and linked into this Package in order to -emulate subroutines and variables of the language defined by this -Package shall not be considered part of this Package, but are the -equivalent of input as in Paragraph 6, provided these subroutines do -not change the language in any way that would cause it to fail the -regression tests for the language. - -8. Aggregation of this Package with a commercial distribution is always -permitted provided that the use of this Package is embedded; that is, -when no overt attempt is made to make this Package's interfaces visible -to the end user of the commercial distribution. Such use shall not be -construed as a distribution of this Package. - -9. The name of the Copyright Holder may not be used to endorse or promote -products derived from this software without specific prior written permission. - -10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED -WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. - - The End - ------------------------------------------------------------------------- - - GNU GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1989, 1991 Free Software Foundation, Inc., - 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Lesser General Public License instead.) You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must show them these terms so they know their -rights. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that redistributors of a free -program will individually obtain patent licenses, in effect making the -program proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not licensed at all. - - The precise terms and conditions for copying, distribution and -modification follow. - - GNU GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License applies to any program or other work which contains -a notice placed by the copyright holder saying it may be distributed -under the terms of this General Public License. The "Program", below, -refers to any such program or work, and a "work based on the Program" -means either the Program or any derivative work under copyright law: -that is to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into another -language. (Hereinafter, translation is included without limitation in -the term "modification".) Each licensee is addressed as "you". - -Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running the Program is not restricted, and the output from the Program -is covered only if its contents constitute a work based on the -Program (independent of having been made by running the Program). -Whether that is true depends on what the Program does. - - 1. You may copy and distribute verbatim copies of the Program's -source code as you receive it, in any medium, provided that you -conspicuously and appropriately publish on each copy an appropriate -copyright notice and disclaimer of warranty; keep intact all the -notices that refer to this License and to the absence of any warranty; -and give any other recipients of the Program a copy of this License -along with the Program. - -You may charge a fee for the physical act of transferring a copy, and -you may at your option offer warranty protection in exchange for a fee. - - 2. You may modify your copy or copies of the Program or any portion -of it, thus forming a work based on the Program, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) You must cause the modified files to carry prominent notices - stating that you changed the files and the date of any change. - - b) You must cause any work that you distribute or publish, that in - whole or in part contains or is derived from the Program or any - part thereof, to be licensed as a whole at no charge to all third - parties under the terms of this License. - - c) If the modified program normally reads commands interactively - when run, you must cause it, when started running for such - interactive use in the most ordinary way, to print or display an - announcement including an appropriate copyright notice and a - notice that there is no warranty (or else, saying that you provide - a warranty) and that users may redistribute the program under - these conditions, and telling the user how to view a copy of this - License. (Exception: if the Program itself is interactive but - does not normally print such an announcement, your work based on - the Program is not required to print an announcement.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Program, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Program, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Program. - -In addition, mere aggregation of another work not based on the Program -with the Program (or with a work based on the Program) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may copy and distribute the Program (or a work based on it, -under Section 2) in object code or executable form under the terms of -Sections 1 and 2 above provided that you also do one of the following: - - a) Accompany it with the complete corresponding machine-readable - source code, which must be distributed under the terms of Sections - 1 and 2 above on a medium customarily used for software interchange; or, - - b) Accompany it with a written offer, valid for at least three - years, to give any third party, for a charge no more than your - cost of physically performing source distribution, a complete - machine-readable copy of the corresponding source code, to be - distributed under the terms of Sections 1 and 2 above on a medium - customarily used for software interchange; or, - - c) Accompany it with the information you received as to the offer - to distribute corresponding source code. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form with such - an offer, in accord with Subsection b above.) - -The source code for a work means the preferred form of the work for -making modifications to it. For an executable work, complete source -code means all the source code for all modules it contains, plus any -associated interface definition files, plus the scripts used to -control compilation and installation of the executable. However, as a -special exception, the source code distributed need not include -anything that is normally distributed (in either source or binary -form) with the major components (compiler, kernel, and so on) of the -operating system on which the executable runs, unless that component -itself accompanies the executable. - -If distribution of executable or object code is made by offering -access to copy from a designated place, then offering equivalent -access to copy the source code from the same place counts as -distribution of the source code, even though third parties are not -compelled to copy the source along with the object code. - - 4. You may not copy, modify, sublicense, or distribute the Program -except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense or distribute the Program is -void, and will automatically terminate your rights under this License. -However, parties who have received copies, or rights, from you under -this License will not have their licenses terminated so long as such -parties remain in full compliance. - - 5. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Program or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Program (or any work based on the -Program), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Program or works based on it. - - 6. Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the -original licensor to copy, distribute or modify the Program subject to -these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - - 7. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Program at all. For example, if a patent -license would not permit royalty-free redistribution of the Program by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Program. - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply and the section as a whole is intended to apply in other -circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system, which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 8. If the distribution and/or use of the Program is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Program under this License -may add an explicit geographical distribution limitation excluding -those countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - - 9. The Free Software Foundation may publish revised and/or new versions -of the General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - -Each version is given a distinguishing version number. If the Program -specifies a version number of this License which applies to it and "any -later version", you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -this License, you may choose any version ever published by the Free Software -Foundation. - - 10. If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - - NO WARRANTY - - 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED -OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS -TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - - 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, -INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING -OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED -TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY -YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER -PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - <one line to give the program's name and a brief idea of what it does.> - Copyright (C) <year> <name of author> - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License along - with this program; if not, write to the Free Software Foundation, Inc., - 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - -Also add information on how to contact you by electronic and paper mail. - -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - - Gnomovision version 69, Copyright (C) year name of author - Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, the commands you use may -be called something other than `show w' and `show c'; they could even be -mouse-clicks or menu items--whatever suits your program. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the program, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the program - `Gnomovision' (which makes passes at compilers) written by James Hacker. - - <signature of Ty Coon>, 1 April 1989 - Ty Coon, President of Vice - -This General Public License does not permit incorporating your program into -proprietary programs. If your program is a subroutine library, you may -consider it more useful to permit linking proprietary applications with the -library. If this is what you want to do, use the GNU Lesser General -Public License instead of this License. - ------------------------------------------------------------------------- - - GNU LESSER GENERAL PUBLIC LICENSE - Version 3, 29 June 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/> - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - - This version of the GNU Lesser General Public License incorporates -the terms and conditions of version 3 of the GNU General Public -License, supplemented by the additional permissions listed below. - - 0. Additional Definitions. - - As used herein, "this License" refers to version 3 of the GNU Lesser -General Public License, and the "GNU GPL" refers to version 3 of the GNU -General Public License. - - "The Library" refers to a covered work governed by this License, -other than an Application or a Combined Work as defined below. - - An "Application" is any work that makes use of an interface provided -by the Library, but which is not otherwise based on the Library. -Defining a subclass of a class defined by the Library is deemed a mode -of using an interface provided by the Library. - - A "Combined Work" is a work produced by combining or linking an -Application with the Library. The particular version of the Library -with which the Combined Work was made is also called the "Linked -Version". - - The "Minimal Corresponding Source" for a Combined Work means the -Corresponding Source for the Combined Work, excluding any source code -for portions of the Combined Work that, considered in isolation, are -based on the Application, and not on the Linked Version. - - The "Corresponding Application Code" for a Combined Work means the -object code and/or source code for the Application, including any data -and utility programs needed for reproducing the Combined Work from the -Application, but excluding the System Libraries of the Combined Work. - - 1. Exception to Section 3 of the GNU GPL. - - You may convey a covered work under sections 3 and 4 of this License -without being bound by section 3 of the GNU GPL. - - 2. Conveying Modified Versions. - - If you modify a copy of the Library, and, in your modifications, a -facility refers to a function or data to be supplied by an Application -that uses the facility (other than as an argument passed when the -facility is invoked), then you may convey a copy of the modified -version: - - a) under this License, provided that you make a good faith effort to - ensure that, in the event an Application does not supply the - function or data, the facility still operates, and performs - whatever part of its purpose remains meaningful, or - - b) under the GNU GPL, with none of the additional permissions of - this License applicable to that copy. - - 3. Object Code Incorporating Material from Library Header Files. - - The object code form of an Application may incorporate material from -a header file that is part of the Library. You may convey such object -code under terms of your choice, provided that, if the incorporated -material is not limited to numerical parameters, data structure -layouts and accessors, or small macros, inline functions and templates -(ten or fewer lines in length), you do both of the following: - - a) Give prominent notice with each copy of the object code that the - Library is used in it and that the Library and its use are - covered by this License. - - b) Accompany the object code with a copy of the GNU GPL and this license - document. - - 4. Combined Works. - - You may convey a Combined Work under terms of your choice that, -taken together, effectively do not restrict modification of the -portions of the Library contained in the Combined Work and reverse -engineering for debugging such modifications, if you also do each of -the following: - - a) Give prominent notice with each copy of the Combined Work that - the Library is used in it and that the Library and its use are - covered by this License. - - b) Accompany the Combined Work with a copy of the GNU GPL and this license - document. - - c) For a Combined Work that displays copyright notices during - execution, include the copyright notice for the Library among - these notices, as well as a reference directing the user to the - copies of the GNU GPL and this license document. - - d) Do one of the following: - - 0) Convey the Minimal Corresponding Source under the terms of this - License, and the Corresponding Application Code in a form - suitable for, and under terms that permit, the user to - recombine or relink the Application with a modified version of - the Linked Version to produce a modified Combined Work, in the - manner specified by section 6 of the GNU GPL for conveying - Corresponding Source. - - 1) Use a suitable shared library mechanism for linking with the - Library. A suitable mechanism is one that (a) uses at run time - a copy of the Library already present on the user's computer - system, and (b) will operate properly with a modified version - of the Library that is interface-compatible with the Linked - Version. - - e) Provide Installation Information, but only if you would otherwise - be required to provide such information under section 6 of the - GNU GPL, and only to the extent that such information is - necessary to install and execute a modified version of the - Combined Work produced by recombining or relinking the - Application with a modified version of the Linked Version. (If - you use option 4d0, the Installation Information must accompany - the Minimal Corresponding Source and Corresponding Application - Code. If you use option 4d1, you must provide the Installation - Information in the manner specified by section 6 of the GNU GPL - for conveying Corresponding Source.) - - 5. Combined Libraries. - - You may place library facilities that are a work based on the -Library side by side in a single library together with other library -facilities that are not Applications and are not covered by this -License, and convey such a combined library under terms of your -choice, if you do both of the following: - - a) Accompany the combined library with a copy of the same work based - on the Library, uncombined with any other library facilities, - conveyed under the terms of this License. - - b) Give prominent notice with the combined library that part of it - is a work based on the Library, and explaining where to find the - accompanying uncombined form of the same work. - - 6. Revised Versions of the GNU Lesser General Public License. - - The Free Software Foundation may publish revised and/or new versions -of the GNU Lesser General Public License from time to time. Such new -versions will be similar in spirit to the present version, but may -differ in detail to address new problems or concerns. - - Each version is given a distinguishing version number. If the -Library as you received it specifies that a certain numbered version -of the GNU Lesser General Public License "or any later version" -applies to it, you have the option of following the terms and -conditions either of that published version or of any later version -published by the Free Software Foundation. If the Library as you -received it does not specify a version number of the GNU Lesser -General Public License, you may choose any version of the GNU Lesser -General Public License ever published by the Free Software Foundation. - - If the Library as you received it specifies that a proxy can decide -whether future versions of the GNU Lesser General Public License shall -apply, that proxy's public statement of acceptance of any version is -permanent authorization for you to choose that version for the -Library. - diff --git a/docs/comm/the-beast/data-types.html b/docs/comm/the-beast/data-types.html index fef4852d4d..4ec220c937 100644 --- a/docs/comm/the-beast/data-types.html +++ b/docs/comm/the-beast/data-types.html @@ -147,7 +147,7 @@ top-level nullary constructors (like True and False). Furthermore, what if the code generator encounters a non-saturated application of a worker? E.g. <tt>(map Just xs)</tt>. We could declare that to be an error (CorePrep should saturate them). But instead we currently -generate a top-level defintion for each constructor worker, whether +generate a top-level definition for each constructor worker, whether nullary or not. It takes the form: <pre> MkT{v} = \ p q r -> MkT{v} p q r @@ -157,7 +157,7 @@ one that generates abstract C and the byte-code generator) treats it as a specia allocates a MkT; it does not make a recursive call! So now there's a top-level curried version of the worker which is available to anyone who wants it. <p> -This strange defintion is not emitted into External Core. Indeed, you might argue that +This strange definition is not emitted into External Core. Indeed, you might argue that we should instead pass the list of <tt>TyCon</tt>s to the code generator and have it generate magic bindings directly. As it stands, it's a real hack: see the code in CorePrep.mkImplicitBinds. diff --git a/docs/comm/the-beast/ncg.html b/docs/comm/the-beast/ncg.html index 5810a35212..84beac2d51 100644 --- a/docs/comm/the-beast/ncg.html +++ b/docs/comm/the-beast/ncg.html @@ -542,7 +542,7 @@ the reg-alloc abstraction (implicitly) assumes. Our strategy is: do a good job for the common small subset, that is integer loads, stores, address calculations, basic ALU ops (+, -, and, or, xor), and jumps. That covers the vast majority of -executed insns. And indeed we do do a good job, with a loss of +executed insns. And indeed we do a good job, with a loss of less than 2% compared with gcc. <p> Initially we tried to handle integer instructions with awkward @@ -742,7 +742,7 @@ other way is a total time waster. <p><small> <!-- hhmts start --> -Last modified: Fri Feb 1 16:14:11 GMT 2002 +Last modified: Mon Aug 19 11:41:43 CEST 2013 <!-- hhmts end --> </small> </body> diff --git a/docs/core-spec/CoreLint.ott b/docs/core-spec/CoreLint.ott index beaf52a7d9..f2799841dc 100644 --- a/docs/core-spec/CoreLint.ott +++ b/docs/core-spec/CoreLint.ott @@ -1,3 +1,9 @@ +%% +%% CoreLint.ott +%% +%% defines formal version of core typing rules +%% +%% See accompanying README file %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Static semantics %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -54,7 +60,7 @@ t = literalType lit G |-tm lit : t G |-tm e : s -G |-co g : s ~#k t +G |-co g : s ~Rep k t ------------------- :: Cast G |-tm e |> g : t @@ -115,10 +121,14 @@ G |-ty t : k2 ---------------------------------------------------- :: Case G |-tm case e as z_s return t of </ alti // i /> : t -G |-co g : t1 ~#k t2 --------------------- :: Coercion +G |-co g : t1 ~Nom k t2 +-------------------- :: CoercionNom G |-tm g : t1 ~#k t2 +G |-co g : t1 ~Rep k t2 +----------------------- :: CoercionRep +G |-tm g : (~R#) k t1 t2 + defn G |- name n ok :: :: lintSingleBinding_lintBinder :: 'Name_' {{ com Name consistency check, \coderef{coreSyn/CoreLint.lhs}{lintSingleBinding\#lintBinder} }} {{ tex [[G]] \labeledjudge{n} [[n]] [[ok]] }} @@ -144,97 +154,179 @@ G |-ki k ok ---------------------------------------- :: TyVar G |-bnd alpha_k ok -defn G |- co g : t1 ~# k t2 :: :: lintCoercion :: 'Co_' +defn G |- co g : t1 ~ R k t2 :: :: lintCoercion :: 'Co_' {{ com Coercion typing, \coderef{coreSyn/CoreLint.lhs}{lintCoercion} }} - {{ tex [[G]] \labeledjudge{co} [[g]] : [[t1]] \mathop{\sim_{\#}^{[[k]]} } [[t2]] }} + {{ tex [[G]] \labeledjudge{co} [[g]] : [[t1]] \mathop{\sim_{[[R]]}^{[[k]]} } [[t2]] }} by G |-ty t : k ---------------------- :: Refl -G |-co <t> : t ~#k t +G |-co <t>_R : t ~R k t -G |-co g1 : s1 ~#k1 t1 -G |-co g2 : s2 ~#k2 t2 +G |-co g1 : s1 ~R k1 t1 +G |-co g2 : s2 ~R k2 t2 G |-arrow k1 -> k2 : k ------------------------- :: TyConAppCoFunTy -G |-co (->) g1 g2 : (s1 -> s2) ~#k (t1 -> t2) +G |-co (->)_R g1 g2 : (s1 -> s2) ~R k (t1 -> t2) T /= (->) -</ G |-co gi : si ~#ki ti // i /> +</ Ri // i /> = tyConRolesX R T +</ G |-co gi : si ~Ri ki ti // i /> G |-app </ (si : ki) // i /> : tyConKind T ~> k --------------------------------- :: TyConAppCo -G |-co T </ gi // i /> : T </ si // i /> ~#k T </ ti // i /> +G |-co T_R </ gi // i /> : T </ si // i /> ~R k T </ ti // i /> -G |-co g1 : s1 ~#k1 t1 -G |-co g2 : s2 ~#k2 t2 +G |-co g1 : s1 ~R k1 t1 +G |-co g2 : s2 ~Nom k2 t2 G |-app (s2 : k2) : k1 ~> k --------------------- :: AppCo -G |-co g1 g2 : (s1 s2) ~#k (t1 t2) +G |-co g1 g2 : (s1 s2) ~R k (t1 t2) + +G |-co g1 : s1 ~Ph k1 t1 +G |-co g2 : s2 ~Ph k2 t2 +G |-app (s2 : k2) : k1 ~> k +--------------------- :: AppCoPhantom +G |-co g1 g2 : (s1 s2) ~Ph k (t1 t2) G |-ki k1 ok -G, z_k1 |-co g : s ~#k2 t +G, z_k1 |-co g : s ~R k2 t --------------------------- :: ForAllCo -G |-co forall z_k1. g : (forall z_k1.s) ~#k2 (forall z_k1.t) +G |-co forall z_k1. g : (forall z_k1.s) ~R k2 (forall z_k1.t) z_(t ~#BOX t) elt G ----------------------- :: CoVarCoBox -G |-co z_(t ~#BOX t) : t ~#BOX t +G |-co z_(t ~#BOX t) : t ~Nom BOX t z_(s ~#k t) elt G k /= BOX ------------------------ :: CoVarCo -G |-co z_(s ~#k t) : s ~#k t +----------------------- :: CoVarCoNom +G |-co z_(s ~#k t) : s ~Nom k t + +z_(s ~R#k t) elt G +k /= BOX +----------------------- :: CoVarCoRepr +G |-co z_(s ~R#k t) : s ~Rep k t G |-ty t1 : k ------------------------------ :: UnsafeCo -G |-co t1 ==>! t2 : t1 ~#k t2 +----------------------------- :: UnivCo +G |-co t1 ==>!_R t2 : t1 ~R k t2 -G |-co g : t1 ~#k t2 +G |-co g : t1 ~R k t2 ------------------------- :: SymCo -G |-co sym g : t2 ~#k t1 +G |-co sym g : t2 ~R k t1 -G |-co g1 : t1 ~#k t2 -G |-co g2 : t2 ~#k t3 +G |-co g1 : t1 ~R k t2 +G |-co g2 : t2 ~R k t3 ----------------------- :: TransCo -G |-co g1 ; g2 : t1 ~#k t3 +G |-co g1 ; g2 : t1 ~R k t3 -G |-co g : (T </ sj // j />) ~#k (T </ tj // j />) +G |-co g : (T </ sj // j />) ~R k (T </ tj // j />) length </ sj // j /> = length </ tj // j /> i < length </ sj // j /> G |-ty si : k +R' = (tyConRolesX R T)[i] ---------------------- :: NthCo -G |-co nth i g : si ~#k ti +G |-co nth i g : si ~R' k ti -G |-co g : (s1 s2) ~#k (t1 t2) +G |-co g : (s1 s2) ~Nom k' (t1 t2) G |-ty s1 : k ----------------------- :: LRCoLeft -G |-co Left g : s1 ~#k t1 +G |-co Left g : s1 ~Nom k t1 -G |-co g : (s1 s2) ~#k (t1 t2) +G |-co g : (s1 s2) ~Nom k' (t1 t2) G |-ty s2 : k ----------------------- :: LRCoRight -G |-co Right g : s2 ~#k t2 +G |-co Right g : s2 ~Nom k t2 -G |-co g : forall m.s ~#k forall n.t +G |-co g : forall m.s ~R k forall n.t G |-ty t0 : k0 m = z_k1 k0 <: k1 --------------------- :: InstCo -G |-co g t0 : s[m |-> t0] ~#k t[n |-> t0] +G |-co g t0 : s[m |-> t0] ~R k t[n |-> t0] -C = T </ axBranchkk // kk /> +C = T_R0 </ axBranchkk // kk /> 0 <= ind < length </ axBranchkk // kk /> -forall </ ni // i />. (</ s1j // j /> ~> t1) = (</ axBranchkk // kk />)[ind] -</ G |-co gi : s'i ~#k'i t'i // i /> +forall </ ni_Ri // i />. (</ s1j // j /> ~> t1) = (</ axBranchkk // kk />)[ind] +</ G |-co gi : s'i ~Ri k'i t'i // i /> </ substi @ // i /> = inits(</ [ ni |-> s'i ] // i />) </ ni = zi_ki // i /> </ k'i <: substi(ki) // i /> -no_conflict(C, </ s2j // j />, ind-1) +no_conflict(C, </ s2j // j />, ind, ind-1) </ s2j = s1j </ [ni |-> s'i] // i/> // j /> t2 = t1 </ [ni |-> t'i] // i /> G |-ty t2 : k ------------------------------------------------------ :: AxiomInstCo -G |-co C ind </ gi // i /> : T </ s2j // j /> ~#k t2 +G |-co C ind </ gi // i /> : T </ s2j // j /> ~R0 k t2 + +defn validRoles T :: :: checkValidRoles :: 'Cvr_' + {{ com Type constructor role validity, \coderef{typecheck/TcTyClsDecls.lhs}{checkValidRoles} }} +by + +</ Ki // i /> = tyConDataCons T +</ Rj // j /> = tyConRoles T +</ validDcRoles </ Rj // j /> Ki // i /> +------------------------------------ :: DataCons +validRoles T + +defn validDcRoles </ Raa // aa /> K :: :: check_dc_roles :: 'Cdr_' + {{ com Data constructor role validity, \coderef{typecheck/TcTyClsDecls.lhs}{check\_dc\_roles} }} +by + +forall </ naa // aa />. forall </ mbb // bb />. </ tcc // cc /> @ -> T </ naa // aa /> = dataConRepType K +</ </ naa : Raa // aa />, </ mbb : Nom // bb /> |- tcc : Rep // cc /> +--------------------------------- :: Args +validDcRoles </ Raa // aa /> K + +defn O |- t : R :: :: check_ty_roles :: 'Ctr_' + {{ com Type role validity, \coderef{typecheck/TcTyClsDecls.lhs}{check\_ty\_roles} }} + {{ tex [[O]] \labeledjudge{ctr} [[t]] : [[R]] }} +by + +O(n) = R' +R' <= R +---------- :: TyVarTy +O |- n : R + +</ Ri // i /> = tyConRoles T +</ Ri elt { Nom, Rep } => O |- ti : Ri // i /> +-------------------------- :: TyConAppRep +O |- T </ ti // i /> : Rep + +</ O |- ti : Nom // i /> +--------------------------- :: TyConAppNom +O |- T </ ti // i /> : Nom + +O |- t1 : R +O |- t2 : Nom +-------------------------- :: AppTy +O |- t1 t2 : R + +O |- t1 : R +O |- t2 : R +------------------- :: FunTy +O |- t1 -> t2 : R + +O, n : Nom |- t : R +--------------------- :: ForAllTy +O |- forall n. t : R + +------------------ :: LitTy +O |- lit : R + +defn R1 <= R2 :: :: ltRole :: 'Rlt_' + {{ com Sub-role relation, \coderef{types/Coercion.lhs}{ltRole} }} + {{ tex [[R1]] \leq [[R2]] }} +by + +-------- :: Nominal +Nom <= R + +-------- :: Phantom +R <= Ph + +------- :: Refl +R <= R defn G |- ki k ok :: :: lintKind :: 'K_' {{ com Kind validity, \coderef{coreSyn/CoreLint.lhs}{lintKind} }} @@ -403,16 +495,32 @@ Constraint <: * ------------------ :: LiftedConstraint * <: Constraint -defn no_conflict ( C , </ sj // j /> , ind ) :: :: check_no_conflict :: 'NoConflict_' - {{ com Branched axiom conflict checking, \coderef{coreSyn/CoreLint.lhs}{lintCoercion\#check\_no\_conflict} }} +defn no_conflict ( C , </ sj // j /> , ind1 , ind2 ) :: :: check_no_conflict :: 'NoConflict_' + {{ com \parbox{5in}{Branched axiom conflict checking, \coderef{types/OptCoercion.lhs}{checkAxInstCo} \\ and \coderef{types/FamInstEnv.lhs}{compatibleBranches} } }} by ------------------------------------------------ :: NoBranch -no_conflict(C, </ si // i/>, -1) +no_conflict(C, </ si // i/>, ind, -1) -C = T </ axBranchkk // kk /> -forall </ ni // i />. (</ tj // j /> ~> t') = (</ axBranchkk // kk />)[ind] +C = T_R </ axBranchkk // kk /> +forall </ ni_Ri // i />. (</ tj // j /> ~> t') = (</ axBranchkk // kk />)[ind2] apart(</ sj // j />, </ tj // j />) -no_conflict(C, </ sj // j />, ind-1) ------------------------------------------------- :: Branch -no_conflict(C, </ sj // j />, ind) +no_conflict(C, </ sj // j />, ind1, ind2-1) +------------------------------------------------ :: Incompat +no_conflict(C, </ sj // j />, ind1, ind2) + +C = T_R </ axBranchkk // kk /> +forall </ ni_Ri // i />. (</ tj // j /> ~> s) = (</ axBranchkk // kk />)[ind1] +forall </ n'i_R'i // i />. (</ t'j // j /> ~> s') = (</ axBranchkk // kk />)[ind2] +apart(</ tj // j />, </ t'j // j />) +no_conflict(C, </ sj // j />, ind1, ind2-1) +------------------------------------------- :: CompatApart +no_conflict(C, </ sj // j />, ind1, ind2) + +C = T_R </ axBranchkk // kk /> +forall </ ni_Ri // i />. (</ tj // j /> ~> s) = (</ axBranchkk // kk />)[ind1] +forall </ n'i_R'i // i />. (</ t'j // j /> ~> s') = (</ axBranchkk // kk />)[ind2] +unify(</ tj // j />, </ t'j // j />) = subst +subst(s) = subst(s') +----------------------------------------- :: CompatCoincident +no_conflict(C, </ sj // j />, ind1, ind2)
\ No newline at end of file diff --git a/docs/core-spec/CoreSyn.ott b/docs/core-spec/CoreSyn.ott index 4c59849bb6..ca060f2f72 100644 --- a/docs/core-spec/CoreSyn.ott +++ b/docs/core-spec/CoreSyn.ott @@ -1,3 +1,9 @@ +%% +%% CoreSyn.ott +%% +%% defines formal version of core syntax +%% +%% See accompanying README file embed {{ tex-preamble \newcommand{\coderef}[2]{\ghcfile{#1}:\texttt{#2}% @@ -16,7 +22,7 @@ metavar alpha {{ tex \alpha }}, beta {{ tex \beta }} ::= metavar N ::= {{ com Type-level constructor names }} metavar K ::= {{ com Term-level data constructor names }} -indexvar i, j, kk {{ tex k }} ::= {{ com Indices to be used in lists }} +indexvar i, j, kk {{ tex k }}, aa {{ tex a }}, bb {{ tex b }}, cc {{ tex c }} ::= {{ com Indices to be used in lists }} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Syntax %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -34,12 +40,17 @@ z :: 'Name_' ::= {{ com Term or type name }} n, m :: 'Var_' ::= {{ com Variable names, \coderef{basicTypes/Var.lhs}{Var} }} | z _ t :: :: IdOrTyVar {{ com Name, labeled with type/kind }} {{ tex {[[z]]}^{[[t]]} }} + | K :: M :: DataCon {{ com Data constructor }} vars :: 'Vars_' ::= {{ com List of variables }} - | </ ni // , // i /> :: :: List - | fv ( t ) :: M :: fv + | </ ni // , // i /> :: :: List + | fv ( t ) :: M :: fv_t {{ tex \textit{fv}([[t]]) }} - | empty :: M :: empty + | fv ( e ) :: M :: fv_e + {{ tex \textit{fv}([[e]]) }} + | empty :: M :: empty + | vars1 \inter vars2 :: M :: intersection + {{ tex [[vars1]] \cap [[vars2]] }} e, u :: 'Expr_' ::= {{ com Expressions, \coderef{coreSyn/CoreSyn.lhs}{Expr} }} | n :: :: Var {{ com Variable }} @@ -53,7 +64,10 @@ e, u :: 'Expr_' ::= {{ com Expressions, \coderef{coreSyn/CoreSyn.lhs}{Expr} }} {{ tex {[[e]]}_{\{[[tick]]\} } }} | t :: :: Type {{ com Type }} | g :: :: Coercion {{ com Coercion }} - | e [ n |-> t ] :: M :: TySubst {{ com Type substitution }} + | e subst :: M :: Subst {{ com Substitution }} + | ( e ) :: M :: Parens {{ com Parenthesized expression }} + | e </ ui // i /> :: M :: Apps {{ com Nested application }} + | S ( n ) :: M :: Lookup {{ com Lookup in the runtime store }} binding :: 'Bind_' ::= {{ com Let-bindings, \coderef{coreSyn/CoreSyn.lhs}{Bind} }} | n = e :: :: NonRec {{ com Non-recursive binding }} @@ -85,43 +99,58 @@ t {{ tex \tau }}, k {{ tex \kappa }}, s {{ tex \sigma }} | tyConKind T :: M :: tyConKind {{ com \coderef{types/TyCon.lhs}{tyConKind} }} | t1 ~# k t2 :: M :: unliftedEq {{ com Metanotation for coercion types }} {{ tex [[t1]] \mathop{\sim_{\#}^{[[k]]} } [[t2]] }} + | t1 ~R# k t2 :: M :: unliftedREq {{ com Metanotation for coercion types }} + {{ tex [[t1]] \mathop{\sim_{\mathsf{R}\#}^{[[k]]} } [[t2]] }} | literalType t :: M :: literalType {{ com \coderef{basicTypes/Literal.lhs}{literalType} }} | ( t ) :: M :: parens {{ com Parentheses }} | t [ n |-> s ] :: M :: TySubst {{ com Type substitution }} | subst ( k ) :: M :: TySubstList {{ com Type substitution list }} | t subst :: M :: TySubstListPost {{ com Type substitution list }} | dataConRepType K :: M :: dataConRepType {{ com Type of DataCon }} + | forall </ ni // , // i /> . t + :: M :: ForAllTys {{ com Nested polymorphism }} + | </ ti // i /> @ -> t' :: M :: FunTys {{ com Nested arrows }} %% COERCIONS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% g {{ tex \gamma }} :: 'Coercion_' ::= {{ com Coercions, \coderef{types/Coercion.lhs}{Coercion} }} - | < t > :: :: Refl {{ com Reflexivity }} - {{ tex \langle [[t]] \rangle }} - | T </ gi // i /> :: :: TyConAppCo {{ com Type constructor application }} + | < t > _ R :: :: Refl {{ com Reflexivity }} + {{ tex {\langle [[t]] \rangle}_{[[R]]} }} + | T RA </ gi // i /> :: :: TyConAppCo {{ com Type constructor application }} | g1 g2 :: :: AppCo {{ com Application }} | forall n . g :: :: ForAllCo {{ com Polymorphism }} | n :: :: CoVarCo {{ com Variable }} | C ind </ gj // j /> :: :: AxiomInstCo {{ com Axiom application }} - | t1 ==>! t2 :: :: UnsafeCo {{ com Unsafe coercion }} + | t1 ==>! RA t2 :: :: UnivCo {{ com Universal coercion }} | sym g :: :: SymCo {{ com Symmetry }} | g1 ; g2 :: :: TransCo {{ com Transitivity }} - | nth i g :: :: NthCo {{ com Projection (0-indexed) }} - {{ tex \textsf{nth}_{[[i]]}\,[[g]] }} + | nth I g :: :: NthCo {{ com Projection (0-indexed) }} + {{ tex \textsf{nth}_{[[I]]}\,[[g]] }} | LorR g :: :: LRCo {{ com Left/right projection }} | g t :: :: InstCo {{ com Type application }} | ( g ) :: M :: Parens {{ com Parentheses }} + | t @ liftingsubst :: M :: Lifted {{ com Type lifted to coercion }} LorR :: 'LeftOrRight_' ::= {{ com left or right deconstructor, \coderef{types/Coercion.lhs}{LeftOrRight} }} | Left :: :: CLeft {{ com Left projection }} | Right :: :: CRight {{ com Right projection }} C :: 'CoAxiom_' ::= {{ com Axioms, \coderef{types/TyCon.lhs}{CoAxiom} }} - | T </ axBranchi // ; // i /> :: :: CoAxiom {{ com Axiom }} - | ( C ) :: M :: Parens {{ com Parentheses }} + | T RA </ axBranchi // ; // i /> :: :: CoAxiom {{ com Axiom }} + | ( C ) :: M :: Parens {{ com Parentheses }} + +R {{ tex \rho }} :: 'Role_' ::= {{ com Roles, \coderef{types/CoAxiom.lhs}{Role} }} + | Nom :: :: Nominal {{ com Nominal }} + {{ tex \mathsf{N} }} + | Rep :: :: Representational {{ com Representational }} + {{ tex \mathsf{R} }} + | Ph :: :: Phantom {{ com Phantom }} + {{ tex \mathsf{P} }} + | role_list [ i ] :: M :: RoleListIndex {{ com Look up in list }} axBranch, b :: 'CoAxBranch_' ::= {{ com Axiom branches, \coderef{types/TyCon.lhs}{CoAxBranch} }} - | forall </ ni // i /> . ( </ tj // j /> ~> s ) :: :: CoAxBranch {{ com Axiom branch }} - | ( </ axBranchi // i /> ) [ ind ] :: M :: lookup {{ com List lookup }} + | forall </ ni RAi // i /> . ( </ tj // j /> ~> s ) :: :: CoAxBranch {{ com Axiom branch }} + | ( </ axBranchi // i /> ) [ ind ] :: M :: lookup {{ com List lookup }} %% TYCONS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -137,13 +166,14 @@ T :: 'TyCon_' ::= {{ com Type constructors, \coderef{types/TyCon.lhs}{TyCon} }} | dataConTyCon K :: M :: dataConTyCon {{ com TyCon extracted from DataCon }} H :: 'PrimTyCon_' ::= {{ com Primitive type constructors, \coderef{prelude/TysPrim.lhs}{} }} - | Int# :: :: intPrimTyCon {{ com Unboxed Int }} - | ( ~# ) :: :: eqPrimTyCon {{ com Unboxed equality }} - | BOX :: :: superKindTyCon {{ com Sort of kinds }} - | * :: :: liftedTypeKindTyCon {{ com Kind of lifted types }} - | # :: :: unliftedTypeKindTyCon {{ com Kind of unlifted types }} - | OpenKind :: :: openTypeKindTyCon {{ com Either $*$ or $\#$ }} - | Constraint :: :: constraintTyCon {{ com Constraint }} + | Int# :: :: intPrimTyCon {{ com Unboxed Int (\texttt{intPrimTyCon}) }} + | ( ~# ) :: :: eqPrimTyCon {{ com Unboxed equality (\texttt{eqPrimTyCon}) }} + | ( ~R# ) :: :: eqReprPrimTyCon {{ com Unboxed representational equality (\texttt{eqReprPrimTyCon}) }} + | BOX :: :: superKindTyCon {{ com Sort of kinds (\texttt{superKindTyCon}) }} + | * :: :: liftedTypeKindTyCon {{ com Kind of lifted types (\texttt{liftedTypeKindTyCon}) }} + | # :: :: unliftedTypeKindTyCon {{ com Kind of unlifted types (\texttt{unliftedTypeKindTyCon}) }} + | OpenKind :: :: openTypeKindTyCon {{ com Either $*$ or $\#$ (\texttt{openTypeKindTyCon}) }} + | Constraint :: :: constraintTyCon {{ com Constraint (\texttt{constraintTyCon}) }} %% CONTEXTS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -152,6 +182,14 @@ G {{ tex \Gamma }} :: 'LintM_Bindings_' ::= {{ com List of bindings, \coderef{co | </ Gi // , // i /> :: :: Concat {{ com Context concatenation }} | vars_of binding :: M :: VarsOf {{ com \coderef{coreSyn/CoreSyn.lhs}{bindersOf} }} +O {{ tex \Omega }} :: 'VarEnv_Role_' ::= {{ com Mapping from type variables to roles }} + | </ ni : Ri // i /> :: :: List {{ com List of bindings }} + | O1 , O2 :: M :: Concat {{ com Concatenate two lists }} + +S {{ tex \Sigma }} :: 'St_' ::= {{ com Runtime store }} + | [ n |-> e ] :: :: Binding {{ com Single binding }} + | </ Si // , // i /> :: :: Concat {{ com Store concatentation }} + %% UTILITY %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% B {{ tex \mathbb{B} }} :: 'Bool_' ::= {{ com Booleans in metatheory }} @@ -162,17 +200,39 @@ kinded_types {{ tex \overline{(\sigma_i : \kappa_i)}^i }} :: 'Kinded_Types_' ::= | </ ( si : ki ) // , // i /> :: :: List | empty :: M :: empty -subst :: 'Subst_' ::= {{ com List of type substitutions }} - | [ n |-> t ] :: :: Mapping +subst :: 'Subst_' ::= {{ com List of substitutions }} + | [ n |-> t ] :: :: TyMapping + | [ n |-> e ] :: :: TmMapping | </ substi // i /> :: :: List -ind :: 'Ind_' ::= {{ com Indices, numbers }} +liftingsubst :: 'LiftSubst_' ::= {{ com List of lifting substitutions }} + | [ n |-> g ] :: :: Mapping + | </ liftingsubsti // i /> :: :: List + +ind, I {{ tex i }} :: 'Ind_' ::= {{ com Indices, numbers }} | i :: :: index | length </ ti // i /> :: M :: length_t | length </ axBranchi // i /> :: M :: length_axBranch | tyConArity T :: M :: tyConArity | ind - 1 :: M :: decrement | -1 :: M :: minusOne + | 0 :: M :: zero + | 1 :: M :: one + | 2 :: M :: two + +type_list :: 'TypeList_' ::= {{ com List of types }} + | </ si // i /> :: :: List + +RA {{ tex {\!\!\!{}_{\rho} } }} :: 'RoleAnnot_' ::= {{ com Role annotation }} + | _ R :: M :: annotation + {{ tex {}_{[[R]]} }} + +role_list :: 'RoleList_' ::= {{ com List of roles }} + | </ Ri // , // i /> :: :: List + | tyConRolesX R T :: M :: tyConRolesX + | tyConRoles T :: M :: tyConRoles + | ( role_list ) :: M :: Parens + | { role_list } :: M :: Braces %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Terminals %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -199,6 +259,7 @@ terminals :: 'terminals_' ::= | BOX :: :: BOX {{ tex \Box }} | Int# :: :: int_hash {{ tex {\textsf{Int} }_{\#} }} | ~# :: :: eq_hash {{ tex \mathop{ {\sim}_{\#} } }} + | ~R# :: :: eq_repr_hash {{ tex \mathop{ {\sim}_{\mathsf{R}\#} } }} | OpenKind :: :: OpenKind {{ tex \textsf{OpenKind} }} | ok :: :: ok {{ tex \textsf{ ok} }} | no_duplicates :: :: no_duplicates {{ tex \textsf{no\_duplicates } }} @@ -229,6 +290,14 @@ terminals :: 'terminals_' ::= | Constraint :: :: Constraint {{ tex \textsf{Constraint} }} | no_conflict :: :: no_conflict {{ tex \textsf{no\_conflict} }} | apart :: :: apart {{ tex \textsf{apart} }} + | unify :: :: unify {{ tex \textsf{unify} }} + | tyConRolesX :: :: tyConRolesX {{ tex \textsf{tyConRolesX} }} + | tyConRoles :: :: tyConRoles {{ tex \textsf{tyConRoles} }} + | tyConDataCons :: :: tyConDataCons {{ tex \textsf{tyConDataCons} }} + | validRoles :: :: validRoles {{ tex \textsf{validRoles} }} + | validDcRoles :: :: validDcRoles {{ tex \textsf{validDcRoles} }} + | --> :: :: steps {{ tex \longrightarrow }} + | coercionKind :: :: coercionKind {{ tex \textsf{coercionKind} }} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Formulae %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -264,12 +333,28 @@ formula :: 'formula_' ::= | k1 elt { </ ki // , // i /> } :: :: kind_elt | e is_a_type :: :: is_a_type {{ tex \exists \tau \text{ s.t.~} [[e]] = \tau }} - | t is_a_coercion :: :: is_a_coercion + | e is_a_coercion :: :: is_a_coercion + {{ tex \exists \gamma \text{ s.t.~} [[e]] = \gamma }} + | t is_a_prop :: :: is_a_prop {{ tex \exists \tau_1, \tau_2, \kappa \text{ s.t.~} [[t]] = \tau_1 \mathop{ {\sim}_{\#}^{\kappa} } \tau_2 }} | axBranch1 = axBranch2 :: :: branch_rewrite | C1 = C2 :: :: axiom_rewrite | apart ( </ ti // i /> , </ sj // j /> ) :: :: apart + | unify ( </ ti // i /> , </ sj // j /> ) = subst :: :: unify + | role_list1 = role_list2 :: :: eq_role_list + | R1 /= R2 :: :: role_neq + | R1 = R2 :: :: eq_role + | </ Ki // i /> = tyConDataCons T :: :: tyConDataCons + | O ( n ) = R :: :: role_lookup + | R elt role_list :: :: role_elt + | formula1 => formula2 :: :: implication + {{ tex [[formula1]] \implies [[formula2]] }} + | alt1 = alt2 :: :: alt_rewrite + | e1 = e2 :: :: e_rewrite + | no other case matches :: :: no_other_case + {{ tex \text{no other case matches} }} + | t = coercionKind g :: :: coercionKind %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Subrules and Parsing %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -289,8 +374,15 @@ TyCon_AlgTyCon right Coercion_AppCo TyCon_PromotedDataCon right Coercion_AppCo TyCon_PromotedTyCon right Coercion_AppCo -Subst_Mapping <= Type_TySubstList +Subst_TyMapping <= Type_TySubstList +Subst_TmMapping <= Type_TySubstList Subst_List <= Type_TySubstList -Subst_Mapping <= Type_TySubstListPost +Subst_TyMapping <= Type_TySubstListPost +Subst_TmMapping <= Type_TySubstListPost + +Expr_Type <= formula_e_rewrite + +Coercion_TyConAppCo <= Coercion_AppCo +Expr_Coercion <= Subst_TmMapping diff --git a/docs/core-spec/Makefile b/docs/core-spec/Makefile index 1a5b27cd75..402f9dbe4e 100644 --- a/docs/core-spec/Makefile +++ b/docs/core-spec/Makefile @@ -1,10 +1,11 @@ -OTT_FILES = CoreSyn.ott CoreLint.ott +OTT_FILES = CoreSyn.ott CoreLint.ott OpSem.ott OTT_TEX = CoreOtt.tex OTT_OPTS = -tex_show_meta false TARGET = core-spec $(TARGET).pdf: $(TARGET).tex $(OTT_TEX) - latexmk -pdf $< + latex -output-format=pdf $< + latex -output-format=pdf $< $(TARGET).tex: $(TARGET).mng $(OTT_FILES) ott $(OTT_OPTS) -tex_filter $< $@ $(OTT_FILES) diff --git a/docs/core-spec/OpSem.ott b/docs/core-spec/OpSem.ott new file mode 100644 index 0000000000..1c21ada0ec --- /dev/null +++ b/docs/core-spec/OpSem.ott @@ -0,0 +1,97 @@ + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Dynamic semantics %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +% The definitions in this file do *not* strictly correspond to any specific +% code in GHC. They are here to provide a reasonable operational semantic +% interpretation to the typing rules presented in the other ott files. Thus, +% your mileage may vary. In particular, there has been *no* attempt to +% write any formal proofs over these semantics. +% +% With that disclaimer disclaimed, these rules are a reasonable jumping-off +% point for an analysis of FC's operational semantics. If you don't want to +% worry about mutual recursion (and who does?), you can even drop the +% environment S. + +grammar + +defns +OpSem :: '' ::= + +defn S |- e --> e' :: :: step :: 'S_' {{ com Single step semantics }} +{{ tex [[S]] \labeledjudge{op} [[e]] [[-->]] [[e']] }} +by + +S(n) = e +----------------- :: Var +S |- n --> e + +S |- e1 --> e1' +------------------- :: App +S |- e1 e2 --> e1' e2 + +----------------------------- :: Beta +S |- (\n.e1) e2 --> e1[n |-> e2] + +g0 = sym (nth 0 g) +g1 = nth 1 g +not e2 is_a_type +not e2 is_a_coercion +----------------------------------------------- :: Push +S |- ((\n.e1) |> g) e2 --> (\n.e1 |> g1) (e2 |> g0) + +---------------------------------------- :: TPush +S |- ((\n.e) |> g) t --> (\n.(e |> g n)) t + +g0 = nth 1 (nth 0 g) +g1 = sym (nth 2 (nth 0 g)) +g2 = nth 1 g +------------------------------- :: CPush +S |- ((\n.e) |> g) g' --> (\n.e |> g2) (g0 ; g' ; g1) + +----------------- :: LetNonRec +S |- let n = e1 in e2 --> e2[n |-> e1] + + +S, </ [ni |-> ei] // i /> |- u --> u' +------------------------------------ :: LetRec +S |- let rec </ ni = ei // i /> in u --> let rec </ ni = ei // i /> in u' + +fv(u) \inter </ ni // i /> = empty +------------------------------------------ :: LetRecReturn +S |- let rec </ ni = ei // i /> in u --> u + + +S |- e --> e' +--------------------------------------- :: Case +S |- case e as n return t of </ alti // i /> --> case e' as n return t of </ alti // i /> + +altj = K </ alphabb_kbb // bb /> </ xcc_tcc // cc /> -> u +u' = u[n |-> e] </ [alphabb_kbb |-> sbb] // bb /> </ [xcc_tcc |-> ecc] // cc /> +-------------------------------------------------------------- :: MatchData +S |- case K </ t'aa // aa /> </ sbb // bb /> </ ecc // cc /> as n return t of </ alti // i /> --> u' + +altj = lit -> u +---------------------------------------------------------------- :: MatchLit +S |- case lit as n return t of </ alti // i /> --> u[n |-> lit] + +altj = _ -> u +no other case matches +------------------------------------------------------------ :: MatchDefault +S |- case e as n return t of </ alti // i /> --> u[n |-> e] + +T </ taa // aa /> ~#k T </ t'aa // aa /> = coercionKind g +forall </ alphaaa_kaa // aa />. forall </ betabb_k'bb // bb />. </ t1cc // cc /> @-> T </ alphaaa_kaa // aa /> = dataConRepType K +</ e'cc = ecc |> (t1cc @ </ [alphaaa_kaa |-> nth aa g] // aa /> </ [betabb_k'bb |-> <sbb>_Nom] // bb />) // cc /> +--------------------------- :: CasePush +S |- case (K </ taa // aa /> </ sbb // bb /> </ ecc // cc />) |> g as n return t2 of </ alti // i /> --> case K </ t'aa // aa /> </ sbb // bb /> </ e'cc // cc /> as n return t2 of </ alti // i /> + +S |- e --> e' +------------------------ :: Cast +S |- e |> g --> e' |> g + +S |- e --> e' +------------------------------ :: Tick +S |- e { tick } --> e' { tick } + diff --git a/docs/core-spec/README b/docs/core-spec/README index e193955490..1fb304d261 100644 --- a/docs/core-spec/README +++ b/docs/core-spec/README @@ -64,7 +64,7 @@ your notation to LaTeX. Three different homs are used: help disambiguate otherwise-ambiguous parses. Getting these right is hard, so if you have trouble, you're not alone. -- In one place, it was necessary to use an @ symbol to disambiguate parses. The +- In a few places, it is necessary to use an @ symbol to disambiguate parses. The @ symbol is not typeset and is used solely for disambiguation. Feel free to use it if necessary to disambiguate other parses. diff --git a/docs/core-spec/core-spec.mng b/docs/core-spec/core-spec.mng index 4b1e986c6d..2e8134c7a1 100644 --- a/docs/core-spec/core-spec.mng +++ b/docs/core-spec/core-spec.mng @@ -7,6 +7,7 @@ \usepackage{xcolor} \usepackage{fullpage} \usepackage{multirow} +\usepackage{url} \newcommand{\ghcfile}[1]{\textsl{#1}} \newcommand{\arraylabel}[1]{\multicolumn{2}{l}{\!\!\!\!\!\!\!\!\!\text{\underline{#1}:}}} @@ -19,7 +20,7 @@ \setlength{\parindent}{0in} \setlength{\parskip}{1ex} -\newcommand{\gram}[1]{\ottgrammartabular{#1\ottinterrule}} +\newcommand{\gram}[1]{\ottgrammartabular{#1\ottafterlastrule}} \begin{document} @@ -29,11 +30,28 @@ System FC, as implemented in GHC\footnote{This document was originally prepared by Richard Eisenberg (\texttt{eir@cis.upenn.edu}), but it should be maintained by anyone who edits the functions or data structures mentioned in this file. Please feel free to contact Richard for more information.}\\ -\Large\today +\Large 2 August, 2013 \end{center} \section{Introduction} +This document presents the typing system of System FC, very closely to how it is +implemented in GHC. Care is taken to include only those checks that are actually +written in the GHC code. It should be maintained along with any changes to this +type system. + +Who will use this? Any implementer of GHC who wants to understand more about the +type system can look here to see the relationships among constructors and the +different types used in the implementation of the type system. Note that the +type system here is quite different from that of Haskell---these are the details +of the internal language, only. + +At the end of this document is a \emph{hypothetical} operational semantics for GHC. +It is hypothetical because GHC does not strictly implement a concrete operational +semantics anywhere in its code. While all the typing rules can be traced back to +lines of real code, the operational semantics do not, in general, have as clear +a provenance. + There are a number of details elided from this presentation. The goal of the formalism is to aid in reasoning about type safety, and checks that do not work toward this goal were omitted. For example, various scoping checks (other @@ -64,7 +82,6 @@ variables: \gram{ \ottz } -foo \gram{ \ottn @@ -132,13 +149,21 @@ a term-level literal, but we are ignoring this distinction here. Invariants on coercions: \begin{itemize} -\item $[[<t1 t2>]]$ is used; never $[[<t1> <t2>]]$. -\item If $[[<T>]]$ is applied to some coercions, at least one of which is not -reflexive, use $[[T </ gi // i />]]$, never $[[<T> g1 g2]] \ldots$. -\item The $[[T]]$ in $[[T </gi//i/>]]$ is never a type synonym, though it could +\item $[[<t1 t2>_R]]$ is used; never $[[<t1>_R <t2>_Nom]]$. +\item If $[[<T>_R]]$ is applied to some coercions, at least one of which is not +reflexive, use $[[T_R </ gi // i />]]$, never $[[<T>_R g1 g2]] \ldots$. +\item The $[[T]]$ in $[[T_R </gi//i/>]]$ is never a type synonym, though it could be a type function. \end{itemize} +Roles label what equality relation a coercion is a witness of. Nominal equality +means that two types are identical (have the same name); representational equality +means that two types have the same representation (introduced by newtypes); and +phantom equality includes all types. See \url{http://ghc.haskell.org/trac/ghc/wiki/Roles} +for more background. + +\gram{\ottR} + Is it a left projection or a right projection? \gram{\ottLorR} @@ -150,6 +175,12 @@ Axioms: \ottaxBranch } +The definition for $[[axBranch]]$ above does not include the list of +incompatible branches (field \texttt{cab\_incomps} of \texttt{CoAxBranch}), +as that would unduly clutter this presentation. Instead, as the list +of incompatible branches can be computed at any time, it is checked for +in the judgment $[[no_conflict]]$. See Section~\ref{sec:no_conflict}. + \subsection{Type constructors} Type constructors in GHC contain \emph{lots} of information. We leave most of it out @@ -179,7 +210,7 @@ the context sometimes requires creating a new, fresh variable name and then applying a substitution. We elide these details in this formalism, but see \coderef{types/Type.lhs}{substTyVarBndr} for details. -\section{Judgments} +\section{Typing judgments} The following functions are used from GHC. Their names are descriptive, and they are not formalized here: \coderef{types/TyCon.lhs}{tyConKind}, @@ -263,12 +294,22 @@ a dead id and for one-tuples. These checks are omitted here. \subsection{Coercion typing} +In the coercion typing judgment, the $\#$ marks are left off the equality +operators to reduce clutter. This is not actually inconsistent, because +the GHC function that implements this check, \texttt{lintCoercion}, actually +returns four separate values (the kind, the two types, and the role), not +a type with head $[[(~#)]]$ or $[[(~R#)]]$. Note that the difference between +these two forms of equality is interpreted in the rules \ottdrulename{Co\_CoVarCoNom} +and \ottdrulename{Co\_CoVarCoRepr}. + \ottdefnlintCoercion{} In \ottdrulename{Co\_AxiomInstCo}, the use of $[[inits]]$ creates substitutions from the first $i$ mappings in $[[ </ [ni |-> si] // i /> ]]$. This has the effect of folding the substitution over the kinds for kind-checking. +See Section~\ref{sec:tyconroles} for more information about $[[tyConRolesX]]$. + \subsection{Name consistency} There are two very similar checks for names, one declared as a local function: @@ -305,17 +346,108 @@ There are two very similar checks for names, one declared as a local function: \ottdefnisSubKind{} +\subsection{Roles} +\label{sec:tyconroles} + +During type-checking, role inference is carried out, assigning roles to the +arguments of every type constructor. The function $[[tyConRoles]]$ extracts these +roles. Also used in other judgments is $[[tyConRolesX]]$, which is the same as +$[[tyConRoles]]$, but with an arbitrary number of $[[Nom]]$ at the end, to account +for potential oversaturation. + +The checks encoded in the following +judgments are run from \coderef{typecheck/TcTyClsDecls.lhs}{checkValidTyCon} +when \texttt{-dcore-lint} is set. + +\ottdefncheckValidRoles{} + +\ottdefncheckXXdcXXroles{} + +In the following judgment, the role $[[R]]$ is an \emph{input}, not an output. + +\ottdefncheckXXtyXXroles{} + +These judgments depend on a sub-role relation: + +\ottdefnltRole{} + \subsection{Branched axiom conflict checking} +\label{sec:no_conflict} The following judgment is used within \ottdrulename{Co\_AxiomInstCo} to make sure that a type family application cannot unify with any previous branch -in the axiom. +in the axiom. The actual code scans through only those branches that are +flagged as incompatible. These branches are stored directly in the +$[[axBranch]]$. However, it is cleaner in this presentation to simply +check for compatibility here. \ottdefncheckXXnoXXconflict{} -The judgment $[[apart]]$ checks to see whether two lists of types are surely apart. -It checks to see if \coderef{types/Unify.lhs}{tcApartTys} returns \texttt{SurelyApart}. -Two types are apart if neither type is a type family application and if they do not -unify. +The judgment $[[apart]]$ checks to see whether two lists of types are surely +apart. $[[apart( </ ti // i />, </ si // i /> )]]$, where $[[ </ ti // i /> +]]$ is a list of types and $[[ </ si // i /> ]]$ is a list of type +\emph{patterns} (as in a type family equation), first flattens the $[[ </ ti + // i /> ]]$ using \coderef{types/FamInstEnv.lhs}{flattenTys} and then checks to +see if \coderef{types/Unify.lhs}{tcUnifyTysFG} returns \texttt{SurelyApart}. +Flattening takes all type family applications and replaces them with fresh variables, +taking care to map identical type family applications to the same fresh variable. + +The algorithm $[[unify]]$ is implemented in \coderef{types/Unify.lhs}{tcUnifyTys}. +It performs a standard unification, returning a substitution upon success. + +\section{Operational semantics} + +\subsection{Disclaimer} +GHC does not implement an operational semantics in any concrete form. Most +of the rules below are implied by algorithms in, for example, the simplifier +and optimizer. Yet, there is no one place in GHC that states these rules, +analogously to \texttt{CoreLint.lhs}. +Nevertheless, these rules are included in this document to help the reader +understand System FC. + +\subsection{The context $[[S]]$} +We use a context $[[S]]$ to keep track of the values of variables in a (mutually) +recursive group. Its definition is as follows: +\[ +[[S]] \quad ::= \quad [[ empty ]] \ |\ [[S]], [[ [n |-> e] ]] +\] +The presence of the context $[[S]]$ is solely to deal with recursion. If your +use of FC does not require modeling recursion, you will not need to track $[[S]]$. + +\subsection{Operational semantics rules} + +\ottdefnstep{} + +\subsection{Notes} + +\begin{itemize} +\item The \ottdrulename{S\_LetRec} and \ottdrulename{S\_LetRecReturn} rules +implement recursion. \ottdrulename{S\_LetRec} adds to the context $[[S]]$ bindings +for all of the mutually recursive equations. Then, after perhaps many steps, +when the body of the $[[let]]\ [[rec]]$ contains no variables that are bound +in the $[[let]]\ [[rec]]$, the context is popped. +\item In the $[[case]]$ rules, a constructor $[[K]]$ is written taking three +lists of arguments: two lists of types and a list of terms. The types passed +in are the universally and, respectively, existentially quantified type variables +to the constructor. The terms are the regular term arguments stored in an +algebraic datatype. Coercions (say, in a GADT) are considered term arguments. +\item The rule \ottdrulename{S\_CasePush} is the most complex rule. +\begin{itemize} +\item The logic in this rule is implemented in \coderef{coreSyn/CoreSubst.lhs}{exprIsConApp\_maybe}. +\item The $[[coercionKind]]$ function (\coderef{types/Coercion.lhs}{coercionKind}) +extracts the two types (and their kind) from +a coercion. It does not require a typing context, as it does not \emph{check} the +coercion, just extracts its types. +\item The $[[dataConRepType]]$ function (\coderef{basicTypes/DataCon.lhs}{dataConRepType}) extracts the full type of a data constructor. Following the notation for +constructor expressions, the parameters to the constructor are broken into three +groups: universally quantified types, existentially quantified types, and terms. +\item The substitutions in the last premise to the rule are unusual: they replace +\emph{type} variables with \emph{coercions}. This substitution is called lifting +and is implemented in \coderef{types/Coercion.lhs}{liftCoSubst}. The notation is +essentially a pun on the fact that types and coercions have such similar structure. +\item Note that the types $[[ </ sbb // bb /> ]]$---the existentially quantified +types---do not change during this step. +\end{itemize} +\end{itemize} \end{document} diff --git a/docs/core-spec/core-spec.pdf b/docs/core-spec/core-spec.pdf Binary files differindex be13ca22c5..4e4ca924fb 100644 --- a/docs/core-spec/core-spec.pdf +++ b/docs/core-spec/core-spec.pdf diff --git a/docs/storage-mgt/ldv.tex b/docs/storage-mgt/ldv.tex index 936407c701..79f0f23282 100644 --- a/docs/storage-mgt/ldv.tex +++ b/docs/storage-mgt/ldv.tex @@ -388,7 +388,7 @@ There are four cases in which a closure is destroyed: \begin{enumerate} \item A closure is overwritten with a blackhole: - @UPD_BH_UPDATABLE()@ and @UPD_BH_SINGLE_ENTRY()@ in @includes/StgMacros.h@, + @UPD_BH_UPDATABLE()@ in @includes/StgMacros.h@, @threadLazyBlackHole()@ and @threadSqueezeStack()@ in @GC.c@, the entry code for @BLACKHOLE@ closures in @StgMiscClosures.hc@ (a @BLACKHOLE@ closure is changed into a @BLACKHOLE_BQ@ closure). @@ -499,7 +499,7 @@ size, we invoke @LDV_recordDead_FILL_SLOP_DYNAMIC()@ only from: \begin{enumerate} \item @threadLazyBlackHole()@ and @threadSqueezeStack()@ in @GC.c@ (for lazy blackholing), -\item @UPD_BH_UPDATABLE()@ and @UPD_BH_SINGLE_ENTRY()@ in +\item @UPD_BH_UPDATABLE()@ in @includes/StgMacros.h@ (for eager blackholing, which isn't the default), \item @updateWithIndirection()@ and @updateWithPermIndirection()@ @@ -639,7 +639,7 @@ Only three files (@includes/StgLdvProf.h@, @LdvProfile.c@, and with LDVU profiling. \item[ClosureMacros.h] changes macro @SET_PROF_HDR()@. \item[Stg.h] includes th header file @StgLdvProf.h@. -\item[StgMacros.h] changes macros @UPD_BH_UPDATABLE()@ and @UPD_BH_SINGLE_ENTRY()@. +\item[StgMacros.h] changes macros @UPD_BH_UPDATABLE()@. \end{description} @\rts@ directory: diff --git a/docs/users_guide/7.8.1-notes.xml b/docs/users_guide/7.8.1-notes.xml index 20785d09fa..f3fa0e1984 100644 --- a/docs/users_guide/7.8.1-notes.xml +++ b/docs/users_guide/7.8.1-notes.xml @@ -3,9 +3,9 @@ <title>Release notes for version 7.8.1</title> <para> - The significant changes to the various parts of the compiler are - listed in the following sections. There have also been numerous bug - fixes and performance improvements over the 7.6 branch. + The significant changes to the various parts of the compiler are listed + in the following sections. There have also been numerous bug fixes and + performance improvements over the 7.6 branch. </para> <sect2> @@ -16,18 +16,585 @@ </para> <itemizedlist> - <listitem> - <para> - TODO: Format these nicely and expand: - - type holes - - rebindable list syntax - - major changes to the type inference engine - - type level naturals - - overlapping type families - - new codegen - </para> - </listitem> + <listitem> + <para> + GHC now supports "type holes" with the + <literal>TypeHoles</literal> extension. When enabled, the + unbound literal <literal>_</literal> may be used during + development in place of a regular identifier, and GHC will + respond with the type necessary to "fill in the hole." + + TODO FIXME: reference. + </para> + </listitem> + + <listitem> + <para> + It is now possible to declare a 'closed' <literal>type + family</literal> when using the + <literal>TypeFamilies</literal> extension. A closed + <literal>type family</literal> cannot have any + instances created other than the ones in its + definition. + + TODO FIXME: reference. + </para> + </listitem> + + <listitem> + <para> + Use of the <literal>GeneralizedNewtypeDeriving</literal> + extension is now subject to <emphasis>role checking</emphasis>, + to ensure type safety of the derived instances. As this change + increases the type safety of GHC, it is possible that some code + that previously compiled will no longer work. + + TODO FIXME: reference. + </para> + </listitem> + + <listitem> + <para> + GHC now supports overloading list literals using the new + <literal>OverloadedLists</literal> extension. + + TODO FIXME: reference. + </para> + </listitem> + + <listitem> + <para> + There has been significant overhaul of the type inference engine and + constraint solver. + + TODO FIXME: reference. + </para> + </listitem> + + <listitem> + <para> + By default, GHC will now unbox all "small" strict + fields in a data type. A "small" data type is one + whose size is equivalent to or smaller than the native + word size of the machine. This means you no longer + have to specify <literal>UNPACK</literal> pragmas for + e.g. strict <literal>Int</literal> fields. This also + applies to floating-point values. + </para> + </listitem> + + <listitem> + <para> + GHC now has a brand-new I/O manager that scales significantly + better for larger workloads compared to the previous one. It + should scale linearly up to approximately 32 cores. + </para> + </listitem> + + <listitem> + <para> + The LLVM backend now supports 128bit SIMD operations. This is + now exploited in both the <literal>vector</literal> and + <literal>dph</literal> packages, exposing a high level + interface. + + TODO FIXME: reference. + </para> + <para> + This is only available with the LLVM backend. + </para> + </listitem> + + <listitem> + <para> + The new code generator, after significant work by many + individuals over the past several years, is now enabled by + default. This is a complete rewrite of the STG to Cmm + transformation. In general, your programs may get slightly + faster. + </para> + + <para> + The old code generator has been removed completely. + </para> + </listitem> + + <listitem> + <para> + PrimOps for comparing unboxed values now return + <literal>Int#</literal> instead of <literal>Bool</literal>. + New PrimOps' names end with <literal>$#</literal> for operators and + <literal>I#</literal> for ordinary names, e.g. <literal>==$#</literal> + compares <literal>Int#</literal>s for equality and + <literal>eqCharI#</literal> does the same for <literal>Char#</literal>s. + Old PrimOps have been removed and turned into wrappers. See + <ulink url="http://ghc.haskell.org/trac/ghc/wiki/NewPrimopsInGHC7.8"> + this GHC wiki page</ulink> for instructions how to update your + existing code. + </para> + </listitem> + + <listitem> + <para> + TODO: mention dynamic changes + </para> + </listitem> + + <listitem> + <para> + TODO: mention new <literal>Typeable</literal> and + <literal>AutoDeriveTypeable</literal> + </para> + </listitem> + </itemizedlist> + </sect2> + + <sect2> + <title>Full details</title> + <sect3> + <title>Language</title> + <itemizedlist> + <listitem> + <para> + There is a new extension, + <literal>NullaryTypeClasses</literal>, which + allows you to declare a type class without any + parameters. + + TODO FIXME: example? + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>Compiler</title> + <itemizedlist> + <listitem> + <para> + GHC now supports a <literal>--show-options</literal> flag, + which will dump all of the flags it supports to standard out. + </para> + </listitem> + <listitem> + <para> + It's now possible to switch the system linker on Linux + (between GNU gold and GNU ld) at runtime without problem. + </para> + </listitem> + <listitem> + <para> + The <literal>-fwarn-dodgy-imports</literal> flag now warns + in the case an <literal>import</literal> statement hides an + entity which is not exported. + </para> + </listitem> + <listitem> + <para> + The LLVM backend was overhauled and rewritten, and + should hopefully be easier to maintain and work on + in the future. + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>GHCi</title> + <itemizedlist> + <listitem> + <para> + GHCi now supports a <literal>prompt2</literal> + setting, which allows you to customize the + continuation prompt of multi-line input. + + TODO FIXME: reference. + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>Template Haskell</title> + <itemizedlist> + <listitem> + <para> + TODO FIXME + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>Runtime system</title> + <itemizedlist> + <listitem> + <para> + The performance of <literal>StablePtr</literal>s and + <literal>StableName</literal>s has been improved. + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>Build system</title> + <itemizedlist> + <listitem> + <para> + GHC >= 7.4 is now required for bootstrapping. + </para> + </listitem> + <listitem> + <para> + GHC can now be built with Clang, and use Clang as the + preprocessor for Haskell code. Only Clang version 3.4svn is + reliably supported. + </para> + </listitem> + </itemizedlist> + </sect3> + </sect2> + + <sect2> + <title>Libraries</title> + + <para> + There have been some changes that have effected multiple + libraries: + </para> + + <itemizedlist> + <listitem> + <para> + TODO FIXME + </para> + </listitem> </itemizedlist> + + <para> + The following libraries have been removed from the GHC tree: + </para> + + <itemizedlist> + <listitem> + <para>TODO FIXME</para> + </listitem> + </itemizedlist> + + <para> + The following libraries have been added to the GHC tree: + </para> + + <itemizedlist> + <listitem> + <para>TODO FIXME</para> + </listitem> + </itemizedlist> + + <sect3> + <title>array</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>base</title> + <itemizedlist> + <listitem> + <para> + Version number 4.7.0.0 (was 4.6.0.1) + </para> + </listitem> + <listitem> + <para> + The <literal>Control.Category</literal> module now has the + <literal>PolyKinds</literal> extension enabled, meaning + that instances of <literal>Category</literal> no longer + need be of kind <literal>* -> * -> *</literal> + </para> + </listitem> + <listitem> + <para> + There are now <literal>Foldable</literal> and <literal>Traversable</literal> + instances for <literal>Either a</literal> and <literal>(,) a</literal> + </para> + </listitem> + <listitem> + <para> + <literal>Control.Concurrent.MVar</literal> has a new + implementation of <literal>readMVar</literal>, which + fixes a long-standing bug where + <literal>readMVar</literal> is only atomic if there + are no other threads running + <literal>putMVar</literal>. + <literal>readMVar</literal> now is atomic, and is + guaranteed to return the value from the first + <literal>putMVar</literal>. There is also a new <literal>tryReadMVar</literal> + which is a non-blocking version. + </para> + </listitem> + <listitem> + <para> + There are now byte endian-swapping primitives + available in <literal>Data.Word</literal>, which + use optimized machine instructions when available. + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>bin-package-db</title> + <itemizedlist> + <listitem> + <para> + This is an internal package, and should not be used. + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>binary</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>bytestring</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>Cabal</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>containers</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>deepseq</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>directory</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>filepath</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>ghc-prim</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>haskell98</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>haskell2010</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>hoopl</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>hpc</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>integer-gmp</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>old-locale</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>old-time</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>process</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>template-haskell</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>time</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>unix</title> + <itemizedlist> + <listitem> + <para> + Version number 2.7.0.0 (was 2.6.0.0) + </para> + </listitem> + <listitem> + <para> + A crash in <literal>getGroupEntryForID</literal> + (and related functions like + <literal>getUserEntryForID</literal> and + <literal>getUserEntryForName</literal>) in + multi-threaded applications has been fixed. + </para> + </listitem> + <listitem> + <para> + The functions <literal>getGroupEntryForID</literal> + and <literal>getUserEntryForID</literal> now fail + with a <literal>isDoesNotExist</literal> error when + the specified ID cannot be found. + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> + <title>Win32</title> + <itemizedlist> + <listitem> + <para> + Version number XXXX (was XXXX) + </para> + </listitem> + </itemizedlist> + </sect3> </sect2> </sect1> - diff --git a/docs/users_guide/extending_ghc.xml b/docs/users_guide/extending_ghc.xml index 1abe8a8f68..dc8d5b4739 100644 --- a/docs/users_guide/extending_ghc.xml +++ b/docs/users_guide/extending_ghc.xml @@ -247,9 +247,8 @@ pass = do dflags <- getDynFlags {-# LANGUAGE DeriveDataTypeable #-} module SayAnnNames.Plugin (plugin, SomeAnn) where import GhcPlugins -import Control.Monad (when) +import Control.Monad (unless) import Data.Data -import Data.Typeable data SomeAnn = SomeAnn deriving (Data, Typeable) @@ -264,13 +263,15 @@ install _ todo = do return (CoreDoPluginPass "Say name" pass : todo) pass :: ModGuts -> CoreM ModGuts -pass g = mapM_ (printAnn g) (mg_binds g) >> return g - where printAnn :: ModGuts -> CoreBind -> CoreM CoreBind - printAnn guts bndr@(NonRec b _) = do +pass g = do + dflags <- getDynFlags + mapM_ (printAnn dflags g) (mg_binds g) >> return g + where printAnn :: DynFlags -> ModGuts -> CoreBind -> CoreM CoreBind + printAnn dflags guts bndr@(NonRec b _) = do anns <- annotationsOn guts b :: CoreM [SomeAnn] - when (not $ null anns) $ putMsgS $ "Annotated binding found: " ++ showSDoc (ppr b) + unless (null anns) $ putMsgS $ "Annotated binding found: " ++ showSDoc dflags (ppr b) return bndr - printAnn _ bndr = return bndr + printAnn _ _ bndr = return bndr annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a] annotationsOn guts bndr = do diff --git a/docs/users_guide/external_core.xml b/docs/users_guide/external_core.xml index faf7148f20..bc9d350d34 100644 --- a/docs/users_guide/external_core.xml +++ b/docs/users_guide/external_core.xml @@ -27,8 +27,7 @@ I am unsure of the proper DocBook elements. <para>Andrew Tolmach, Tim Chevalier ({apt,tjc}@cs.pdx.edu) and The GHC Team</para> - <abstract> - <para>This document provides a precise definition for the GHC Core + <para>This chapter provides a precise definition for the GHC Core language, so that it can be used to communicate between GHC and new stand-alone compilation tools such as back-ends or optimizers.<footnote> @@ -51,8 +50,6 @@ I am unsure of the proper DocBook elements. formally embody the static and dynamic semantics, are available separately.</para> - </abstract> - <section id="introduction"> <title>Introduction</title> diff --git a/docs/users_guide/ffi-chap.xml b/docs/users_guide/ffi-chap.xml index a2fe177612..32f714851f 100644 --- a/docs/users_guide/ffi-chap.xml +++ b/docs/users_guide/ffi-chap.xml @@ -274,7 +274,7 @@ extern HsInt foo(HsInt a0);</programlisting> <filename>M_stub.o</filename> in the final link command line, or you'll get link errors for the missing function(s) (this isn't necessary when building your program with <literal>ghc - ––make</literal>, as GHC will automatically link in the + --make</literal>, as GHC will automatically link in the correct bits).</para> <sect3 id="using-own-main"> diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 5366360f37..ba4b0b13b0 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -30,7 +30,7 @@ <entry>-</entry> </row> <row> - <entry><option>-help</option></entry> + <entry><option>--help</option></entry> <entry>help</entry> <entry>mode</entry> <entry>-</entry> @@ -54,31 +54,37 @@ <entry>-</entry> </row> <row> - <entry><option>––supported-extensions</option> or <option>––supported-languages</option></entry> + <entry><option>--supported-extensions</option> or <option>--supported-languages</option></entry> <entry>display the supported languages and language extensions</entry> <entry>mode</entry> <entry>-</entry> </row> <row> - <entry><option>––info</option></entry> + <entry><option>--show-options</option></entry> + <entry>display the supported command line options</entry> + <entry>mode</entry> + <entry>-</entry> + </row> + <row> + <entry><option>--info</option></entry> <entry>display information about the compiler</entry> <entry>mode</entry> <entry>-</entry> </row> <row> - <entry><option>––version</option></entry> + <entry><option>--version</option></entry> <entry>display GHC version</entry> <entry>mode</entry> <entry>-</entry> </row> <row> - <entry><option>––numeric-version</option></entry> + <entry><option>--numeric-version</option></entry> <entry>display GHC version (numeric only)</entry> <entry>mode</entry> <entry>-</entry> </row> <row> - <entry><option>––print-libdir</option></entry> + <entry><option>--print-libdir</option></entry> <entry>display GHC library directory</entry> <entry>mode</entry> <entry>-</entry> @@ -784,6 +790,12 @@ <entry><option>-XNPlusKPatterns</option></entry> </row> <row> + <entry><option>-XNegativeLiterals</option></entry> + <entry>Enable support for negative literals</entry> + <entry>dynamic</entry> + <entry><option>-XNoNegativeLiterals</option></entry> + </row> + <row> <entry><option>-XNoTraditionalRecordSyntax</option></entry> <entry>Disable support for traditional record syntax (as supported by Haskell 98) <literal>C {f = x}</literal></entry> <entry>dynamic</entry> @@ -1009,7 +1021,7 @@ </row> <row> <entry><option>-XTypeOperators</option></entry> - <entry>Enable type operators.</entry> + <entry>Enable <link linkend="type-operators">type operators</link>.</entry> <entry>dynamic</entry> <entry><option>-XNoTypeOperators</option></entry> </row> diff --git a/docs/users_guide/ghc.mk b/docs/users_guide/ghc.mk index bfd9433f7c..69864cc689 100644 --- a/docs/users_guide/ghc.mk +++ b/docs/users_guide/ghc.mk @@ -20,8 +20,8 @@ docs/users_guide_DOCBOOK_SOURCES := \ $(wildcard docs/users_guide/*.xml) \ $(basename $(wildcard docs/users_guide/*.xml.in))) -$(docs/users_guide_GENERATED_DOCBOOK_SOURCES): %.xml: inplace/bin/mkUserGuidePart$(exeext) - inplace/bin/mkUserGuidePart$(exeext) $@ +$(docs/users_guide_GENERATED_DOCBOOK_SOURCES): %.xml: $(mkUserGuidePart_INPLACE) + $(mkUserGuidePart_INPLACE) $@ $(eval $(call docbook,docs/users_guide,users_guide)) diff --git a/docs/users_guide/ghci.xml b/docs/users_guide/ghci.xml index 93ab62bf29..df483e81f3 100644 --- a/docs/users_guide/ghci.xml +++ b/docs/users_guide/ghci.xml @@ -161,7 +161,7 @@ Ok, modules loaded: Main. <para>or it can be set using the <literal>:set</literal> command from within GHCi (see <xref linkend="ghci-cmd-line-options"/>)<footnote><para>Note that in - GHCi, and <option>––make</option> mode, the <option>-i</option> + GHCi, and <option>--make</option> mode, the <option>-i</option> option is used to specify the search path for <emphasis>source</emphasis> files, whereas in standard batch-compilation mode the <option>-i</option> option is used to @@ -338,7 +338,7 @@ Compiling A ( A.hs, interpreted ) <para>HINT: since GHCi will only use a compiled object file if it can be sure that the compiled version is up-to-date, a good technique when working on a large program is to occasionally run - <literal>ghc ––make</literal> to compile the whole project (say + <literal>ghc --make</literal> to compile the whole project (say before you go for lunch :-), then continue working in the interpreter. As you modify code, the changed modules will be interpreted, but the rest of the project will remain @@ -1715,7 +1715,7 @@ a :: a <para>The history is only available when using <literal>:trace</literal>; the reason for this is we found that logging each breakpoint in the history cuts performance by a factor of - 2 or more. By default, GHCi remembers the last 50 steps in the history, but this can be changed with the <option>-fghci-hist-size=<replaceable>n</replaceable></option><indexterm><primary><option>–fghci-hist-size</option></primary></indexterm> option).</para> + 2 or more. By default, GHCi remembers the last 50 steps in the history, but this can be changed with the <option>-fghci-hist-size=<replaceable>n</replaceable></option><indexterm><primary><option>-fghci-hist-size</option></primary></indexterm> option).</para> </sect2> <sect2 id="ghci-debugger-exceptions"> @@ -1910,10 +1910,10 @@ Just 20 <sect1 id="ghci-invocation"> <title>Invoking GHCi</title> <indexterm><primary>invoking</primary><secondary>GHCi</secondary></indexterm> - <indexterm><primary><option>––interactive</option></primary></indexterm> + <indexterm><primary><option>--interactive</option></primary></indexterm> <para>GHCi is invoked with the command <literal>ghci</literal> or - <literal>ghc ––interactive</literal>. One or more modules or + <literal>ghc --interactive</literal>. One or more modules or filenames can also be specified on the command line; this instructs GHCi to load the specified modules or filenames (and all the modules they depend on), just as if you had said @@ -2180,6 +2180,93 @@ maybe :: b -> (a -> b) -> Maybe a -> b <varlistentry> <term> + <literal>:complete</literal> <replaceable>type</replaceable> + <optional><replaceable>n</replaceable>-</optional><optional><replaceable>m</replaceable></optional> + <replaceable>string-literal</replaceable> + <indexterm><primary><literal>:complete</literal></primary></indexterm> + </term> + <listitem> + <para>This command allows to request command completions + from GHCi even when interacting over a pipe instead of a + proper terminal and is designed for integrating GHCi's + completion with text editors and IDEs.</para> + + <para>When called, <literal>:complete</literal> prints the + <replaceable>n</replaceable><superscript>th</superscript> to + <replaceable>m</replaceable><superscript>th</superscript> + completion candidates for the partial input + <replaceable>string-literal</replaceable> for the completion + domain denoted by + <replaceable>type</replaceable>. Currently, only the + <literal>repl</literal> domain is supported which denotes + the kind of completion that would be provided interactively + by GHCi at the input prompt.</para> + + <para>If omitted, <replaceable>n</replaceable> and + <replaceable>m</replaceable> default to the first or last + available completion candidate respectively. If there are + less candidates than requested via the range argument, + <replaceable>n</replaceable> and + <replaceable>m</replaceable> are implicitly capped to the + number of available completition candidates.</para> + + <para>The output of <literal>:complete</literal> begins with + a header line containing three space-delimited fields: + + <itemizedlist> + <listitem>An integer denoting the number + <replaceable>l</replaceable> of printed + completions,</listitem> + + <listitem>an integer denoting the total number of + completions available, and finally</listitem> + + <listitem>a string literal denoting a common + prefix to be added to the returned completion + candidates.</listitem> + </itemizedlist> + + The header line is followed by <replaceable>l</replaceable> + lines each containing one completion candidate encoded as + (quoted) string literal. Here are some example invocations + showing the various cases:</para> + +<screen> +Prelude> :complete repl 0 "" +0 470 "" +Prelude> :complete repl 5 "import For" +5 21 "import " +"Foreign" +"Foreign.C" +"Foreign.C.Error" +"Foreign.C.String" +"Foreign.C.Types" +Prelude> :complete repl 5-10 "import For" +6 21 "import " +"Foreign.C.Types" +"Foreign.Concurrent" +"Foreign.ForeignPtr" +"Foreign.ForeignPtr.Safe" +"Foreign.ForeignPtr.Unsafe" +"Foreign.Marshal" +Prelude> :complete repl 20- "import For" +2 21 "import " +"Foreign.StablePtr" +"Foreign.Storable" +Prelude> :complete repl "map" +3 3 "" +"map" +"mapM" +"mapM_" +Prelude> :complete repl 5-10 "map" +0 3 "" +</screen> + + </listitem> + </varlistentry> + + <varlistentry> + <term> <literal>:continue</literal> <indexterm><primary><literal>:continue</literal></primary></indexterm> </term> @@ -2255,11 +2342,11 @@ Prelude> :mycd .. </screen> <para>Or I could define a simple way to invoke - “<literal>ghc ––make Main</literal>” in the + “<literal>ghc --make Main</literal>” in the current directory:</para> <screen> -Prelude> :def make (\_ -> return ":! ghc ––make Main") +Prelude> :def make (\_ -> return ":! ghc --make Main") </screen> <para>We can define a command that reads GHCi input from a @@ -2410,9 +2497,11 @@ Prelude> :. cmds.ghci and (b) all the other things mentioned in the instance are in scope (either qualified or otherwise) as a result of a <literal>:load</literal> or <literal>:module</literal> commands. </para> + <para> The command <literal>:info!</literal> works in a similar fashion but it removes restriction (b), showing all instances that are in scope and mention <replaceable>name</replaceable> in their head. + </para> </listitem> </varlistentry> @@ -2426,7 +2515,21 @@ Prelude> :. cmds.ghci <para>Infers and prints the kind of <replaceable>type</replaceable>. The latter can be an arbitrary type expression, including a partial application of a type constructor, - such as <literal>Either Int</literal>. If you specify the + such as <literal>Either Int</literal>. In fact, <literal>:kind</literal> + even allows you to write a partial application of a type synonym (usually disallowed), + so that this works: +<programlisting> +ghci> type T a b = (a,b,a) +ghci> :k T Int Bool +T Int Bool :: * +ghci> :k T +T :: * -> * -> * +ghci> :k T Int +T Int :: * -> * +</programlisting> + </para> + <para> + If you specify the optional "<literal>!</literal>", GHC will in addition normalise the type by expanding out type synonyms and evaluating type-function applications, and display the normalised result.</para> @@ -2684,8 +2787,10 @@ bar <para>Sets the string to be used as the prompt in GHCi. Inside <replaceable>prompt</replaceable>, the sequence <literal>%s</literal> is replaced by the names of the - modules currently in scope, and <literal>%%</literal> is - replaced by <literal>%</literal>. If <replaceable>prompt</replaceable> + modules currently in scope, <literal>%l</literal> is replaced + by the line number (as referenced in compiler messages) of the + current prompt, and <literal>%%</literal> is replaced by + <literal>%</literal>. If <replaceable>prompt</replaceable> starts with " then it is parsed as a Haskell String; otherwise it is treated as a literal string.</para> </listitem> @@ -2693,6 +2798,16 @@ bar <varlistentry> <term> + <literal>:set</literal> <literal>prompt2</literal> <replaceable>prompt</replaceable> + </term> + <listitem> + <para>Sets the string to be used as the continuation prompt + (used when using the <literal>:{</literal> command) in GHCi.</para> + </listitem> + </varlistentry> + + <varlistentry> + <term> <literal>:set</literal> <literal>stop</literal> [<replaceable>num</replaceable>] <replaceable>cmd</replaceable> </term> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index c396237f27..0b16156595 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -440,6 +440,21 @@ Indeed, the bindings can even be recursive. </para> </sect2> + <sect2 id="negative-literals"> + <title>Negative Literals</title> + <para> + The literal <literal>-123</literal> is, according to + Haskell98 and Haskell 2010, desugared as + <literal>negate (fromInteger 123)</literal>. + </para> + + <para> + The language extension <option>-XNegativeLiterals</option> + means that it is instead desugared as + <literal>fromInteger (-123)</literal>. + </para> + </sect2> + <!-- ====================== HIERARCHICAL MODULES ======================= --> @@ -844,10 +859,10 @@ To disable it, you can use the <option>-XNoTraditionalRecordSyntax</option> flag The do-notation of Haskell 98 does not allow <emphasis>recursive bindings</emphasis>, that is, the variables bound in a do-expression are visible only in the textually following code block. Compare this to a let-expression, where bound variables are visible in the entire binding - group. -</para> + group. +</para> -<para> +<para> It turns out that such recursive bindings do indeed make sense for a variety of monads, but not all. In particular, recursion in this sense requires a fixed-point operator for the underlying monad, captured by the <literal>mfix</literal> method of the <literal>MonadFix</literal> class, defined in <literal>Control.Monad.Fix</literal> as follows: @@ -888,7 +903,7 @@ justOnes = do { rec { xs <- Just (1:xs) } As you can guess <literal>justOnes</literal> will evaluate to <literal>Just [-1,-1,-1,...</literal>. </para> -<para> +<para> GHC's implementation the mdo-notation closely follows the original translation as described in the paper <ulink url="https://sites.google.com/site/leventerkok/recdo.pdf">A recursive do for Haskell</ulink>, which in turn is based on the work <ulink url="http://sites.google.com/site/leventerkok/erkok-thesis.pdf">Value Recursion @@ -922,14 +937,14 @@ As you can guess <literal>justOnes</literal> will evaluate to <literal>Just [-1, to the underlying monadic value-recursion operator <literal>mfix</literal>, belonging to the <literal>MonadFix</literal> class. Here is an example: <programlisting> -rec { b <- f a c ===> (b,c) <- mfix (\~(b,c) -> do { b <- f a c - ; c <- f b a } ; c <- f b a - ; return (b,c) }) +rec { b <- f a c ===> (b,c) <- mfix (\ ~(b,c) -> do { b <- f a c + ; c <- f b a } ; c <- f b a + ; return (b,c) }) </programlisting> As usual, the meta-variables <literal>b</literal>, <literal>c</literal> etc., can be arbitrary patterns. In general, the statement <literal>rec <replaceable>ss</replaceable></literal> is desugared to the statement <programlisting> -<replaceable>vs</replaceable> <- mfix (\~<replaceable>vs</replaceable> -> do { <replaceable>ss</replaceable>; return <replaceable>vs</replaceable> }) +<replaceable>vs</replaceable> <- mfix (\ ~<replaceable>vs</replaceable> -> do { <replaceable>ss</replaceable>; return <replaceable>vs</replaceable> }) </programlisting> where <replaceable>vs</replaceable> is a tuple of the variables bound by <replaceable>ss</replaceable>. </para> @@ -1677,8 +1692,8 @@ Note that <literal>\case</literal> starts a layout, so you can write <sect2 id="empty-case"> <title>Empty case alternatives</title> <para> -The <option>-XEmptyCase</option> flag enables -case expressions, or lambda-case expressions, that have no alternatives, +The <option>-XEmptyCase</option> flag enables +case expressions, or lambda-case expressions, that have no alternatives, thus: <programlisting> case e of { } -- No alternatives @@ -1692,7 +1707,7 @@ has no non-bottom values. For example: f :: Void -> Int f x = case x of { } </programlisting> -With dependently-typed features it is more useful +With dependently-typed features it is more useful (see <ulink url="http://hackage.haskell.org/trac/ghc/ticket/2431">Trac</ulink>). For example, consider these two candidate definitions of <literal>absurd</literal>: <programlisting> @@ -1704,7 +1719,7 @@ absurd x = error "absurd" -- (A) absurd x = case x of {} -- (B) </programlisting> We much prefer (B). Why? Because GHC can figure out that <literal>(True :~: False)</literal> -is an empty type. So (B) has no partiality and GHC should be able to compile with +is an empty type. So (B) has no partiality and GHC should be able to compile with <option>-fwarn-incomplete-patterns</option>. (Though the pattern match checking is not yet clever enough to do that. On the other hand (A) looks dangerous, and GHC doesn't check to make @@ -2284,25 +2299,10 @@ to be written infix, very much like expressions. More specifically: </para></listitem> <listitem><para> Types, and class constraints, can be written infix. For example - <screen> - x :: Int :*: Bool - f :: (a :=: b) => a -> b - </screen> - </para></listitem> -<listitem><para> - A type variable can be an (unqualified) operator e.g. <literal>+</literal>. - The lexical syntax is the same as that for variable operators, excluding "(.)", - "(!)", and "(*)". In a binding position, the operator must be - parenthesised. For example: -<programlisting> - type T (+) = Int + Int - f :: T Either - f = Left 3 - - liftA2 :: Arrow (~>) - => (a -> b -> c) -> (e ~> a) -> (e ~> b) -> (e ~> c) - liftA2 = ... -</programlisting> +<screen> + x :: Int :*: Bool + f :: (a :=: b) => a -> b +</screen> </para></listitem> <listitem><para> Back-quotes work @@ -2328,6 +2328,56 @@ to be written infix, very much like expressions. More specifically: </para> </sect2> +<sect2 id="type-operators"> +<title>Type operators</title> +<para> +In types, an operator symbol like <literal>(+)</literal> is normally treated as a type +<emphasis>variable</emphasis>, just like <literal>a</literal>. Thus in Haskell 98 you can say +<programlisting> +type T (+) = ((+), (+)) +-- Just like: type T a = (a,a) + +f :: T Int -> Int +f (x,y)= x +</programlisting> +As you can see, using operators in this way is not very useful, and Haskell 98 does not even +allow you to write them infix. +</para> +<para> +The language <option>-XTypeOperators</option> changes this behaviour: +<itemizedlist> +<listitem><para> +Operator symbols become type <emphasis>constructors</emphasis> rather than +type <emphasis>variables</emphasis>. +</para></listitem> +<listitem><para> +Operator symbols in types can be written infix, both in definitions and uses. +for example: +<programlisting> +data a + b = Plus a b +type Foo = Int + Bool +</programlisting> +</para></listitem> +<listitem><para> +There is now some potential ambiguity in import and export lists; for example +if you write <literal>import M( (+) )</literal> do you mean the +<emphasis>function</emphasis> <literal>(+)</literal> or the +<emphasis>type constructor</emphasis> <literal>(+)</literal>? +The default is the former, but GHC allows you to specify the latter +by preceding it with the keyword <literal>type</literal>, thus: +<programlisting> +import M( type (+) ) +</programlisting> +</para></listitem> +<listitem><para> +The fixity of a type operator may be set using the usual fixity declarations +but, as in <xref linkend="infix-tycons"/>, the function and type constructor share +a single fixity. +</para></listitem> +</itemizedlist> +</para> +</sect2> + <sect2 id="type-synonyms"> <title>Liberalised type synonyms</title> @@ -3086,12 +3136,11 @@ selectors. Here is the example of that section, in GADT-style syntax: <programlisting> data Counter a where - NewCounter { _this :: self - , _inc :: self -> self - , _display :: self -> IO () - , tag :: a - } - :: Counter a + NewCounter :: { _this :: self + , _inc :: self -> self + , _display :: self -> IO () + , tag :: a + } -> Counter a </programlisting> As before, only one selector function is generated here, that for <literal>tag</literal>. Nevertheless, you can still use all the field names in pattern matching and record construction. @@ -3105,7 +3154,7 @@ So GHC implements the following design: a data constructor declared in a GADT-st declaration is displayed infix by <literal>Show</literal> iff (a) it is an operator symbol, (b) it has two arguments, (c) it has a programmer-supplied fixity declaration. For example <programlisting> - infix 6 (:--:) + infix 6 (:--:) data T a where (:--:) :: Int -> Bool -> T Int </programlisting> @@ -3203,17 +3252,17 @@ As mentioned in <xref linkend="gadt-style"/>, record syntax is supported. For example: <programlisting> data Term a where - Lit { val :: Int } :: Term Int - Succ { num :: Term Int } :: Term Int - Pred { num :: Term Int } :: Term Int - IsZero { arg :: Term Int } :: Term Bool - Pair { arg1 :: Term a - , arg2 :: Term b - } :: Term (a,b) - If { cnd :: Term Bool - , tru :: Term a - , fls :: Term a - } :: Term a + Lit :: { val :: Int } -> Term Int + Succ :: { num :: Term Int } -> Term Int + Pred :: { num :: Term Int } -> Term Int + IsZero :: { arg :: Term Int } -> Term Bool + Pair :: { arg1 :: Term a + , arg2 :: Term b + } -> Term (a,b) + If :: { cnd :: Term Bool + , tru :: Term a + , fls :: Term a + } -> Term a </programlisting> However, for GADTs there is the following additional constraint: every constructor that has a field <literal>f</literal> must have @@ -3389,10 +3438,13 @@ modules <literal>Data.Typeable</literal> and <literal>Data.Generics</literal> re </para> <para>Since GHC 7.8.1, <literal>Typeable</literal> is kind-polymorphic (see <xref linkend="kind-polymorphism"/>) and can be derived for any datatype and -type class. Instances for datatypes can be derived by attaching a +type class. Instances for datatypes can be derived by attaching a <literal>deriving Typeable</literal> clause to the datatype declaration, or by using standalone deriving (see <xref linkend="stand-alone-deriving"/>). Instances for type classes can only be derived using standalone deriving. +For data families, <literal>Typeable</literal> should only be derived for the +uninstantiated family type; each instance will then automatically have a +<literal>Typeable</literal> instance too. See also <xref linkend="auto-derive-typeable"/>. </para> <para> @@ -3434,7 +3486,9 @@ can be mentioned in the <literal>deriving</literal> clause. <para> The flag <option>-XAutoDeriveTypeable</option> triggers the generation of derived <literal>Typeable</literal> instances for every datatype and type -class declaration in the module it is used. This flag implies +class declaration in the module it is used. It will also generate +<literal>Typeable</literal> instances for any promoted data constructors +(<xref linkend="promotion"/>). This flag implies <option>-XDeriveDataTypeable</option> (<xref linkend="deriving-typeable"/>). </para> @@ -3471,7 +3525,7 @@ dictionary, only slower! </para> -<sect3> <title> Generalising the deriving clause </title> +<sect3 id="generalized-newtype-deriving"> <title> Generalising the deriving clause </title> <para> GHC now permits such instances to be derived instead, using the flag <option>-XGeneralizedNewtypeDeriving</option>, @@ -3592,6 +3646,8 @@ where derive these classes for a newtype, but it happens in the usual way, not via this new mechanism. </para></listitem> +<listitem><para> + The role of the last parameter of each of the <literal>ci</literal> is <emphasis>not</emphasis> <literal>N</literal>. (See <xref linkend="roles"/>.)</para></listitem> </itemizedlist> Then, for each <literal>ci</literal>, the derived instance declaration is: @@ -3809,7 +3865,7 @@ globally configurable settings in a program. For example, assumeRH :: a -> a -- Deterministic version of the Miller test - -- correctness depends on the generalized Riemann hypothesis + -- correctness depends on the generalized Riemann hypothesis isPrime :: RiemannHypothesis => Integer -> Bool isPrime n = assumeRH (...) </programlisting> @@ -4186,7 +4242,7 @@ including both declarations (A) and (B), say); an error is only reported if a particular constraint matches more than one. </para></listitem> </itemizedlist> -See also <xref linkend="instance-overlap"/> for flags that loosen the +See also <xref linkend="instance-overlap"/> for flags that loosen the instance resolution rules. </para> @@ -4416,7 +4472,7 @@ with <option>-fcontext-stack=</option><emphasis>N</emphasis>. <title>Overlapping instances</title> <para> -In general, as discussed in <xref linkend="instance-resolution"/>, +In general, as discussed in <xref linkend="instance-resolution"/>, <emphasis>GHC requires that it be unambiguous which instance declaration should be used to resolve a type-class constraint</emphasis>. This behaviour @@ -4431,7 +4487,7 @@ an <literal>OPTIONS_GHC</literal> pragma if desired (<xref linkend="source-file- <para> The <option>-XOverlappingInstances</option> flag instructs GHC to loosen the instance resolution described in <xref linkend="instance-resolution"/>, by -allowing more than one instance to match, <emphasis>provided there is a most specific one</emphasis>. +allowing more than one instance to match, <emphasis>provided there is a most specific one</emphasis>. For example, consider <programlisting> instance context1 => C Int a where ... -- (A) @@ -4444,9 +4500,9 @@ The constraint <literal>C Int [Int]</literal> matches instances (A), most-specific match, the program is rejected. </para> <para> -An instance declaration is <emphasis>more specific</emphasis> than another iff +An instance declaration is <emphasis>more specific</emphasis> than another iff the head of former is a substitution instance of the latter. For example -(D) is "more specific" than (C) because you can get from (C) to (D) by +(D) is "more specific" than (C) because you can get from (C) to (D) by substituting <literal>a:=Int</literal>. </para> <para> @@ -4609,7 +4665,7 @@ instance C a => C (T a) where xs :: [b] xs = [x,x,x] </programlisting> -Provided that you also specify <option>-XScopedTypeVariables</option> +Provided that you also specify <option>-XScopedTypeVariables</option> (<xref linkend="scoped-type-variables"/>), the <literal>forall b</literal> scopes over the definition of <literal>foo</literal>, and in particular over the type signature for <literal>xs</literal>. @@ -4703,7 +4759,7 @@ constructing lists. In Haskell, the list notation can be be used in the following seven ways: <programlisting> -[] -- Empty list +[] -- Empty list [x] -- x : [] [x,y,z] -- x : y : z : [] [x .. ] -- enumFrom x @@ -4738,7 +4794,7 @@ listing gives a few examples:</para> ['a' .. 'z'] :: Text </programlisting> <para> -List patterns are also overloaded. When the <option>OverloadedLists</option> +List patterns are also overloaded. When the <option>OverloadedLists</option> extension is turned on, these definitions are desugared as follows <programlisting> f [] = ... -- f (toList -> []) = ... @@ -4752,7 +4808,7 @@ g [x,y,z] = ... -- g (toList -> [x,y,z]) = ... <para>In the above desugarings, the functions <literal>toList</literal>, <literal>fromList</literal> and <literal>fromListN</literal> are all -methods of +methods of the <literal>IsList</literal> class, which is itself exported from the <literal>GHC.Exts</literal> module. The type class is defined as follows:</para> @@ -4769,18 +4825,18 @@ class IsList l where </programlisting> <para>The <literal>FromList</literal> class and its methods are intended to be -used in conjunction with the <option>OverloadedLists</option> extension. +used in conjunction with the <option>OverloadedLists</option> extension. <itemizedlist> <listitem> <para> The type function <literal>Item</literal> returns the type of items of the structure <literal>l</literal>. </para></listitem> -<listitem><para> -The function <literal>fromList</literal> +<listitem><para> +The function <literal>fromList</literal> constructs the structure <literal>l</literal> from the given list of -<literal>Item l</literal>. +<literal>Item l</literal>. </para></listitem> -<listitem><para> +<listitem><para> The function <literal>fromListN</literal> takes the input list's length as a hint. Its behaviour should be equivalent to <literal>fromList</literal>. The hint can be used for more efficient @@ -4789,8 +4845,8 @@ construction of the structure <literal>l</literal> compared to list's length the behaviour of <literal>fromListN</literal> is not specified. </para></listitem> -<listitem><para> -The function <literal>toList</literal> should be +<listitem><para> +The function <literal>toList</literal> should be the inverse of <literal>fromList</literal>. </para></listitem> </itemizedlist> @@ -4812,12 +4868,12 @@ instance (Ord a) => FromList (Set a) where instance (Ord k) => FromList (Map k v) where type Item (Map k v) = (k,v) - fromList = Map.fromList + fromList = Map.fromList toList = Map.toList instance FromList (IntMap v) where type Item (IntMap v) = (Int,v) - fromList = IntMap.fromList + fromList = IntMap.fromList toList = IntMap.toList instance FromList Text where @@ -4841,7 +4897,7 @@ instance FromList (Vector a) where GHC uses the <literal>fromList</literal> (etc) methods from module <literal>GHC.Exts</literal>. You do not need to import <literal>GHC.Exts</literal> for this to happen. </para> -<para> However if you use <option>-XRebindableSyntax</option>, then +<para> However if you use <option>-XRebindableSyntax</option>, then GHC instead uses whatever is in scope with the names of <literal>toList</literal>, <literal>fromList</literal> and <literal>fromListN</literal>. That is, these functions are rebindable; @@ -4883,7 +4939,7 @@ representation).</para> <title>Type families</title> <para> - <firstterm>Indexed type families</firstterm> are a new GHC extension to + <firstterm>Indexed type families</firstterm> form an extension to facilitate type-level programming. Type families are a generalisation of <firstterm>associated data types</firstterm> @@ -4926,11 +4982,11 @@ representation).</para> indices. </para> <para> - Indexed type families come in two flavours: <firstterm>data - families</firstterm> and <firstterm>type synonym - families</firstterm>. They are the indexed family variants of algebraic - data types and type synonyms, respectively. The instances of data families - can be data types and newtypes. + Indexed type families come in three flavours: <firstterm>data + families</firstterm>, <firstterm>open type synonym families</firstterm>, and + <firstterm>closed type synonym families</firstterm>. They are the indexed + family variants of algebraic data types and type synonyms, respectively. The + instances of data families can be data types and newtypes. </para> <para> Type families are enabled by the flag <option>-XTypeFamilies</option>. @@ -5038,7 +5094,7 @@ data instance G [a] b where </para> <para> - Even if type families are defined as toplevel declarations, functions + Even if data families are defined as toplevel declarations, functions that perform different computations for different family instances may still need to be defined as methods of type classes. In particular, the following is not possible: @@ -5084,22 +5140,24 @@ instance Foo Char where <title>Synonym families</title> <para> - Type families appear in two flavours: (1) they can be defined on the - toplevel or (2) they can appear inside type classes (in which case they - are known as associated type synonyms). The former is the more general - variant, as it lacks the requirement for the type-indexes to coincide with - the class parameters. However, the latter can lead to more clearly - structured code and compiler warnings if some type instances were - - possibly accidentally - omitted. In the following, we always discuss the - general toplevel form first and then cover the additional constraints - placed on associated types. + Type families appear in three flavours: (1) they can be defined as open + families on the toplevel, (2) they can be defined as closed families on + the toplevel, or (3) they can appear inside type classes (in which case + they are known as associated type synonyms). Toplevel families are more + general, as they lack the requirement for the type-indexes to coincide + with the class parameters. However, associated type synonyms can lead to + more clearly structured code and compiler warnings if some type instances + were - possibly accidentally - omitted. In the following, we always + discuss the general toplevel forms first and then cover the additional + constraints placed on associated types. Note that closed associated type + synonyms do not exist. </para> <sect3 id="type-family-declarations"> <title>Type family declarations</title> <para> - Indexed type families are introduced by a signature, such as + Open indexed type families are introduced by a signature, such as <programlisting> type family Elem c :: * </programlisting> @@ -5135,12 +5193,7 @@ F Bool -- WRONG: unsaturated application <sect3 id="type-instance-declarations"> <title>Type instance declarations</title> <para> - There are two forms of type family instance declaration: unbranched and - branched. Branched instances list any number of alternatives, to be - checked in order from top to bottom, similarly to normal function - declarations. Unbranched instances supply only one left-hand side. - - Unbranched instance declarations of type families are very similar to + Instance declarations of type families are very similar to standard type synonym declarations. The only two differences are that the keyword <literal>type</literal> is followed by <literal>instance</literal> and that some or all of the type arguments @@ -5156,45 +5209,55 @@ type instance Elem [e] = e </para> <para> - Branched instance declarations, on the other hand, allow many different - left-hand-side type patterns. These patterns are tried in order, from - top to bottom, when simplifying a type family application. A branched instance - declaration is introduced by <literal>type instance where</literal>. For example: + Type family instance declarations are only legitimate when an + appropriate family declaration is in scope - just like class instances + require the class declaration to be visible. Moreover, each instance + declaration has to conform to the kind determined by its family + declaration, and the number of type parameters in an instance + declaration must match the number of type parameters in the family + declaration. Finally, the right-hand side of a type instance must be a + monotype (i.e., it may not include foralls) and after the expansion of + all saturated vanilla type synonyms, no synonyms, except family synonyms + may remain. + </para> + </sect3> + + <sect3 id="closed-type-families"> + <title>Closed type families</title> + <para> + A type family can also be declared with a <literal>where</literal> clause, + defining the full set of equations for that family. For example: <programlisting> -type instance where +type family F a where F Int = Double F Bool = Char F a = String </programlisting> - In this example, we declare an instance for <literal>F</literal> such - that <literal>F Int</literal> simplifies to <literal>Double</literal>, - <literal>F Bool</literal> simplifies to <literal>Char</literal>, and for - any other type <literal>a</literal> that is known not to be - <literal>Int</literal> or <literal>Bool</literal>, <literal>F - a</literal> simplifies to <literal>String</literal>. Note that GHC must - be sure that <literal>a</literal> cannot unify with - <literal>Int</literal> or <literal>Bool</literal> in that last case; if - a programmer specifies just <literal>F a</literal> in their code, GHC will - not be able to simplify the type. After all, <literal>a</literal> might later - be instantiated with <literal>Int</literal>. + A closed type family's equations are tried in order, from top to bottom, + when simplifying a type family application. In this example, we declare + an instance for <literal>F</literal> such that <literal>F Int</literal> + simplifies to <literal>Double</literal>, <literal>F Bool</literal> + simplifies to <literal>Char</literal>, and for any other type + <literal>a</literal> that is known not to be <literal>Int</literal> or + <literal>Bool</literal>, <literal>F a</literal> simplifies to + <literal>String</literal>. Note that GHC must be sure that + <literal>a</literal> cannot unify with <literal>Int</literal> or + <literal>Bool</literal> in that last case; if a programmer specifies + just <literal>F a</literal> in their code, GHC will not be able to + simplify the type. After all, <literal>a</literal> might later be + instantiated with <literal>Int</literal>. </para> <para> - Branched instances and unbranched instances may be mixed freely for the same - type family. + A closed type family's equations have the same restrictions as the + equations for an open type family instances. </para> + </sect3> + <sect3 id="type-family-examples"> + <title>Type family examples</title> <para> - Type family instance declarations are only legitimate when an - appropriate family declaration is in scope - just like class instances - require the class declaration to be visible. Moreover, each instance - declaration has to conform to the kind determined by its family - declaration, and the number of type parameters in an instance - declaration must match the number of type parameters in the family - declaration. Finally, the right-hand side of a type instance must be a - monotype (i.e., it may not include foralls) and after the expansion of - all saturated vanilla type synonyms, no synonyms, except family synonyms - may remain. Here are some examples of admissible and illegal type +Here are some examples of admissible and illegal type instances: <programlisting> type family F a :: * @@ -5203,13 +5266,11 @@ type instance F String = Char -- OK! type instance F (F a) = a -- WRONG: type parameter mentions a type family type instance F (forall a. (a, b)) = b -- WRONG: a forall type appears in a type parameter type instance F Float = forall a.a -- WRONG: right-hand side may not be a forall type -type instance where -- OK! - F (Maybe Int) = Int - F (Maybe Bool) = Bool - F (Maybe a) = String -type instance where -- WRONG: conflicts with earlier instances (see below) - F Int = Float - F a = [a] +type family H a where -- OK! + H Int = Int + H Bool = Bool + H a = String +type instance H Char = Char -- WRONG: cannot have instances of closed family type family G a b :: * -> * type instance G Int = (,) -- WRONG: must be two type parameters @@ -5218,35 +5279,83 @@ type instance G Int Char Float = Double -- WRONG: must be two type parameters </para> </sect3> <sect3 id="type-family-overlap"> - <title>Overlap of type synonym instances</title> + <title>Compatibility and apartness of type family equations</title> <para> - The unbranched instance declarations of a type family used in a single - program may only overlap if the right-hand sides of the overlapping - instances coincide for the overlapping types. More formally, two - instance declarations overlap if there is a substitution that makes - the left-hand sides of the instances syntactically the same. Whenever - that is the case, if the instances are unbranched, the right-hand - sides of the instances must also be syntactically equal under the same - substitution. This condition is independent of whether the type family - is associated or not, and it is not only a matter of consistency, but - one of type safety. Branched instances are not permitted to overlap - with any other instances, branched or unbranched. + There must be some restrictions on the equations of type families, lest + we define an ambiguous rewrite system. So, equations of open type families + are restricted to be <firstterm>compatible</firstterm>. Two type patterns + are compatible if +<orderedlist> +<listitem><para>all corresponding types in the patterns are <firstterm>apart</firstterm>, or</para></listitem> +<listitem><para>the two patterns unify producing a substitution, and the right-hand sides are equal under that substitution.</para></listitem> +</orderedlist> + Two types are considered <firstterm>apart</firstterm> if, for all possible + substitutions, the types cannot reduce to a common reduct. </para> + <para> - Here are two example to illustrate the condition under which overlap - is permitted. + The first clause of "compatible" is the more straightforward one. It says + that the patterns of two distinct type family instances cannot overlap. + For example, the following is disallowed: +<programlisting> +type instance F Int = Bool +type instance F Int = Char +</programlisting> + The second clause is a little more interesting. It says that two + overlapping type family instances are allowed if the right-hand + sides coincide in the region of overlap. Some examples help here: <programlisting> type instance F (a, Int) = [a] type instance F (Int, b) = [b] -- overlap permitted type instance G (a, Int) = [a] type instance G (Char, a) = [a] -- ILLEGAL overlap, as [Char] /= [Int] - -type instance H Int = Int -type instance where -- ILLEGAL overlap, as branched instances may not overlap - H a = a </programlisting> - </para> + Note that this compatibility condition is independent of whether the type family + is associated or not, and it is not only a matter of consistency, but + one of type safety. </para> + + <para> + The definition for "compatible" uses a notion of "apart", whose definition + in turn relies on type family reduction. This condition of "apartness", as + stated, is impossible to check, so we use this conservative approximation: + two types are considered to be apart when the two types cannot be unified, + even by a potentially infinite unifier. Allowing the unifier to be infinite + disallows the following pair of instances: +<programlisting> +type instance H x x = Int +type instance H [x] x = Bool +</programlisting> + The type patterns in this pair equal if <literal>x</literal> is replaced + by an infinite nesting of lists. Rejecting instances such as these is + necessary for type soundness. + </para> + + <para> + Compatibility also affects closed type families. When simplifying an + application of a closed type family, GHC will select an equation only + when it is sure that no incompatible previous equation will ever apply. + Here are some examples: +<programlisting> +type family F a where + F Int = Bool + F a = Char + +type family G a where + G Int = Int + G a = a +</programlisting> + In the definition for <literal>F</literal>, the two equations are + incompatible -- their patterns are not apart, and yet their + right-hand sides do not coincide. Thus, before GHC selects the + second equation, it must be sure that the first can never apply. So, + the type <literal>F a</literal> does not simplify; only a type such + as <literal>F Double</literal> will simplify to + <literal>Char</literal>. In <literal>G</literal>, on the other hand, + the two equations are compatible. Thus, GHC can ignore the first + equation when looking at the second. So, <literal>G a</literal> will + simplify to <literal>a</literal>.</para> + <para> However see <xref linkend="ghci-decls"/> for the overlap rules in GHCi.</para> </sect3> @@ -5377,10 +5486,6 @@ instance GMapKey Flob where the free indexed parameter is of a kind with a finite number of alternatives (unlike <literal>*</literal>). </para> - - <para> - Branched associated type instances are not currently supported. - </para> </sect3> <sect3 id="assoc-decl-defs"> @@ -5633,7 +5738,7 @@ instance Show v => Show (GMap () v) where ... <title>Kind polymorphism</title> <para> This section describes <emphasis>kind polymorphism</emphasis>, and extension -enabled by <option>-XPolyKinds</option>. +enabled by <option>-XPolyKinds</option>. It is described in more detail in the paper <ulink url="http://dreixel.net/research/pdf/ghp.pdf">Giving Haskell a Promotion</ulink>, which appeared at TLDI 2012. @@ -5679,27 +5784,53 @@ Note that the datatype <literal>Proxy</literal> has kind <para> Generally speaking, with <option>-XPolyKinds</option>, GHC will infer a polymorphic -kind for un-decorated whenever possible. For example: +kind for un-decorated declarations, whenever possible. For example: <programlisting> data T m a = MkT (m a) -- GHC infers kind T :: forall k. (k -> *) -> k -> * </programlisting> -Just as in the world of terms, you can restrict polymorphism using a signature +Just as in the world of terms, you can restrict polymorphism using a +kind signature (sometimes called a kind annotation) (<option>-XPolyKinds</option> implies <option>-XKindSignatures</option>): <programlisting> data T m (a :: *) = MkT (m a) -- GHC now infers kind T :: (* -> *) -> * -> * </programlisting> -There is no "forall" for kind variables. Instead, you can simply mention a kind -variable in a kind signature, thus: +There is no "forall" for kind variables. Instead, when binding a type variable, +you can simply mention a kind +variable in a kind annotation for that type-variable binding, thus: <programlisting> data T (m :: k -> *) a = MkT (m a) -- GHC now infers kind T :: forall k. (k -> *) -> k -> * </programlisting> +The kind "forall" is placed +just outside the outermost type-variable binding whose kind annotation mentions +the kind variable. For example +<programlisting> +f1 :: (forall a m. m a -> Int) -> Int + -- f1 :: forall (k:BOX). + -- (forall (a:k) (m:k->*). m a -> Int) + -- -> Int + +f2 :: (forall (a::k) m. m a -> Int) -> Int + -- f2 :: (forall (k:BOX) (a:k) (m:k->*). m a -> Int) + -- -> Int +</programlisting> +Here in <literal>f1</literal> there is no kind annotation mentioning the polymorphic +kind variable, so <literal>k</literal> is generalised at the top +level of the signature for <literal>f1</literal>, +making the signature for <literal>f1</literal> is as polymorphic as possible. +But in the case of of <literal>f2</literal> we give a kind annotation in the <literal>forall (a:k)</literal> +binding, and GHC therefore puts the kind <literal>forall</literal> right there too. +</para> +<para> +(Note: These rules are a bit indirect and clumsy. Perhaps GHC should allow explicit kind quantification. +But the implicit quantification (e.g. in the declaration for data type T above) is certainly +very convenient, and it is not clear what the syntax for explicit quantification should be.) </para> </sect2> -<sect2> <title>Polymorphic kind recursion and complete kind signatures</title> +<sect2 id="complete-kind-signatures"> <title>Polymorphic kind recursion and complete kind signatures</title> <para> Just as in type inference, kind inference for recursive types can only use <emphasis>monomorphic</emphasis> recursion. @@ -5709,7 +5840,7 @@ data T m a = MkT (m a) (T Maybe (m a)) -- GHC infers kind T :: (* -> *) -> * -> * </programlisting> The recursive use of <literal>T</literal> forced the second argument to have kind <literal>*</literal>. -However, just as in type inference, you can achieve polymorphic recursion by giving a +However, just as in type inference, you can achieve polymorphic recursion by giving a <emphasis>complete kind signature</emphasis> for <literal>T</literal>. The way to give a complete kind signature for a data type is to use a GADT-style declaration with an explicit kind signature thus: @@ -5744,14 +5875,21 @@ you must use GADT syntax. </para></listitem> <listitem><para> -A type or data family declaration <emphasis>always</emphasis> have a +An open type or data family declaration <emphasis>always</emphasis> has a complete user-specified kind signature; no "<literal>::</literal>" is required: <programlisting> data family D1 a -- D1 :: * -> * data family D2 (a :: k) -- D2 :: forall k. k -> * data family D3 (a :: k) :: * -- D3 :: forall k. k -> * type family S1 a :: k -> * -- S1 :: forall k. * -> k -> * + +class C a where -- C :: k -> Constraint + type AT a b -- AT :: k -> * -> * </programlisting> +In the last example, the variable <literal>a</literal> has an implicit kind +variable annotation from the class declaration. It keeps its polymorphic kind +in the associated type declaration. The variable <literal>b</literal>, however, +gets defaulted to <literal>*</literal>. </para></listitem> </itemizedlist> In a complete user-specified kind signature, any un-decorated type variable to the @@ -5760,6 +5898,39 @@ If you want kind polymorphism, specify a kind variable. </para> </sect2> + +<sect2><title>Kind inference in closed type families</title> + +<para>Although all open type families are considered to have a complete +user-specified kind signature, we can relax this condition for closed type +families, where we have equations on which to perform kind inference. GHC will +infer a kind for any type variable in a closed type family when that kind is +never used in pattern-matching. If you want a kind variable to be used in +pattern-matching, you must declare it explicitly. +</para> + +<para> +Here are some examples (assuming <literal>-XDataKinds</literal> is enabled): +<programlisting> +type family Not a where -- Not :: Bool -> Bool + Not False = True + Not True = False + +type family F a where -- ERROR: requires pattern-matching on a kind variable + F Int = Bool + F Maybe = Char + +type family G (a :: k) where -- G :: k -> * + G Int = Bool + G Maybe = Char + +type family SafeHead where -- SafeHead :: [k] -> Maybe k + SafeHead '[] = Nothing -- note that k is not required for pattern-matching + SafeHead (h ': t) = Just h +</programlisting> +</para> + +</sect2> </sect1> <sect1 id="promotion"> @@ -5825,7 +5996,7 @@ data Nat = Ze | Su Nat data List a = Nil | Cons a (List a) data Pair a b = Pair a b - + data Sum a b = L a | R b </programlisting> give rise to the following kinds and type constructors: @@ -5890,7 +6061,7 @@ type T1 = P -- 1 type T2 = 'P -- promoted 2 </programlisting> Note that promoted datatypes give rise to named kinds. Since these can never be -ambiguous, we do not allow quotes in kind names. +ambiguous, we do not allow quotes in kind names. </para> <para>Just as in the case of Template Haskell (<xref linkend="th-syntax"/>), there is no way to quote a data constructor or type constructor whose second character @@ -5968,7 +6139,7 @@ data Ex :: * where MkEx :: forall a. a -> Ex </programlisting> Both the type <literal>Ex</literal> and the data constructor <literal>MkEx</literal> -get promoted, with the polymorphic kind <literal>'MkEx :: forall k. k -> Ex</literal>. +get promoted, with the polymorphic kind <literal>'MkEx :: forall k. k -> Ex</literal>. Somewhat surprisingly, you can write a type family to extract the member of a type-level existential: <programlisting> @@ -5977,7 +6148,7 @@ type instance UnEx (MkEx x) = x </programlisting> At first blush, <literal>UnEx</literal> seems poorly-kinded. The return kind <literal>k</literal> is not mentioned in the arguments, and thus it would seem -that an instance would have to return a member of <literal>k</literal> +that an instance would have to return a member of <literal>k</literal> <emphasis>for any</emphasis> <literal>k</literal>. However, this is not the case. The type family <literal>UnEx</literal> is a kind-indexed type family. The return kind <literal>k</literal> is an implicit parameter to <literal>UnEx</literal>. @@ -6623,7 +6794,7 @@ field type signatures.</para> </listitem> <listitem> <para> As the type of an implicit parameter </para> </listitem> <listitem> <para> In a pattern type signature (see <xref linkend="scoped-type-variables"/>) </para> </listitem> </itemizedlist> -The <option>-XRankNTypes</option> option is also required for any +The <option>-XRankNTypes</option> option is also required for any type with a <literal>forall</literal> or context to the right of an arrow (e.g. <literal>f :: Int -> forall a. a->a</literal>, or <literal>g :: Int -> Ord a => a -> a</literal>). Such types are technically rank 1, but @@ -6633,7 +6804,7 @@ are clearly not Haskell-98, and an extra flag did not seem worth the bother. <para> The obselete language options <option>-XPolymorphicComponents</option> and <option>-XRank2Types</option> are synonyms for <option>-XRankNTypes</option>. They used to specify finer distinctions that -GHC no longer makes. (They should really elicit a deprecation warning, but they don't, purely +GHC no longer makes. (They should really elicit a deprecation warning, but they don't, purely to avoid the need to library authors to change their old flags specifciations.) </para> @@ -7181,8 +7352,24 @@ scope over the methods defined in the <literal>where</literal> part. For exampl </sect2> +<sect2> +<title>Bindings and generalisation</title> -<sect2 id="typing-binds"> +<sect3 id="monomorphism"> +<title>Switching off the dreaded Monomorphism Restriction</title> + <indexterm><primary><option>-XNoMonomorphismRestriction</option></primary></indexterm> + +<para>Haskell's monomorphism restriction (see +<ulink url="http://www.haskell.org/onlinereport/decls.html#sect4.5.5">Section +4.5.5</ulink> +of the Haskell Report) +can be completely switched off by +<option>-XNoMonomorphismRestriction</option>. +</para> +</sect3> + + +<sect3 id="typing-binds"> <title>Generalised typing of mutually recursive bindings</title> <para> @@ -7243,28 +7430,14 @@ pattern binding must have the same context. For example, this is fine: g y = (y <= y) || f True </programlisting> </para> -</sect2> - -<sect2 id="monomorphism"> -<title>Switching off the dreaded Monomorphism Restriction</title> - <indexterm><primary><option>-XNoMonomorphismRestriction</option></primary></indexterm> - -<para>Haskell's monomorphism restriction (see -<ulink url="http://www.haskell.org/onlinereport/decls.html#sect4.5.5">Section -4.5.5</ulink> -of the Haskell Report) -can be completely switched off by -<option>-XNoMonomorphismRestriction</option>. -</para> -</sect2> - +</sect3> -<sect2 id="mono-local-binds"> +<sect3 id="mono-local-binds"> <title>Let-generalisation</title> <para> An ML-style language usually generalises the type of any let-bound or where-bound variable, so that it is as polymorphic as possible. -With the flag <option>-XMonoLocalBinds</option> GHC implements a slightly more conservative policy: +With the flag <option>-XMonoLocalBinds</option> GHC implements a slightly more conservative policy: <emphasis>it generalises only "closed" bindings</emphasis>. A binding is considered "closed" if either <itemizedlist> @@ -7284,15 +7457,17 @@ But <literal>k</literal> is not closed because it mentions <literal>x</literal> Another way to think of it is this: all closed bindings <literal>could</literal> be defined at top level. (In the example, we could move <literal>h</literal> to top level.) </para><para> -All of this applies only to bindings that lack an explicit type signature, so that GHC has to +All of this applies only to bindings that lack an explicit type signature, so that GHC has to infer its type. If you supply a type signature, then that fixes type of the binding, end of story. </para><para> -The rationale for this more conservative strategy is given in -<ulink url="http://research.microsoft.com/~simonpj/papers/constraints/index.htm">the papers</ulink> "Let should not be generalised" and "Modular type inference with local assumptions". +The rationale for this more conservative strategy is given in +<ulink url="http://research.microsoft.com/~simonpj/papers/constraints/index.htm">the papers</ulink> "Let should not be generalised" and "Modular type inference with local assumptions", and +a related <ulink url="http://hackage.haskell.org/trac/ghc/blog/LetGeneralisationInGhc7">blog post</ulink>. </para><para> The flag <option>-XMonoLocalBinds</option> is implied by <option>-XTypeFamilies</option> and <option>-XGADTs</option>. You can switch it off again with <option>-XNoMonoLocalBinds</option> but type inference becomes less predicatable if you do so. (Read the papers!) </para> +</sect3> </sect2> <sect2 id="type-holes"> @@ -7312,7 +7487,7 @@ the term you're about to write. </para> <para> -This extension allows special placeholders, written with a leading underscore (e.g. "<literal>_</literal>", +This extension allows special placeholders, written with a leading underscore (e.g. "<literal>_</literal>", "<literal>_foo</literal>", "<literal>_bar</literal>"), to be used as an expression. During compilation these holes will generate an error message describing what type is expected there, information about the origin of any free type variables, and a list of local bindings @@ -7470,7 +7645,7 @@ Prelude> fst (True, 1 == 'a') In the expression: 1 == 'a' In the first argument of `fst', namely `(True, 1 == 'a')' </programlisting> -Otherwise, in the common case of a simple type error such as +Otherwise, in the common case of a simple type error such as typing <literal>reverse True</literal> at the prompt, you would get a warning and then an immediately-following type error when the expression is evaluated. </para> @@ -7590,7 +7765,7 @@ Wiki page</ulink>. <itemizedlist> <listitem><para> <literal>'f</literal> has type <literal>Name</literal>, and names the function <literal>f</literal>. Similarly <literal>'C</literal> has type <literal>Name</literal> and names the data constructor <literal>C</literal>. - In general <literal>'</literal><replaceable>thing</replaceable> + In general <literal>'</literal><replaceable>thing</replaceable> interprets <replaceable>thing</replaceable> in an expression context.</para> <para>A name whose second character is a single quote (sadly) cannot be quoted in this way, @@ -10534,7 +10709,228 @@ Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh. </sect1> +<sect1 id="roles"> +<title>Roles +<indexterm><primary>roles</primary></indexterm> +</title> + +<para> +Using <option>-XGeneralizedNewtypeDeriving</option> (<xref +linkend="generalized-newtype-deriving" />), a programmer can take existing +instances of classes and "lift" these into instances of that class for a +newtype. However, this is not always safe. For example, consider the following: +</para> + +<programlisting> + newtype Age = MkAge { unAge :: Int } + + type family Inspect x + type instance Inspect Age = Int + type instance Inspect Int = Bool + class BadIdea a where + bad :: a -> Inspect a + + instance BadIdea Int where + bad = (> 0) + + deriving instance BadIdea Age -- not allowed! +</programlisting> + +<para> +If the derived instance were allowed, what would the type of its method +<literal>bad</literal> be? It would seem to be <literal>Age -> Inspect +Age</literal>, which is equivalent to <literal>Age -> Int</literal>, according +to the type family <literal>Inspect</literal>. Yet, if we simply adapt the +implementation from the instance for <literal>Int</literal>, the implementation +for <literal>bad</literal> produces a <literal>Bool</literal>, and we have trouble. +</para> + +<para> +The way to identify such situations is to have <emphasis>roles</emphasis> assigned +to type variables of datatypes, classes, and type synonyms.</para> + +<para> +Roles as implemented in GHC are a from a simplified version of the work +described in <ulink +url="http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf">Generative +type abstraction and type-level computation</ulink>, published at POPL 2011.</para> + +<sect2> +<title>Nominal, Representational, and Phantom</title> + +<para>The goal of the roles system is to track when two types have the same +underlying representation. In the example above, <literal>Age</literal> and +<literal>Int</literal> have the same representation. But, the corresponding +instances of <literal>BadIdea</literal> would <emphasis>not</emphasis> have +the same representation, because the types of the implementations of +<literal>bad</literal> would be different.</para> + +<para>Suppose we have two uses of a type constructor, each applied to the same +parameters except for one difference. (For example, <literal>T Age Bool +c</literal> and <literal>T Int Bool c</literal> for some type +<literal>T</literal>.) The role of a type parameter says what we need to +know about the two differing type arguments in order to know that the two +outer types have the same representation (in the example, what must be true +about <literal>Age</literal> and <literal>Int</literal> in order to show that +<literal>T Age Bool c</literal> has the same representation as <literal> +T Int Bool c</literal>).</para> + +<para>GHC supports three different roles for type parameters: nominal, +representational, and phantom. If a type parameter has a nominal (N) role, +then the two types that differ must not actually differ at all: they must be +identical (after type family reduction). If a type parameter has a +representational (R) role, then the two types must have the same +representation. (If <literal>T</literal>'s first parameter's role is R, then +<literal>T Age Bool c</literal> and <literal>T Int Bool c</literal> would have +the same representation, because <literal>Age</literal> and <literal>Int</literal> +have the same representation.) If a type parameter has a phantom (P) role, +then we need no further information.</para> + +<para>Here are some examples:</para> + +<programlisting> + data Simple a = MkSimple a -- a has role R + + type family F + type instance F Int = Bool + type instance F Age = Char + + data Complex a = MkComplex (F a) -- a has role N + + data Phant a = MkPhant Bool -- a has role P +</programlisting> + +<para>The type <literal>Simple</literal> has its parameter at role R, which is +generally the most common case. <literal>Simple Age</literal> would have the same +representation as <literal>Simple Int</literal>. The type <literal>Complex</literal>, +on the other hand, has its parameter at role N, because <literal>Simple Age</literal> +and <literal>Simple Int</literal> are <emphasis>not</emphasis> the same. Lastly, +<literal>Phant Age</literal> and <literal>Phant Bool</literal> have the same +representation, even though <literal>Age</literal> and <literal>Bool</literal> +are unrelated.</para> + +</sect2> + +<sect2> +<title>Role inference</title> + +<para> +What role should a given type parameter should have? GHC performs role +inference to determine the correct role for every parameter. It starts with a +few base facts: <literal>(->)</literal> has two R parameters; +<literal>(~)</literal> has two N parameters; all type families' parameters are +N; and all GADT-like parameters are N. Then, these facts are propagated to all +places where these types are used. By defaulting parameters to role P, any +parameters unused in the right-hand side (or used only in other types in P +positions) will be P. Whenever a parameter is used in an R position (that is, +used as a type argument to a constructor whose corresponding variable is at +role R), we raise its role from P to R. Similarly, when a parameter is used in +an N position, its role is upgraded to N. We never downgrade a role from N to +P or R, or from R to P. In this way, we infer the most-general role for each +parameter. +</para> + +<para>There is one particularly tricky case that should be explained:</para> + +<programlisting> + data Tricky a b = MkTricky (a b) +</programlisting> + +<para>What should <literal>Tricky</literal>'s roles be? At first blush, it would +seem that both <literal>a</literal> and <literal>b</literal> should be at role R, +since both are used in the right-hand side and neither is involved in a type family. +However, this would be wrong, as the following example shows:</para> + +<programlisting> + data Nom a = MkNom (F a) -- type family F from example above +</programlisting> + +<para>Is <literal>Tricky Nom Age</literal> representationally equal to +<literal>Tricky Nom Int</literal>? No! The former stores a <literal>Char</literal> +and the latter stores a <literal>Bool</literal>. The solution to this is +to require all parameters to type variables to have role N. Thus, GHC would +infer role R for <literal>a</literal> but role N for <literal>b</literal>.</para> + +</sect2> + +<sect2> +<title>Role annotations +<indexterm><primary>-XRoleAnnotations</primary></indexterm> +</title> + +<para> +Sometimes the programmer wants to constrain the inference process. For +example, the base library contains the following definition: +</para> + +<programlisting> + data Ptr a = Ptr Addr# +</programlisting> + +<para> +The idea is that <literal>a</literal> should really be an R parameter, but +role inference assigns it to P. This makes some level of sense: a pointer to +an <literal>Int</literal> really is representationally the same as a pointer +to a <literal>Bool</literal>. But, that's not at all how we want to use +<literal>Ptr</literal>s! So, we want to be able to say</para> + +<programlisting> + data Ptr a@R = Ptr Addr# +</programlisting> + +<para> +The <literal>@R</literal> (enabled with <option>-XRoleAnnotations</option>) annotation forces the +parameter a to be at role R, not role P. GHC then checks +the user-supplied roles to make sure they don't break any promises. It would +be bad, for example, if the user could make <literal>BadIdea</literal>'s role be R. +</para> + +<para>As another example, we can consider a type <literal>Set a</literal> that +represents a set of data, ordered according to <literal>a</literal>'s +<literal>Ord</literal> instance. While it would generally be type-safe to +consider <literal>a</literal> to be at role R, it is possible that a +<literal>newtype</literal> and its base type have +<emphasis>different</emphasis> orderings encoded in their respective +<literal>Ord</literal> instances. This would lead to misbehavior at runtime. +So, the author of the <literal>Set</literal> datatype would like its parameter +to be at role N. This would be done with a declaration</para> + +<programlisting> + data Set a@N = ... +</programlisting> + +<para>The other place where role annotations may be necessary are in +<literal>hs-boot</literal> files (<xref linkend="mutual-recursion"/>), where +the right-hand sides of definitions can be omitted. As usual, the +types/classes declared in an <literal>hs-boot</literal> file must match up +with the definitions in the <literal>hs</literal> file, including down to the +roles. The default role is R in <literal>hs-boot</literal> files, +corresponding to the common use case.</para> + +<para> +Role annotations are allowed on type variables in data, newtype, class, +and type declarations. They are not allowed on type/data family +declarations or in explicit foralls in function type signatures. +The syntax for a role annotation is an <literal>@</literal> sign followed +by one of <literal>N</literal>, <literal>R</literal>, or <literal>P</literal>, +directly following a type variable. If the type variable has an explicit +kind annotation, the role annotation goes after the kind annotation, outside +the parentheses. Here are some examples:</para> + +<programlisting> + data T1 a b@P = MkT1 a -- b is not used; annotation is fine but unnecessary + data T2 a b@P = MkT2 b -- ERROR: b is used and cannot be P + data T3 a b@N = MkT3 a -- OK: N is higher than necessary, but safe + data T4 (a :: * -> *)@N = MkT4 (a Int) -- OK, but N is higher than necessary + class C a@R b where ... -- OK + type X a@N = ... -- OK + type family F a@R -- ERROR: annotations not allowed on family declarations +</programlisting> + +</sect2> + +</sect1> <!-- Emacs stuff: ;;; Local Variables: *** diff --git a/docs/users_guide/intro.xml b/docs/users_guide/intro.xml index b21b793f73..a7cd33ac5c 100644 --- a/docs/users_guide/intro.xml +++ b/docs/users_guide/intro.xml @@ -302,7 +302,7 @@ <para>The version number of your copy of GHC can be found by invoking <literal>ghc</literal> with the - <literal>––version</literal> flag (see <xref + <literal>--version</literal> flag (see <xref linkend="options-help"/>).</para> </sect1> diff --git a/docs/users_guide/packages.xml b/docs/users_guide/packages.xml index c6a1d089a2..3f2dd97aa5 100644 --- a/docs/users_guide/packages.xml +++ b/docs/users_guide/packages.xml @@ -13,7 +13,7 @@ Packages url="http://hackage.haskell.org/packages/hackage.html">HackageDB</ulink>.</para> <para>Using a package couldn't be simpler: if you're using - <option>––make</option> or GHCi, then most of the installed packages will be + <option>--make</option> or GHCi, then most of the installed packages will be automatically available to your program without any further options. The exceptions to this rule are covered below in <xref linkend="using-packages" />.</para> @@ -147,8 +147,8 @@ exposed-modules: Network.BSD, or dynamically is controlled by the flag pair <option>-static</option>/<option>-dynamic</option>.</para> - <para>In <option>––make</option> mode - and <option>––interactive</option> mode (see + <para>In <option>--make</option> mode + and <option>--interactive</option> mode (see <xref linkend="modes" />), the compiler normally determines which packages are required by the current Haskell modules, and links only those. In batch mode @@ -961,9 +961,9 @@ ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf <varlistentry> <term> - <option>––force</option> + <option>--force</option> <indexterm><primary> - <option>––force</option> + <option>--force</option> </primary></indexterm> </term> <listitem> @@ -977,7 +977,7 @@ ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf <varlistentry> <term> - <option>––global</option><indexterm><primary><option>––global</option></primary> + <option>--global</option><indexterm><primary><option>--global</option></primary> </indexterm> </term> <listitem> @@ -991,7 +991,7 @@ ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf <varlistentry> <term> - <option>––help</option><indexterm><primary><option>––help</option></primary> + <option>--help</option><indexterm><primary><option>--help</option></primary> </indexterm> </term> <term> @@ -1005,7 +1005,7 @@ ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf <varlistentry> <term> - <option>––user</option><indexterm><primary><option>––user</option></primary> + <option>--user</option><indexterm><primary><option>--user</option></primary> </indexterm> </term> <listitem> @@ -1040,7 +1040,7 @@ ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf </indexterm> </term> <term> - <option>––version</option><indexterm><primary><option>––version</option></primary> + <option>--version</option><indexterm><primary><option>--version</option></primary> </indexterm> </term> <listitem> @@ -1115,11 +1115,11 @@ ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf it. To build one manually, the following GNU <command>ld</command> command can be used:</para> -<screen>ld -r ––whole-archive -o HSfoo.o libHSfoo.a</screen> +<screen>ld -r --whole-archive -o HSfoo.o libHSfoo.a</screen> <para>(replace - <literal>––whole-archive</literal> with - <literal>–all_load</literal> on MacOS X)</para> + <literal>--whole-archive</literal> with + <literal>-all_load</literal> on MacOS X)</para> </listitem> <listitem> <para>When building the package as shared library, GHC can be used to diff --git a/docs/users_guide/phases.xml b/docs/users_guide/phases.xml index f4019bd8cd..90489e84d2 100644 --- a/docs/users_guide/phases.xml +++ b/docs/users_guide/phases.xml @@ -693,7 +693,7 @@ $ cat foo.hspp</screen> </term> <listitem> <para>Omits the link step. This option can be used with - <option>––make</option> to avoid the automatic linking + <option>--make</option> to avoid the automatic linking that takes place if the program contains a <literal>Main</literal> module.</para> </listitem> diff --git a/docs/users_guide/profiling.xml b/docs/users_guide/profiling.xml index a776382645..fdc7b2b24d 100644 --- a/docs/users_guide/profiling.xml +++ b/docs/users_guide/profiling.xml @@ -1077,7 +1077,7 @@ MAIN MAIN 102 0 0.0 0.0 100.0 1 </sect1> <sect1 id="hp2ps"> - <title><command>hp2ps</command>––heap profile to PostScript</title> + <title><command>hp2ps</command>--heap profile to PostScript</title> <indexterm><primary><command>hp2ps</command></primary></indexterm> <indexterm><primary>heap profiles</primary></indexterm> diff --git a/docs/users_guide/runtime_control.xml b/docs/users_guide/runtime_control.xml index bc50f28d3c..3e3ae3f7d2 100644 --- a/docs/users_guide/runtime_control.xml +++ b/docs/users_guide/runtime_control.xml @@ -100,7 +100,7 @@ $ ./prog -f +RTS -H32m -S -RTS -h foo bar <para> If you absolutely positively want all the rest of the options in a command line to go to the program (and not the RTS), use a - <option>––RTS</option><indexterm><primary><option>--RTS</option></primary></indexterm>. + <option>--RTS</option><indexterm><primary><option>--RTS</option></primary></indexterm>. </para> <para> diff --git a/docs/users_guide/separate_compilation.xml b/docs/users_guide/separate_compilation.xml index d0acbfb39f..84f6684307 100644 --- a/docs/users_guide/separate_compilation.xml +++ b/docs/users_guide/separate_compilation.xml @@ -836,7 +836,13 @@ values. For example: </programlisting> </para></listitem> <listitem><para> Fixity declarations are exactly as in Haskell.</para></listitem> -<listitem><para> Type synonym declarations are exactly as in Haskell.</para></listitem> +<listitem><para> Vanilla type synonym declarations are exactly as in Haskell.</para></listitem> +<listitem><para> Open type and data family declarations are exactly as in Haskell.</para></listitem> +<listitem><para> A closed type family may optionally omit its equations, as in the following example: +<programlisting> + type family ClosedFam a where .. +</programlisting> +The <literal>..</literal> is meant literally -- you should write two dots in your file. Note that the <literal>where</literal> clause is still necessary to distinguish closed families from open ones. If you give any equations of a closed family, you must give all of them, in the same order as they appear in the accompanying Haskell file.</para></listitem> <listitem><para> A data type declaration can either be given in full, exactly as in Haskell, or it can be given abstractly, by omitting the '=' sign and everything that follows. For example: <programlisting> @@ -1037,7 +1043,7 @@ M.o : X.hi-boot locate any imported modules that come from packages. The package modules won't be included in the dependencies generated, though (but see the - <option>––include-pkg-deps</option> option below).</para> + <option>--include-pkg-deps</option> option below).</para> <para>The dependency generation phase of GHC can take some additional options, which you may find useful. @@ -1104,7 +1110,7 @@ M.o : X.hi-boot </varlistentry> <varlistentry> - <term><option>––exclude-module=<file></option></term> + <term><option>--exclude-module=<file></option></term> <listitem> <para>Regard <filename><file></filename> as "stable"; i.e., exclude it from having dependencies on @@ -1113,7 +1119,7 @@ M.o : X.hi-boot </varlistentry> <varlistentry> - <term><option>––include-pkg-deps</option></term> + <term><option>--include-pkg-deps</option></term> <listitem> <para>Regard modules imported from packages as unstable, i.e., generate dependencies on any imported package modules diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml index be7e3da2ce..7540279504 100644 --- a/docs/users_guide/using.xml +++ b/docs/users_guide/using.xml @@ -183,7 +183,7 @@ module X where <varlistentry> <term>Mode flags</term> <listitem> - <para>For example, <option>––make</option> or <option>-E</option>. + <para>For example, <option>--make</option> or <option>-E</option>. There may only be a single mode flag on the command line. The available modes are listed in <xref linkend="modes"/>.</para> </listitem> @@ -341,10 +341,10 @@ module X where <varlistentry> <term> - <cmdsynopsis><command>ghc ––make</command> + <cmdsynopsis><command>ghc --make</command> </cmdsynopsis> <indexterm><primary>make mode</primary></indexterm> - <indexterm><primary><option>––make</option></primary></indexterm> + <indexterm><primary><option>--make</option></primary></indexterm> </term> <listitem> <para>In this mode, GHC will build a multi-module Haskell @@ -357,7 +357,7 @@ module X where <para> This mode is the default if there are any Haskell source files mentioned on the command line, and in this case - the <option>––make</option> option can be omitted. + the <option>--make</option> option can be omitted. </para> </listitem> </varlistentry> @@ -435,7 +435,7 @@ module X where <cmdsynopsis> <command>ghc --help</command> <command>ghc -?</command> </cmdsynopsis> - <indexterm><primary><option>––help</option></primary></indexterm> + <indexterm><primary><option>--help</option></primary></indexterm> </term> <listitem> <para>Cause GHC to spew a long usage message to standard @@ -448,7 +448,7 @@ module X where <cmdsynopsis> <command>ghc --show-iface <replaceable>file</replaceable></command> </cmdsynopsis> - <indexterm><primary><option>––--show-iface</option></primary></indexterm> + <indexterm><primary><option>--show-iface</option></primary></indexterm> </term> <listitem> <para>Read the interface in @@ -463,7 +463,7 @@ module X where <command>ghc --supported-extensions</command> <command>ghc --supported-languages</command> </cmdsynopsis> - <indexterm><primary><option>––supported-extensions</option></primary><primary><option>––supported-languages</option></primary></indexterm> + <indexterm><primary><option>--supported-extensions</option></primary><primary><option>--supported-languages</option></primary></indexterm> </term> <listitem> <para>Print the supported language extensions.</para> @@ -473,9 +473,21 @@ module X where <varlistentry> <term> <cmdsynopsis> + <command>ghc --show-options</command> + </cmdsynopsis> + <indexterm><primary><option>--show-options</option></primary></indexterm> + </term> + <listitem> + <para>Print the supported command line options. This flag can be used for autocompletion in a shell.</para> + </listitem> + </varlistentry> + + <varlistentry> + <term> + <cmdsynopsis> <command>ghc --info</command> </cmdsynopsis> - <indexterm><primary><option>––info</option></primary></indexterm> + <indexterm><primary><option>--info</option></primary></indexterm> </term> <listitem> <para>Print information about the compiler.</para> @@ -489,7 +501,7 @@ module X where <command>ghc -V</command> </cmdsynopsis> <indexterm><primary><option>-V</option></primary></indexterm> - <indexterm><primary><option>––version</option></primary></indexterm> + <indexterm><primary><option>--version</option></primary></indexterm> </term> <listitem> <para>Print a one-line string including GHC's version number.</para> @@ -501,7 +513,7 @@ module X where <cmdsynopsis> <command>ghc --numeric-version</command> </cmdsynopsis> - <indexterm><primary><option>––numeric-version</option></primary></indexterm> + <indexterm><primary><option>--numeric-version</option></primary></indexterm> </term> <listitem> <para>Print GHC's numeric version number only.</para> @@ -513,7 +525,7 @@ module X where <cmdsynopsis> <command>ghc --print-libdir</command> </cmdsynopsis> - <indexterm><primary><option>––print-libdir</option></primary></indexterm> + <indexterm><primary><option>--print-libdir</option></primary></indexterm> </term> <listitem> <para>Print the path to GHC's library directory. This is @@ -530,8 +542,8 @@ module X where </variablelist> <sect2 id="make-mode"> - <title>Using <command>ghc</command> <option>––make</option></title> - <indexterm><primary><option>––make</option></primary></indexterm> + <title>Using <command>ghc</command> <option>--make</option></title> + <indexterm><primary><option>--make</option></primary></indexterm> <indexterm><primary>separate compilation</primary></indexterm> <para>In this mode, GHC will build a multi-module Haskell program by following @@ -542,7 +554,7 @@ module X where program like this:</para> <screen> -ghc ––make Main.hs +ghc --make Main.hs </screen> <para> @@ -563,7 +575,7 @@ ghc Main.hs program will also be linked into an executable.</para> <para>The main advantages to using <literal>ghc - ––make</literal> over traditional + --make</literal> over traditional <literal>Makefile</literal>s are:</para> <itemizedlist> @@ -571,7 +583,7 @@ ghc Main.hs <para>GHC doesn't have to be restarted for each compilation, which means it can cache information between compilations. Compiling a multi-module program with <literal>ghc - ––make</literal> can be up to twice as fast as + --make</literal> can be up to twice as fast as running <literal>ghc</literal> individually on each source file.</para> </listitem> @@ -588,7 +600,7 @@ ghc Main.hs <para>Any of the command-line options described in the rest of this chapter can be used with - <option>––make</option>, but note that any options + <option>--make</option>, but note that any options you give on the command line will apply to all the source files compiled, so if you want any options to apply to a single source file only, you'll need to use an <literal>OPTIONS_GHC</literal> @@ -828,8 +840,8 @@ ghc -c Foo.hs <listitem> <para>Minimal verbosity: print one line per compilation (this is the default when - <option>––make</option> or - <option>––interactive</option> is on).</para> + <option>--make</option> or + <option>--interactive</option> is on).</para> </listitem> </varlistentry> @@ -950,17 +962,23 @@ test.hs:(5,4)-(6,7): <option>-fwarn-overlapping-patterns</option>, <option>-fwarn-warnings-deprecations</option>, <option>-fwarn-deprecated-flags</option>, + <option>-fwarn-unrecognised-pragmas</option>, + <option>-fwarn-pointless-pragmas</option>, <option>-fwarn-duplicate-constraints</option>, <option>-fwarn-duplicate-exports</option>, + <option>-fwarn-overflowed-literals</option>, + <option>-fwarn-empty-enumerations</option>, <option>-fwarn-missing-fields</option>, <option>-fwarn-missing-methods</option>, <option>-fwarn-lazy-unlifted-bindings</option>, <option>-fwarn-wrong-do-bind</option>, <option>-fwarn-unsupported-calling-conventions</option>, - <option>-fwarn-dodgy-foreign-imports</option>, and - <option>-fwarn-typeable-instances</option>. The following - flags are - simple ways to select standard “packages” of warnings: + <option>-fwarn-dodgy-foreign-imports</option>, + <option>-fwarn-typeable-instances</option>, + <option>-fwarn-inline-rule-shadowing</option>, and + <option>-fwarn-unsupported-llvm-version</option>. + The following flags are simple ways to select standard + “packages” of warnings: </para> <variablelist> @@ -1078,6 +1096,20 @@ test.hs:(5,4)-(6,7): </varlistentry> <varlistentry> + <term><option>-fwarn-pointless-pragmas</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-pointless-pragmas</option></primary> + </indexterm> + <indexterm><primary>warnings</primary></indexterm> + <indexterm><primary>pragmas</primary></indexterm> + <para>Causes a warning to be emitted when GHC detects that a + module contains a pragma that has no effect.</para> + + <para>This option is on by default.</para> + </listitem> + </varlistentry> + + <varlistentry> <term><option>-fwarn-warnings-deprecations</option>:</term> <listitem> <indexterm><primary><option>-fwarn-warnings-deprecations</option></primary> @@ -1183,6 +1215,30 @@ foreign import "&f" f :: FunPtr t </varlistentry> <varlistentry> + <term><option>-fwarn-overflowed-literals</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-overflowed-literals</option></primary> + </indexterm> + <para> + Causes a warning to be emitted if a literal will overflow, + e.g. <literal>300 :: Word8</literal>. + </para> + </listitem> + </varlistentry> + + <varlistentry> + <term><option>-fwarn-empty-enumerations</option>:</term> + <listitem> + <indexterm><primary><option>-fwarn-empty-enumerations</option></primary> + </indexterm> + <para> + Causes a warning to be emitted if an enumeration is + empty, e.g. <literal>[5 .. 3]</literal>. + </para> + </listitem> + </varlistentry> + + <varlistentry> <term><option>-fwarn-lazy-unlifted-bindings</option>:</term> <listitem> <indexterm><primary><option>-fwarn-lazy-unlifted-bindings</option></primary> @@ -1901,11 +1957,12 @@ f "2" = 2 <indexterm><primary>constructor fields, strict</primary></indexterm> </term> <listitem> - <para>This option causes all constructor fields which are - marked strict (i.e. “!”) and which - representation is smaller or equal to the size of a - pointer to be unpacked, if possible. It is equivalent to - adding an <literal>UNPACK</literal> pragma (see <xref + <para><emphasis>On by default.</emphasis>. This option + causes all constructor fields which are marked strict + (i.e. “!”) and which representation is smaller + or equal to the size of a pointer to be unpacked, if + possible. It is equivalent to adding an + <literal>UNPACK</literal> pragma (see <xref linkend="unpack-pragma"/>) to every strict constructor field that fulfils the size restriction. </para> diff --git a/docs/users_guide/utils.xml b/docs/users_guide/utils.xml index 109cc01752..005f2edaee 100644 --- a/docs/users_guide/utils.xml +++ b/docs/users_guide/utils.xml @@ -187,7 +187,7 @@ tags: <variablelist> <varlistentry> <term><literal>-o FILE</literal> or - <literal>––output=FILE</literal></term> + <literal>--output=FILE</literal></term> <listitem> <para>Name of the Haskell file.</para> </listitem> @@ -195,7 +195,7 @@ tags: <varlistentry> <term><literal>-t FILE</literal> or - <literal>––template=FILE</literal></term> + <literal>--template=FILE</literal></term> <listitem> <para>The template file (see below).</para> </listitem> @@ -203,7 +203,7 @@ tags: <varlistentry> <term><literal>-c PROG</literal> or - <literal>––cc=PROG</literal></term> + <literal>--cc=PROG</literal></term> <listitem> <para>The C compiler to use (default: <command>gcc</command>)</para> @@ -212,7 +212,7 @@ tags: <varlistentry> <term><literal>-l PROG</literal> or - <literal>––ld=PROG</literal></term> + <literal>--ld=PROG</literal></term> <listitem> <para>The linker to use (default: <command>gcc</command>).</para> @@ -221,7 +221,7 @@ tags: <varlistentry> <term><literal>-C FLAG</literal> or - <literal>––cflag=FLAG</literal></term> + <literal>--cflag=FLAG</literal></term> <listitem> <para>An extra flag to pass to the C compiler.</para> </listitem> @@ -236,7 +236,7 @@ tags: <varlistentry> <term><literal>-L FLAG</literal> or - <literal>––lflag=FLAG</literal></term> + <literal>--lflag=FLAG</literal></term> <listitem> <para>An extra flag to pass to the linker.</para> </listitem> @@ -244,7 +244,7 @@ tags: <varlistentry> <term><literal>-i FILE</literal> or - <literal>––include=FILE</literal></term> + <literal>--include=FILE</literal></term> <listitem> <para>As if the appropriate <literal>#include</literal> directive was placed in the source.</para> @@ -253,7 +253,7 @@ tags: <varlistentry> <term><literal>-D NAME[=VALUE]</literal> or - <literal>––define=NAME[=VALUE]</literal></term> + <literal>--define=NAME[=VALUE]</literal></term> <listitem> <para>As if the appropriate <literal>#define</literal> directive was placed in the source.</para> @@ -261,7 +261,7 @@ tags: </varlistentry> <varlistentry> - <term><literal>––no-compile</literal></term> + <term><literal>--no-compile</literal></term> <listitem> <para>Stop after writing out the intermediate C program to disk. The file name for the intermediate C program is the input file name @@ -271,7 +271,7 @@ tags: <varlistentry> <term><literal>-k</literal> or - <literal>––keep-files</literal></term> + <literal>--keep-files</literal></term> <listitem> <para>Proceed as normal, but do not delete any intermediate files.</para> </listitem> @@ -279,14 +279,14 @@ tags: <varlistentry> <term><literal>-x</literal> or - <literal>––cross-compile</literal></term> + <literal>--cross-compile</literal></term> <listitem> <para>Activate cross-compilation mode (see <xref linkend="hsc2hs_cross"/>).</para> </listitem> </varlistentry> <varlistentry> - <term><literal>––cross-safe</literal></term> + <term><literal>--cross-safe</literal></term> <listitem> <para>Restrict the .hsc directives to those supported by the <literal>--cross-compile</literal> mode (see <xref linkend="hsc2hs_cross"/>). @@ -298,14 +298,14 @@ tags: <varlistentry> - <term><literal>-?</literal> or <literal>––help</literal></term> + <term><literal>-?</literal> or <literal>--help</literal></term> <listitem> <para>Display a summary of the available flags and exit successfully.</para> </listitem> </varlistentry> <varlistentry> - <term><literal>-V</literal> or <literal>––version</literal></term> + <term><literal>-V</literal> or <literal>--version</literal></term> <listitem> <para>Output version information and exit successfully.</para> </listitem> diff --git a/docs/users_guide/win32-dlls.xml b/docs/users_guide/win32-dlls.xml index ad1c788ada..2e2cb46298 100644 --- a/docs/users_guide/win32-dlls.xml +++ b/docs/users_guide/win32-dlls.xml @@ -313,7 +313,7 @@ option on all the Haskell modules that make up your application. <para> <indexterm><primary>Creating a Win32 DLL</primary></indexterm> -<indexterm><primary>–shared</primary></indexterm> +<indexterm><primary>-shared</primary></indexterm> Sealing up your Haskell library inside a DLL is straightforward; compile up the object files that make up the library, and then build the DLL by issuing a command of the form: @@ -321,12 +321,12 @@ the DLL by issuing a command of the form: <para> <screen> -ghc –shared -o foo.dll bar.o baz.o wibble.a -lfooble +ghc -shared -o foo.dll bar.o baz.o wibble.a -lfooble </screen> </para> <para> -By feeding the ghc compiler driver the option <option>–shared</option>, it +By feeding the ghc compiler driver the option <option>-shared</option>, it will build a DLL rather than produce an executable. The DLL will consist of all the object files and archives given on the command line. @@ -366,12 +366,12 @@ you compile into a DLL must have a common root. <listitem> <para> By default, the entry points of all the object files will be exported from -the DLL when using <option>–shared</option>. Should you want to constrain +the DLL when using <option>-shared</option>. Should you want to constrain this, you can specify the <emphasis>module definition file</emphasis> to use on the command line as follows: <screen> -ghc –shared -o .... MyDef.def +ghc -shared -o .... MyDef.def </screen> See Microsoft documentation for details, but a module definition file @@ -390,7 +390,7 @@ EXPORTS <listitem> <para> -In addition to creating a DLL, the <option>–shared</option> option also +In addition to creating a DLL, the <option>-shared</option> option also creates an import library. The import library name is derived from the name of the DLL, as follows: diff --git a/driver/ghci/ghc.mk b/driver/ghci/ghc.mk index 736b7a927d..bd4bf36117 100644 --- a/driver/ghci/ghc.mk +++ b/driver/ghci/ghc.mk @@ -38,7 +38,7 @@ driver/ghci_dist_OTHER_OBJS = driver/ghci/ghci.res $(eval $(call build-prog,driver/ghci,dist,1)) -driver/ghci_dist_PROG_VER = ghci-$(ProjectVersion)$(exeext) +driver/ghci_dist_PROG_VER = ghci-$(ProjectVersion)$(exeext1) INSTALL_BINS += driver/ghci/dist/build/tmp/$(driver/ghci_dist_PROG_VER) diff --git a/driver/utils/dynwrapper.c b/driver/utils/dynwrapper.c new file mode 100644 index 0000000000..a9250f58ba --- /dev/null +++ b/driver/utils/dynwrapper.c @@ -0,0 +1,197 @@ + +/* +Need to concatenate this file with something that defines: +LPTSTR path_dirs[]; +LPTSTR progDll; +LPTSTR rtsDll; +int rtsOpts; +*/ + +#include <stdarg.h> +#include <stdio.h> +#include <Windows.h> +#include <Shlwapi.h> + +#include "Rts.h" + +void die(char *fmt, ...) { + va_list argp; + + fprintf(stderr, "error: "); + va_start(argp, fmt); + vfprintf(stderr, fmt, argp); + va_end(argp); + fprintf(stderr, "\n"); + + exit(1); +} + +LPTSTR getModuleFileName(void) { + HMODULE hExe; + LPTSTR exePath; + DWORD exePathSize; + DWORD res; + + hExe = GetModuleHandle(NULL); + if (hExe == NULL) { + die("GetModuleHandle failed"); + } + + // 300 chars ought to be enough, but there are various cases where + // it might not be (e.g. unicode paths, or \\server\foo\... paths. + // So we start off with 300 and grow if necessary. + exePathSize = 300; + exePath = malloc(exePathSize); + if (exePath == NULL) { + die("Mallocing %d for GetModuleFileName failed", exePathSize); + } + + while ((res = GetModuleFileName(hExe, exePath, exePathSize)) && + (GetLastError() == ERROR_INSUFFICIENT_BUFFER)) { + exePathSize *= 2; + exePath = realloc(exePath, exePathSize); + if (exePath == NULL) { + die("Reallocing %d for GetModuleFileName failed", exePathSize); + } + } + + if (!res) { + die("GetModuleFileName failed"); + } + return exePath; +} + +void setPath(void) { + LPTSTR *dir; + LPTSTR path; + int n; + int len = 0; + LPTSTR exePath, s; + + exePath = getModuleFileName(); + for(s = exePath; *s != '\0'; s++) { + if (*s == '\\') { + *s = '/'; + } + } + s = StrRChr(exePath, NULL, '/'); + if (s == NULL) { + die("No directory separator in executable path: %s", exePath); + } + s[0] = '\0'; + n = s - exePath; + + for (dir = path_dirs; *dir != NULL; dir++) { + len += n + lstrlen(*dir) + 1/* semicolon */; + } + len++; // NUL + + path = malloc(len); + if (path == NULL) { + die("Mallocing %d for PATH failed", len); + } + s = path; + for (dir = path_dirs; *dir != NULL; dir++) { + StrCpy(s, exePath); + s += n; + StrCpy(s, *dir); + s += lstrlen(*dir); + s[0] = ';'; + s++; + } + s[0] = '\0'; + free(exePath); + + if (! SetEnvironmentVariable(TEXT("PATH"), path)) { + printf("SetEnvironmentVariable failed (%d)\n", GetLastError()); + } + free(path); +} + +HINSTANCE loadDll(LPTSTR dll) { + HINSTANCE h; + DWORD dw; + LPVOID lpMsgBuf; + + h = LoadLibrary(dll); + + if (h == NULL) { + dw = GetLastError(); + FormatMessage( + FORMAT_MESSAGE_ALLOCATE_BUFFER | + FORMAT_MESSAGE_FROM_SYSTEM | + FORMAT_MESSAGE_IGNORE_INSERTS, + NULL, + dw, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), + (LPTSTR) &lpMsgBuf, + 0, NULL ); + die("loadDll %s failed: %d: %s\n", dll, dw, lpMsgBuf); + } + + return h; +} + +void *GetNonNullProcAddress(HINSTANCE h, char *sym) { + void *p; + + p = GetProcAddress(h, sym); + if (p == NULL) { + die("Failed to find address for %s", sym); + } + return p; +} + +HINSTANCE GetNonNullModuleHandle(LPTSTR dll) { + HINSTANCE h; + + h = GetModuleHandle(dll); + if (h == NULL) { + die("Failed to get module handle for %s", dll); + } + return h; +} + +typedef int (*hs_main_t)(int , char **, StgClosure *, RtsConfig); + +int main(int argc, char *argv[]) { + void *p; + HINSTANCE hRtsDll, hProgDll; + LPTSTR oldPath; + + StgClosure *main_p; + RtsConfig rts_config; + hs_main_t hs_main_p; + + // MSDN says: An environment variable has a maximum size limit of + // 32,767 characters, including the null-terminating character. + oldPath = malloc(32767); + if (oldPath == NULL) { + die("Mallocing 32767 for oldPath failed"); + } + + if (!GetEnvironmentVariable(TEXT("PATH"), oldPath, 32767)) { + if (GetLastError() == ERROR_ENVVAR_NOT_FOUND) { + oldPath[0] = '\0'; + } + else { + die("Looking up PATH env var failed"); + } + } + setPath(); + hProgDll = loadDll(progDll); + if (! SetEnvironmentVariable(TEXT("PATH"), oldPath)) { + printf("SetEnvironmentVariable failed (%d)\n", GetLastError()); + } + free(oldPath); + + hRtsDll = GetNonNullModuleHandle(rtsDll); + + hs_main_p = GetNonNullProcAddress(hRtsDll, "hs_main"); + main_p = GetNonNullProcAddress(hProgDll, "ZCMain_main_closure"); + rts_config.rts_opts_enabled = rtsOpts; + rts_config.rts_opts = NULL; + + return hs_main_p(argc, argv, main_p, rts_config); +} + @@ -76,11 +76,28 @@ default : all + +################################################## +# Check that we have a new enough 'make' + +HAVE_EVAL := NO +$(eval HAVE_EVAL := YES) + +ifeq "$(HAVE_EVAL)" "NO" +$(error Your make does not support eval. You need GNU make >= 3.81) +endif + +ifeq "$(abspath /)" "" +$(error Your make does not support abspath. You need GNU make >= 3.81) +endif +################################################## + + # Catch make if it runs away into an infinite loop ifeq "$(MAKE_RESTARTS)" "" else ifeq "$(MAKE_RESTARTS)" "1" else -$(error Make has restarted itself $(MAKE_RESTARTS) times; is there a makefile bug?) +$(error Make has restarted itself $(MAKE_RESTARTS) times; is there a makefile bug? See http://hackage.haskell.org/trac/ghc/wiki/Building/Troubleshooting#Makehasrestarteditself3timesisthereamakefilebug for details) endif ifneq "$(CLEANING)" "YES" @@ -110,6 +127,14 @@ comma=, show: @echo '$(VALUE)="$($(VALUE))"' +# echo is used by the nightly builders to query the build system for +# information. +# Using printf means that we don't get a trailing newline. We escape +# backslashes and double quotes in the string to protect them from the +# shell, and percent signs to protect them from printf. +echo: + @printf "$(subst %,%%,$(subst ",\",$(subst \,\\\\,$($(VALUE)))))" + # ----------------------------------------------------------------------------- # Include subsidiary build-system bits @@ -167,7 +192,7 @@ include rules/clean-target.mk # ----------------------------------------------------------------------------- # The inplace tree -$(eval $(call clean-target,inplace,,inplace/bin inplace/lib)) +$(eval $(call clean-target,root,inplace,inplace/bin inplace/lib)) # ----------------------------------------------------------------------------- # Whether to build dependencies or not @@ -204,6 +229,15 @@ GHCI_WAY = v HADDOCK_WAY = v endif +WINDOWS_DYN_PROG_RTS := rts +ifeq "$(GhcThreaded)" "YES" +WINDOWS_DYN_PROG_RTS := $(WINDOWS_DYN_PROG_RTS)_thr +endif +ifeq "$(GhcDebugged)" "YES" +WINDOWS_DYN_PROG_RTS := $(WINDOWS_DYN_PROG_RTS)_debug +endif +WINDOWS_DYN_PROG_RTS := $(WINDOWS_DYN_PROG_RTS)_dyn_LIB_NAME + # ----------------------------------------------------------------------------- # Compilation Flags @@ -249,6 +283,11 @@ include rules/build-dependencies.mk include rules/include-dependencies.mk # ----------------------------------------------------------------------------- +# Dynamic library references + +include rules/relative-dynlib-references.mk + +# ----------------------------------------------------------------------------- # Build package-data.mk files include rules/build-package-data.mk @@ -494,12 +533,17 @@ utils/runghc/dist-install/package-data.mk: compiler/stage2/package-data.mk utils/mkUserGuidePart/dist/package-data.mk: compiler/stage2/package-data.mk # add the final package.conf dependency: ghc-prim depends on RTS -libraries/ghc-prim/dist-install/package-data.mk : rts/package.conf.inplace +libraries/ghc-prim/dist-install/package-data.mk : rts/dist/package.conf.inplace endif # -------------------------------- # Misc package-related settings +# Run Haddock for the packages that will be installed. We need to handle +# compiler specially due to the different dist directory name. +$(foreach p,$(INSTALL_PACKAGES),$(eval $p_dist-install_DO_HADDOCK = YES)) +compiler_stage2_DO_HADDOCK = YES + BOOT_PKG_CONSTRAINTS := \ $(foreach d,$(PACKAGES_STAGE0),\ $(foreach p,$(basename $(notdir $(wildcard libraries/$d/*.cabal))),\ @@ -512,24 +556,6 @@ ALL_STAGE1_LIBS += $(foreach lib,$(PACKAGES_STAGE1),$(libraries/$(lib)_dist-inst endif BOOT_LIBS = $(foreach lib,$(PACKAGES_STAGE0),$(libraries/$(lib)_dist-boot_v_LIB)) -# ----------------------------------------------- -# Haddock-related bits - -# Run Haddock for the packages that will be installed. We need to handle -# compiler specially due to the different dist directory name. -$(foreach p,$(INSTALL_PACKAGES),$(eval $p_dist-install_DO_HADDOCK = YES)) -compiler_stage2_DO_HADDOCK = YES - -# Build the Haddock contents and index -ifeq "$(HADDOCK_DOCS)" "YES" -libraries/dist-haddock/index.html: inplace/bin/haddock$(exeext) $(ALL_HADDOCK_FILES) - cd libraries && sh gen_contents_index --intree -ifeq "$(phase)" "final" -$(eval $(call all-target,library_doc_index,libraries/dist-haddock/index.html)) -endif -INSTALL_LIBRARY_DOCS += libraries/dist-haddock/* -endif - # ---------------------------------------- # Special magic for the ghc-prim package @@ -569,18 +595,6 @@ $(error Unknown integer library: $(INTEGER_LIBRARY)) endif endif -# ---------------------------------------- -# Workarounds for problems building DLLs on Windows - -ifeq "$(TargetOS_CPP)" "mingw32" -# We don't build the GHC package the dyn way on Windows, so -# we can't build these packages the dyn way either. See trac #5987 -libraries/dph/dph-lifted-base_dist-install_EXCLUDED_WAYS := dyn -libraries/dph/dph-lifted-boxed_dist-install_EXCLUDED_WAYS := dyn -libraries/dph/dph-lifted-copy_dist-install_EXCLUDED_WAYS := dyn -libraries/dph/dph-lifted-vseg_dist-install_EXCLUDED_WAYS := dyn -endif - # ----------------------------------------------------------------------------- # Include build instructions from all subdirs @@ -592,8 +606,6 @@ ifeq "$(Windows_Host)" "YES" BUILD_DIRS += utils/touchy endif -BUILD_DIRS += docs/users_guide -BUILD_DIRS += docs/man BUILD_DIRS += utils/unlit BUILD_DIRS += utils/hp2ps @@ -610,6 +622,7 @@ BUILD_DIRS += driver/ghci BUILD_DIRS += driver/ghc BUILD_DIRS += driver/haddock BUILD_DIRS += libffi +BUILD_DIRS += utils/deriveConstants BUILD_DIRS += includes BUILD_DIRS += rts @@ -633,18 +646,10 @@ endif ifeq "$(INTEGER_LIBRARY)" "integer-gmp" BUILD_DIRS += libraries/integer-gmp/gmp +BUILD_DIRS += libraries/integer-gmp/mkGmpDerivedConstants else ifneq "$(findstring clean,$(MAKECMDGOALS))" "" BUILD_DIRS += libraries/integer-gmp/gmp -endif - -ifeq "$(CrossCompiling)-$(phase)" "YES-final" -MAYBE_GHCTAGS= -MAYBE_HPC= -MAYBE_RUNGHC= -else -MAYBE_GHCTAGS=utils/ghctags -MAYBE_HPC=utils/hpc -MAYBE_RUNGHC=utils/runghc +BUILD_DIRS += libraries/integer-gmp/mkGmpDerivedConstants endif BUILD_DIRS += utils/haddock @@ -652,14 +657,15 @@ BUILD_DIRS += utils/haddock/doc BUILD_DIRS += compiler BUILD_DIRS += utils/hsc2hs BUILD_DIRS += utils/ghc-pkg -BUILD_DIRS += utils/deriveConstants BUILD_DIRS += utils/testremove -BUILD_DIRS += $(MAYBE_GHCTAGS) +ifeq "$(Stage1Only)" "NO" +BUILD_DIRS += utils/ghctags +endif BUILD_DIRS += utils/dll-split BUILD_DIRS += utils/ghc-pwd BUILD_DIRS += utils/ghc-cabal -BUILD_DIRS += $(MAYBE_HPC) -BUILD_DIRS += $(MAYBE_RUNGHC) +BUILD_DIRS += utils/hpc +BUILD_DIRS += utils/runghc BUILD_DIRS += ghc ifneq "$(BINDIST)" "YES" @@ -668,6 +674,8 @@ BUILD_DIRS += utils/mkUserGuidePart endif endif +BUILD_DIRS += docs/users_guide +BUILD_DIRS += docs/man BUILD_DIRS += utils/count_lines BUILD_DIRS += utils/compare_sizes @@ -710,7 +718,7 @@ $(shell echo "[]" >$(BOOTSTRAPPING_CONF)) endif endif -$(eval $(call clean-target,$(BOOTSTRAPPING_CONF),,$(BOOTSTRAPPING_CONF))) +$(eval $(call clean-target,root,bootstrapping_conf,$(BOOTSTRAPPING_CONF))) # register the boot packages in strict sequence, because running # multiple ghc-pkgs in parallel doesn't work (registrations may get @@ -746,6 +754,19 @@ libraries/vector/dist-install/build/Data/Vector/Fusion/Stream/Monadic.$($(way)_o )) endif +# ----------------------------------------------- +# Haddock-related bits + +# Build the Haddock contents and index +ifeq "$(HADDOCK_DOCS)" "YES" +libraries/dist-haddock/index.html: $(haddock_INPLACE) $(ALL_HADDOCK_FILES) + cd libraries && sh gen_contents_index --intree +ifeq "$(phase)" "final" +$(eval $(call all-target,library_doc_index,libraries/dist-haddock/index.html)) +endif +INSTALL_LIBRARY_DOCS += libraries/dist-haddock/* +endif + # ----------------------------------------------------------------------------- # Creating a local mingw copy on Windows @@ -796,7 +817,7 @@ define installLibsTo case $$i in \ *.a) \ $(call INSTALL_DATA,$(INSTALL_OPTS),$$i,$2); \ - $(RANLIB) $2/`basename $$i` ;; \ + $(RANLIB_CMD) $2/`basename $$i` ;; \ *.dll) \ $(call INSTALL_PROGRAM,$(INSTALL_OPTS),$$i,$2) ; \ $(STRIP_CMD) $2/`basename $$i` ;; \ @@ -881,7 +902,7 @@ INSTALL_DISTDIR_compiler = stage2 # Now we can do the installation install_packages: install_libexecs -install_packages: rts/package.conf.install +install_packages: rts/dist/package.conf.install $(call INSTALL_DIR,"$(DESTDIR)$(topdir)") $(call removeTrees,"$(INSTALLED_PACKAGE_CONF)") $(call INSTALL_DIR,"$(INSTALLED_PACKAGE_CONF)") @@ -892,20 +913,20 @@ install_packages: rts/package.conf.install $(foreach p, $(INSTALL_PACKAGES), \ $(call make-command, \ "$(ghc-cabal_INPLACE)" copy \ - "$(STRIP_CMD)" \ $p $(INSTALL_DISTDIR_$p) \ + "$(STRIP_CMD)" \ '$(DESTDIR)' \ '$(prefix)' \ '$(ghclibdir)' \ '$(docdir)/html/libraries')) - "$(INSTALLED_GHC_PKG_REAL)" --force --global-package-db "$(INSTALLED_PACKAGE_CONF)" update rts/package.conf.install + "$(INSTALLED_GHC_PKG_REAL)" --force --global-package-db "$(INSTALLED_PACKAGE_CONF)" update rts/dist/package.conf.install $(foreach p, $(INSTALL_PACKAGES), \ $(call make-command, \ "$(ghc-cabal_INPLACE)" register \ + $p $(INSTALL_DISTDIR_$p) \ "$(INSTALLED_GHC_REAL)" \ "$(INSTALLED_GHC_PKG_REAL)" \ "$(DESTDIR)$(topdir)" \ - $p $(INSTALL_DISTDIR_$p) \ '$(DESTDIR)' \ '$(prefix)' \ '$(ghclibdir)' \ @@ -992,20 +1013,13 @@ unix-binary-dist-prep: $(call removeFiles,$(BIN_DIST_PREP_TAR)) # h means "follow symlinks", e.g. if aclocal.m4 is a symlink to a source # tree then we want to include the real file, not a symlink to it - cd bindistprep && "$(TAR_CMD)" hcf - -T ../$(BIN_DIST_LIST) | bzip2 -c > ../$(BIN_DIST_PREP_TAR_BZ2) + cd bindistprep && "$(TAR_CMD)" hcf - -T ../bindist-list | bzip2 -c > ../$(BIN_DIST_PREP_TAR_BZ2) windows-binary-dist-prep: $(call removeTrees,bindistprep/) $(MAKE) prefix=$(TOP)/$(BIN_DIST_PREP_DIR) install cd bindistprep && "$(TAR_CMD)" cf - $(BIN_DIST_NAME) | bzip2 -c > ../$(BIN_DIST_PREP_TAR_BZ2) -windows-installer: -ifeq "$(ISCC_CMD)" "" - @echo No ISCC_CMD, so not making installer -else - "$(ISCC_CMD)" /O. /Fbindistprep/$(WINDOWS_INSTALLER_BASE) - < distrib/ghc.iss -endif - # tryTimes tries to run its third argument multiple times, until it # succeeds. Don't call it directly; call try10Times instead. # The first and second argument to tryTimes are lists of values. @@ -1023,9 +1037,6 @@ try10Times = $(call tryTimes,,x x x x x x x x x x,$1) { echo Failed; false; } .PHONY: publish-binary-dist publish-binary-dist: $(call try10Times,$(PublishCp) $(BIN_DIST_TAR_BZ2) $(PublishLocation)/dist) -ifeq "$(mingw32_TARGET_OS)" "1" - $(call try10Times,$(PublishCp) $(WINDOWS_INSTALLER) $(PublishLocation)/dist) -endif ifeq "$(mingw32_TARGET_OS)" "1" DOCDIR_TO_PUBLISH = $(BIN_DIST_INST_DIR)/doc @@ -1047,7 +1058,7 @@ publish-docs: # # A source dist is built from a complete build tree, because we -# require some extra files not contained in a darcs checkout: the +# require some extra files not contained in a git checkout: the # output from Happy and Alex, for example. # # The steps performed by 'make dist' are as follows: @@ -1062,26 +1073,31 @@ publish-docs: SRC_DIST_ROOT = sdistprep SRC_DIST_BASE_NAME = ghc-$(ProjectVersion) -SRC_DIST_GHC_NAME = ghc-$(ProjectVersion)-src -SRC_DIST_GHC_ROOT = $(SRC_DIST_ROOT)/ghc -SRC_DIST_GHC_DIR = $(SRC_DIST_GHC_ROOT)/$(SRC_DIST_BASE_NAME) -SRC_DIST_GHC_TARBALL = $(SRC_DIST_ROOT)/$(SRC_DIST_GHC_NAME).tar.bz2 +SRC_DIST_GHC_NAME = ghc-$(ProjectVersion)-src +SRC_DIST_GHC_ROOT = $(SRC_DIST_ROOT)/ghc +SRC_DIST_GHC_DIR = $(SRC_DIST_GHC_ROOT)/$(SRC_DIST_BASE_NAME) +SRC_DIST_GHC_TARBALL = $(SRC_DIST_ROOT)/$(SRC_DIST_GHC_NAME).tar.bz2 -SRC_DIST_TESTSUITE_NAME = ghc-$(ProjectVersion)-testsuite -SRC_DIST_TESTSUITE_ROOT = $(SRC_DIST_ROOT)/testsuite-ghc -SRC_DIST_TESTSUITE_DIR = $(SRC_DIST_TESTSUITE_ROOT)/$(SRC_DIST_BASE_NAME) -SRC_DIST_TESTSUITE_TARBALL = $(SRC_DIST_ROOT)/$(SRC_DIST_TESTSUITE_NAME).tar.bz2 +SRC_DIST_WINDOWS_TARBALLS_NAME = ghc-$(ProjectVersion)-windows-extra-src +SRC_DIST_WINDOWS_TARBALLS_ROOT = $(SRC_DIST_ROOT)/windows-tarballs +SRC_DIST_WINDOWS_TARBALLS_DIR = $(SRC_DIST_WINDOWS_TARBALLS_ROOT)/$(SRC_DIST_BASE_NAME) +SRC_DIST_WINDOWS_TARBALLS_TARBALL = $(SRC_DIST_ROOT)/$(SRC_DIST_WINDOWS_TARBALLS_NAME).tar.bz2 + +SRC_DIST_TESTSUITE_NAME = ghc-$(ProjectVersion)-testsuite +SRC_DIST_TESTSUITE_ROOT = $(SRC_DIST_ROOT)/testsuite-ghc +SRC_DIST_TESTSUITE_DIR = $(SRC_DIST_TESTSUITE_ROOT)/$(SRC_DIST_BASE_NAME) +SRC_DIST_TESTSUITE_TARBALL = $(SRC_DIST_ROOT)/$(SRC_DIST_TESTSUITE_NAME).tar.bz2 # # Files to include in source distributions # SRC_DIST_GHC_DIRS = mk rules docs distrib bindisttest libffi includes \ - utils docs rts compiler ghc driver libraries ghc-tarballs + utils docs rts compiler ghc driver libraries libffi-tarballs SRC_DIST_GHC_FILES += \ configure.ac config.guess config.sub configure \ aclocal.m4 README ANNOUNCE HACKING LICENSE Makefile install-sh \ - ghc.spec.in ghc.spec settings.in VERSION \ - boot boot-pkgs packages ghc.mk + settings.in VERSION \ + boot packages ghc.mk VERSION : echo $(ProjectVersion) >VERSION @@ -1123,6 +1139,17 @@ sdist-ghc-prep : $(call sdist_ghc_file,utils/haddock,dist,src,Haddock,Parse,y) cd $(SRC_DIST_GHC_DIR) && "$(FIND)" $(SRC_DIST_GHC_DIRS) \( -name .git -o -name "autom4te*" -o -name "*~" -o -name "\#*" -o -name ".\#*" -o -name "log" -o -name "*-SAVE" -o -name "*.orig" -o -name "*.rej" \) -print | "$(XARGS)" $(XARGS_OPTS) "$(RM)" $(RM_OPTS_REC) +.PHONY: sdist-windows-tarballs-prep +sdist-windows-tarballs-prep : + $(call removeTrees,$(SRC_DIST_WINDOWS_TARBALLS_ROOT)) + $(call removeFiles,$(SRC_DIST_WINDOWS_TARBALLS_TARBALL)) + -mkdir $(SRC_DIST_ROOT) + mkdir $(SRC_DIST_WINDOWS_TARBALLS_ROOT) + mkdir $(SRC_DIST_WINDOWS_TARBALLS_DIR) + mkdir $(SRC_DIST_WINDOWS_TARBALLS_DIR)/ghc-tarballs + cd $(SRC_DIST_WINDOWS_TARBALLS_DIR)/ghc-tarballs && lndir $(TOP)/ghc-tarballs + $(call removeTrees,$(SRC_DIST_WINDOWS_TARBALLS_DIR)/ghc-tarballs/.git) + .PHONY: sdist-testsuite-prep sdist-testsuite-prep : $(call removeTrees,$(SRC_DIST_TESTSUITE_ROOT)) @@ -1135,9 +1162,10 @@ sdist-testsuite-prep : $(call removeTrees,$(SRC_DIST_TESTSUITE_DIR)/testsuite/.git) .PHONY: sdist -sdist : sdist-ghc-prep sdist-testsuite-prep - cd $(SRC_DIST_GHC_ROOT) && "$(TAR_CMD)" chf - $(SRC_DIST_BASE_NAME) 2> src_ghc_log | bzip2 > $(TOP)/$(SRC_DIST_GHC_TARBALL) - cd $(SRC_DIST_TESTSUITE_ROOT) && "$(TAR_CMD)" chf - $(SRC_DIST_BASE_NAME) 2> src_ghc_log | bzip2 > $(TOP)/$(SRC_DIST_TESTSUITE_TARBALL) +sdist : sdist-ghc-prep sdist-windows-tarballs-prep sdist-testsuite-prep + cd $(SRC_DIST_GHC_ROOT) && "$(TAR_CMD)" chf - $(SRC_DIST_BASE_NAME) 2> src_ghc_log | bzip2 > $(TOP)/$(SRC_DIST_GHC_TARBALL) + cd $(SRC_DIST_WINDOWS_TARBALLS_ROOT) && "$(TAR_CMD)" chf - $(SRC_DIST_BASE_NAME) 2> windows_extra_src_ghc_log | bzip2 > $(TOP)/$(SRC_DIST_WINDOWS_TARBALLS_TARBALL) + cd $(SRC_DIST_TESTSUITE_ROOT) && "$(TAR_CMD)" chf - $(SRC_DIST_BASE_NAME) 2> testsuite_log | bzip2 > $(TOP)/$(SRC_DIST_TESTSUITE_TARBALL) sdist-manifest : $(SRC_DIST_GHC_TARBALL) tar tjf $(SRC_DIST_GHC_TARBALL) | sed "s|^ghc-$(ProjectVersion)/||" | sort >sdist-manifest @@ -1216,26 +1244,64 @@ clean_bindistprep: $(call removeTrees,bindistprep/) distclean : clean - $(call removeFiles,config.cache config.status config.log mk/config.h mk/stamp-h) - $(call removeFiles,mk/config.mk mk/are-validating.mk mk/project.mk) - $(call removeFiles,mk/config.mk.old mk/project.mk.old) - $(call removeFiles,settings docs/users_guide/ug-book.xml) - $(call removeFiles,compiler/ghc.cabal compiler/ghc.cabal.old) +# Clean the files that ./validate creates. + $(call removeFiles,mk/are-validating.mk) + +# Clean the files that we ask ./configure to create. + $(call removeFiles,mk/config.mk) + $(call removeFiles,mk/install.mk) + $(call removeFiles,mk/project.mk) + $(call removeFiles,compiler/ghc.cabal) $(call removeFiles,ghc/ghc-bin.cabal) + $(call removeFiles,utils/runghc/runghc.cabal) + $(call removeFiles,settings) + $(call removeFiles,docs/users_guide/ug-book.xml) + $(call removeFiles,docs/users_guide/ug-ent.xml) + $(call removeFiles,docs/index.html) + $(call removeFiles,libraries/prologue.txt) + $(call removeFiles,distrib/configure.ac) + +# ./configure also makes these. + $(call removeFiles,mk/config.h) + +# Internal files generated by ./configure for itself. + $(call removeFiles,config.cache config.status config.log) + +# ./configure build ghc-pwd in utils/ghc-pwd/dist-boot, so clean it up. + $(call removeTrees,utils/ghc-pwd/dist-boot) + +# The root Makefile makes .old versions of some files that configure +# generates, so we clean those too. + $(call removeFiles,mk/config.mk.old) + $(call removeFiles,mk/project.mk.old) + $(call removeFiles,compiler/ghc.cabal.old) + +# Clean the *Config.h files generated by library configure scripts $(call removeFiles,libraries/base/include/HsBaseConfig.h) + $(call removeFiles,libraries/base/include/EventConfig.h) $(call removeFiles,libraries/directory/include/HsDirectoryConfig.h) $(call removeFiles,libraries/process/include/HsProcessConfig.h) $(call removeFiles,libraries/unix/include/HsUnixConfig.h) + $(call removeFiles,libraries/time/include/HsTimeConfig.h) $(call removeFiles,libraries/old-time/include/HsTimeConfig.h) - $(call removeTrees,utils/ghc-pwd/dist-boot) + +# The library configure scripts also like creating autom4te.cache +# directories, so clean them all up. + $(call removeTrees,$(patsubst %, libraries/%/autom4te.cache, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2))) + +# We make these when making or testing bindists + $(call removeFiles,bindist-list) + $(call removeTrees,bindisttest/a) + +# Not sure why this is being cleaned here. $(call removeTrees,includes/dist-derivedconstants) + +# Finally, clean the inplace tree. $(call removeTrees,inplace) - $(call removeTrees,$(patsubst %, libraries/%/autom4te.cache, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2))) maintainer-clean : distclean $(call removeFiles,configure mk/config.h.in) $(call removeTrees,autom4te.cache $(wildcard libraries/*/autom4te.cache)) - $(call removeFiles,ghc.spec) $(call removeFiles,$(patsubst %, libraries/%/GNUmakefile, \ $(PACKAGES_STAGE1) $(PACKAGES_STAGE2))) $(call removeFiles,$(patsubst %, libraries/%/ghc.mk, $(PACKAGES_STAGE1) $(PACKAGES_STAGE2))) @@ -1245,6 +1311,7 @@ maintainer-clean : distclean $(call removeFiles,libraries/directory/include/HsDirectoryConfig.h.in) $(call removeFiles,libraries/process/include/HsProcessConfig.h.in) $(call removeFiles,libraries/unix/include/HsUnixConfig.h.in) + $(call removeFiles,libraries/time/include/HsTimeConfig.h.in) $(call removeFiles,libraries/old-time/include/HsTimeConfig.h.in) .PHONY: all_libraries @@ -1284,13 +1351,26 @@ endif # ----------------------------------------------------------------------------- # Numbered phase targets +# In phase 1, we'll be building dependency files for most things +# built by the bootstrapping compiler while make is 'include'ing +# makefiles. But in order to build dependency files, we'll need to +# build any automatically generated .hs files, which means that +# we'll need to be able to build any tools that generate .hs files +# etc. But in order to do that, we need to already know the +# dependencies for those tools, so we build their dependency files +# here. .PHONY: phase_0_builds -phase_0_builds: $(utils/ghc-pkg_dist_depfile_haskell) -phase_0_builds: $(utils/ghc-pkg_dist_depfile_c_asm) +# hsc2hs is needed, e.g. to make the .hs files for hpc. phase_0_builds: $(utils/hsc2hs_dist_depfile_haskell) phase_0_builds: $(utils/hsc2hs_dist_depfile_c_asm) +# genprimopcode is needed to make the .hs-incl files that are in the +# ghc package. phase_0_builds: $(utils/genprimopcode_dist_depfile_haskell) phase_0_builds: $(utils/genprimopcode_dist_depfile_c_asm) +# deriveConstants is used to create header files included in the +# ghc package. +phase_0_builds: $(utils/deriveConstants_dist_depfile_haskell) +phase_0_builds: $(utils/deriveConstants_dist_depfile_c_asm) .PHONY: phase_1_builds phase_1_builds: $(PACKAGE_DATA_MKS) diff --git a/ghc.spec.in b/ghc.spec.in deleted file mode 100644 index 2a70043eea..0000000000 --- a/ghc.spec.in +++ /dev/null @@ -1,187 +0,0 @@ -# WARNING: ghc.spec is automatically generated from ghc.spec.in by -# ./configure. Make sure you are editing ghc.spec.in, not ghc.spec. -# -# RPM spec file for GHC -*-rpm-spec-*- -# -# Copyright [1998..2007] The GHC Team -# -# Thanks to Zoltan Vorosbaranyi <vbzoli@vbzo.li> for suggestions in -# earlier versions and Pixel <pixel@mandrakesoft.com> for coding tips. -# -# This file is subject to the same free software license as GHC. - -%define name ghc -%define version @ProjectVersion@ -%define release @release@ - -Name: %{name} -Version: %{version} -Release: %{release} -License: BSD-like -Group: Development/Languages/Haskell -URL: http://haskell.org/ghc/ -Source0: http://haskell.org/ghc/dist/%{version}/ghc-%{version}-src.tar.bz2 -Source1: http://haskell.org/ghc/dist/%{version}/ghc-%{version}-src-extralibs.tar.bz2 -Packager: Sven Panne <sven.panne@aedion.de> -BuildRoot: %{_tmppath}/%{name}-%{version}-build -PreReq: update-alternatives -Requires: gmp, readline -BuildRequires: update-alternatives, alex >= 2.0, happy >= 1.15, ghc >= 5, haddock, docbook-dtd, docbook-xsl-stylesheets, libxslt, libxml2, fop, xmltex, dvips, gmp, readline-devel, mesaglut-devel -Provides: haskell -Summary: The Glasgow Haskell Compiler - -%description -Haskell is the standard lazy purely functional programming language. -The current language version is Haskell 98, agreed in December 1998, -with a revised version published in January 2003. - -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, C++, whatever). - -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 at http://haskell.org/. - -Authors: --------- - Krasimir Angelov <ka2_mail@yahoo.com> - Manuel Chakravarty <chak@cse.unsw.edu.au> - Koen Claessen <koen@cs.chalmers.se> - Robert Ennals <Robert.Ennals@cl.cam.ac.uk> - Sigbjorn Finne <sof@galconn.com> - Gabrielle Keller <keller@cvs.haskell.org> - Marcin Kowalczyk <qrczak@knm.org.pl> - Jeff Lewis <jeff@galconn.com> - Ian Lynagh <igloo@earth.li> - Simon Marlow <simonmar@microsoft.com> - Sven Panne <sven.panne@aedion.de> - Ross Paterson <ross@soi.city.ac.uk> - Simon Peyton Jones <simonpj@microsoft.com> - Don Stewart <dons@cse.unsw.edu.au> - Volker Stolz <stolz@i2.informatik.rwth-aachen.de> - Wolfgang Thaller <wolfgang.thaller@gmx.net> - Andrew Tolmach <apt@cs.pdx.edu> - Keith Wansbrough <Keith.Wansbrough@cl.cam.ac.uk> - Michael Weber <michael.weber@post.rwth-aachen.de> - plus a dozen helping hands... - -%package prof -Requires: ghc = %{version}-%{release} -Summary: Profiling libraries for GHC -Group: Development/Libraries - -%description prof -Profiling libraries for Glorious Glasgow Haskell Compilation System -(GHC). They should be installed when GHC's profiling subsystem is -needed. - -%prep -%setup -b1 - -%build -test -f configure || perl boot -./configure --prefix=%{_prefix} --mandir=%{_mandir} - -# Don't install these tools, we'll use update-alternatives below. -touch mk/build.mk -echo "NO_INSTALL_RUNHASKELL=YES" >>mk/build.mk -echo "NO_INSTALL_HSC2HS=YES" >>mk/build.mk - -make %{?jobs:-j%jobs} -make html -# Alas, we don't pass make options/arguments down to "libraries", so let's redo make here... -make -C libraries HADDOCK_DOCS=YES -( cd libraries/Cabal && docbook2html doc/Cabal.xml --output doc/Cabal ) -make -C docs/ext-core ps -make -C docs/storage-mgt ps - -%install -# This is a cruel hack: There seems to be no way to install the Haddock -# documentation into the build directory, because DESTDIR is alway prepended. -# Furthermore, rpm removes the target documentation directory before the doc -# macros are processed. Therefore we have to copy things back into safety... :-P -# The right thing would be being able to install directly into the build tree. -make DESTDIR=${RPM_BUILD_ROOT} docdir=%{_datadir}/doc/packages/%{name} HADDOCK_DOCS=YES install install-docs -mkdir html-docs -cp -a ${RPM_BUILD_ROOT}%{_datadir}/doc/packages/%{name}/{index.html,libraries} html-docs -# Use version-less hsc2hs out of the way, we use update-alternatives. -mv ${RPM_BUILD_ROOT}%{_prefix}/bin/hsc2hs ${RPM_BUILD_ROOT}%{_prefix}/bin/hsc2hs-ghc - -# generate the file list for lib/ _excluding_ all files needed for profiling -# only -# -# * generating file lists in a BUILD_ROOT spec is a bit tricky: the file list -# has to contain complete paths, _but_ without the BUILD_ROOT, we also do -# _not_ want have directory names in the list; furthermore, we have to make -# sure that any leading / is removed from %{_prefix}/lib, as find has to -# interpret the argument as a relative path; however, we have to include the -# leading / again in the final file list (otherwise, rpm complains) -# * isn't there an easier way to do all this? -# -dir=`pwd` -cd ${RPM_BUILD_ROOT} -libdir=`echo %{_prefix}/lib | sed 's|^/||'` -find $libdir ! -type d ! -name '*.p_hi' ! -name '*_p.a' -print | sed 's|^|/|' > $dir/rpm-noprof-lib-files -find $libdir ! -type d \( -name '*.p_hi' -or -name '*_p.a' \) -print | sed 's|^|/|' > $dir/rpm-prof-lib-files -cd $dir - -%clean -rm -rf ${RPM_BUILD_ROOT} - -%post -# Alas, GHC, Hugs and nhc all come with different set of tools in addition to -# a runFOO: -# -# * GHC: hsc2hs -# * Hugs: hsc2hs, cpphs -# * nhc: cpphs -# -# Therefore it is currently not possible to use --slave below to form link -# groups under a single name 'runhaskell'. Either these tools should be -# disentangled from the Haskell implementations or all implementations should -# have the same set of tools. *sigh* -update-alternatives --install %{_bindir}/runhaskell runhaskell %{_bindir}/runghc 500 -update-alternatives --install %{_bindir}/hsc2hs hsc2hs %{_bindir}/hsc2hs-ghc 500 - -%preun -if test "$1" = 0; then - update-alternatives --remove runhaskell %{_bindir}/runghc - update-alternatives --remove hsc2hs %{_bindir}/hsc2hs-ghc -fi - -%files -f rpm-noprof-lib-files -%defattr(-,root,root) -%doc docs/docbook-cheat-sheet/docbook-cheat-sheet -%doc ANNOUNCE -%doc LICENSE -%doc README -%doc docs/comm -%doc docs/ext-core/core.ps -%doc docs/storage-mgt/ldv.ps -%doc docs/storage-mgt/rp.ps -%doc docs/storage-mgt/sm.ps -%doc docs/users_guide/users_guide -%doc libraries/Cabal/doc/Cabal -%doc html-docs/* -%{_mandir}/man1/ghc.1* -%{_prefix}/bin/ghc -%{_prefix}/bin/ghc-%{version} -%{_prefix}/bin/ghc-pkg -%{_prefix}/bin/ghc-pkg-%{version} -%{_prefix}/bin/ghci -%{_prefix}/bin/ghci-%{version} -%{_prefix}/bin/ghcprof -%{_prefix}/bin/hp2ps -%{_prefix}/bin/hpc -%{_prefix}/bin/hsc2hs-ghc -%{_prefix}/bin/hsc2hs-%{version} -%{_prefix}/bin/runghc - -%files prof -f rpm-prof-lib-files -%defattr(-,root,root) diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index e61e1409de..a3fe632493 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -64,7 +64,7 @@ data GHCiState = GHCiState progname :: String, args :: [String], prompt :: String, - def_prompt :: String, + prompt2 :: String, editor :: String, stop :: String, options :: [GHCiOption], diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 263babeafc..fd034eaf7d 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -90,6 +90,7 @@ import System.IO.Error import System.IO.Unsafe ( unsafePerformIO ) import System.Process import Text.Printf +import Text.Read ( readMaybe ) #ifndef mingw32_HOST_OS import System.Posix hiding ( getEnv ) @@ -109,7 +110,8 @@ data GhciSettings = GhciSettings { availableCommands :: [Command], shortHelpText :: String, fullHelpText :: String, - defPrompt :: String + defPrompt :: String, + defPrompt2 :: String } defaultGhciSettings :: GhciSettings @@ -118,7 +120,8 @@ defaultGhciSettings = availableCommands = ghciCommands, shortHelpText = defShortHelpText, fullHelpText = defFullHelpText, - defPrompt = default_prompt + defPrompt = default_prompt, + defPrompt2 = default_prompt2 } ghciWelcomeMsg :: String @@ -143,6 +146,7 @@ ghciCommands = [ ("cd", keepGoing' changeDirectory, completeFilename), ("check", keepGoing' checkModule, completeHomeModule), ("continue", keepGoing continueCmd, noCompletion), + ("complete", keepGoing completeCmd, noCompletion), ("cmd", keepGoing cmdCmd, completeExpression), ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename), ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename), @@ -230,6 +234,7 @@ defFullHelpText = " (!: more details; *: all top-level names)\n" ++ " :cd <dir> change directory to <dir>\n" ++ " :cmd <expr> run the commands returned by <expr>::IO String\n" ++ + " :complete <dom> [<rng>] <s> list completions for partial input string\n" ++ " :ctags[!] [<file>] create tags file for Vi (default: \"tags\")\n" ++ " (!: use regex instead of line number)\n" ++ " :def <cmd> <expr> define command :<cmd> (later defined command has\n" ++ @@ -285,6 +290,7 @@ defFullHelpText = " :set args <arg> ... set the arguments returned by System.getArgs\n" ++ " :set prog <progname> set the value returned by System.getProgName\n" ++ " :set prompt <prompt> set the prompt used in GHCi\n" ++ + " :set prompt2 <prompt> set the continuation prompt used in GHCi\n" ++ " :set editor <cmd> set the command used for :edit\n" ++ " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++ " :unset <option> ... unset options\n" ++ @@ -306,6 +312,7 @@ defFullHelpText = " :show breaks show the active breakpoints\n" ++ " :show context show the breakpoint context\n" ++ " :show imports show the current imports\n" ++ + " :show linker show current linker state\n" ++ " :show modules show the currently loaded modules\n" ++ " :show packages show the currently active package flags\n" ++ " :show language show the currently active language flags\n" ++ @@ -327,9 +334,10 @@ findEditor = do foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt -default_progname, default_prompt, default_stop :: String +default_progname, default_prompt, default_prompt2, default_stop :: String default_progname = "<interactive>" default_prompt = "%s> " +default_prompt2 = "%s| " default_stop = "" default_args :: [String] @@ -393,7 +401,7 @@ interactiveUI config srcs maybe_exprs = do GHCiState{ progname = default_progname, GhciMonad.args = default_args, prompt = defPrompt config, - def_prompt = defPrompt config, + prompt2 = defPrompt2 config, stop = default_stop, editor = default_editor, options = [], @@ -583,6 +591,11 @@ fileLoop hdl = do l <- liftIO $ tryIO $ hGetLine hdl case l of Left e | isEOFError e -> return Nothing + | -- as we share stdin with the program, the program + -- might have already closed it, so we might get a + -- handle-closed exception. We therefore catch that + -- too. + isIllegalOperation e -> return Nothing | InvalidArgument <- etype -> return Nothing | otherwise -> liftIO $ ioError e where etype = ioeGetErrorType e @@ -596,6 +609,7 @@ fileLoop hdl = do mkPrompt :: GHCi String mkPrompt = do + st <- getGHCiState imports <- GHC.getContext resumes <- GHC.getResumeContext @@ -626,12 +640,12 @@ mkPrompt = do deflt_prompt = dots <> context_bit <> modules_bit + f ('%':'l':xs) = ppr (1 + line_number st) <> f xs f ('%':'s':xs) = deflt_prompt <> f xs f ('%':'%':xs) = char '%' <> f xs f (x:xs) = char x <> f xs f [] = empty - st <- getGHCiState dflags <- getDynFlags return (showSDoc dflags (f (prompt st))) @@ -704,7 +718,7 @@ runOneCommand eh gCmd = do multiLineCmd q = do st <- lift getGHCiState let p = prompt st - lift $ setGHCiState st{ prompt = "%s| " } + lift $ setGHCiState st{ prompt = prompt2 st } mb_cmd <- collectCommand q "" lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p } return mb_cmd @@ -767,7 +781,7 @@ checkInputForLayout stmt getStmt = do _other -> do st1 <- lift getGHCiState let p = prompt st1 - lift $ setGHCiState st1{ prompt = "%s| " } + lift $ setGHCiState st1{ prompt = prompt2 st1 } mb_stmt <- ghciHandle (\ex -> case fromException ex of Just UserInterrupt -> return Nothing _ -> case fromException ex of @@ -1038,7 +1052,7 @@ filterOutChildren get_thing xs Nothing -> False pprInfo :: PrintExplicitForalls - -> (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst GHC.Branched]) -> SDoc + -> (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc pprInfo pefas (thing, fixity, cls_insts, fam_insts) = pprTyThingInContextLoc pefas thing $$ show_fixity @@ -1872,17 +1886,18 @@ setCmd "" = showOptions False setCmd "-a" = showOptions True setCmd str = case getCmd str of - Right ("args", rest) -> + Right ("args", rest) -> case toArgs rest of Left err -> liftIO (hPutStrLn stderr err) Right args -> setArgs args - Right ("prog", rest) -> + Right ("prog", rest) -> case toArgs rest of Right [prog] -> setProg prog _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>") - Right ("prompt", rest) -> setPrompt $ Just $ dropWhile isSpace rest - Right ("editor", rest) -> setEditor $ dropWhile isSpace rest - Right ("stop", rest) -> setStop $ dropWhile isSpace rest + Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest + Right ("prompt2", rest) -> setPrompt2 $ dropWhile isSpace rest + Right ("editor", rest) -> setEditor $ dropWhile isSpace rest + Right ("stop", rest) -> setStop $ dropWhile isSpace rest _ -> case toArgs str of Left err -> liftIO (hPutStrLn stderr err) Right wds -> setOptions wds @@ -1975,22 +1990,30 @@ setStop cmd = do st <- getGHCiState setGHCiState st{ stop = cmd } -setPrompt :: Maybe String -> GHCi () -setPrompt Nothing = do - st <- getGHCiState - setGHCiState ( st { prompt = def_prompt st } ) +setPrompt :: String -> GHCi () +setPrompt = setPrompt_ f err + where + f v st = st { prompt = v } + err st = "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\"" + +setPrompt2 :: String -> GHCi () +setPrompt2 = setPrompt_ f err + where + f v st = st { prompt2 = v } + err st = "syntax: :set prompt2 <prompt>, currently \"" ++ prompt2 st ++ "\"" -setPrompt (Just value) = do +setPrompt_ :: (String -> GHCiState -> GHCiState) -> (GHCiState -> String) -> String -> GHCi () +setPrompt_ f err value = do st <- getGHCiState if null value - then liftIO $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\"" + then liftIO $ hPutStrLn stderr $ err st else case value of '\"' : _ -> case reads value of [(value', xs)] | all isSpace xs -> - setGHCiState (st { prompt = value' }) + setGHCiState $ f value' st _ -> liftIO $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax." - _ -> setGHCiState (st { prompt = value }) + _ -> setGHCiState $ f value st setOptions wds = do -- first, deal with the GHCi opts (+s, +t, etc.) @@ -2054,11 +2077,12 @@ unsetOptions str (other_opts, rest3) = partition (`elem` map fst defaulters) rest2 defaulters = - [ ("args" , setArgs default_args) - , ("prog" , setProg default_progname) - , ("prompt", setPrompt Nothing) - , ("editor", liftIO findEditor >>= setEditor) - , ("stop" , setStop default_stop) + [ ("args" , setArgs default_args) + , ("prog" , setProg default_progname) + , ("prompt" , setPrompt default_prompt) + , ("prompt2", setPrompt2 default_prompt2) + , ("editor" , liftIO findEditor >>= setEditor) + , ("stop" , setStop default_stop) ] no_flag ('-':'f':rest) = return ("-fno-" ++ rest) @@ -2120,6 +2144,7 @@ showCmd str = do ["args"] -> liftIO $ putStrLn (show (GhciMonad.args st)) ["prog"] -> liftIO $ putStrLn (show (progname st)) ["prompt"] -> liftIO $ putStrLn (show (prompt st)) + ["prompt2"] -> liftIO $ putStrLn (show (prompt2 st)) ["editor"] -> liftIO $ putStrLn (show (editor st)) ["stop"] -> liftIO $ putStrLn (show (stop st)) ["imports"] -> showImports @@ -2134,8 +2159,8 @@ showCmd str = do ["languages"] -> showLanguages -- backwards compat ["language"] -> showLanguages ["lang"] -> showLanguages -- useful abbreviation - _ -> throwGhcException (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++ - " | breaks | context | packages | language ]")) + _ -> throwGhcException (CmdLineError ("syntax: :show [ args | prog | prompt | prompt2 | editor | stop | modules\n" ++ + " | bindings | breaks | context | packages | language ]")) showiCmd :: String -> GHCi () showiCmd str = do @@ -2195,7 +2220,7 @@ showBindings = do return $ maybe (text "") (pprTT pefas) mb_stuff pprTT :: PrintExplicitForalls - -> (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst GHC.Branched]) -> SDoc + -> (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc pprTT pefas (thing, fixity, _cls_insts, _fam_insts) = pprTyThing pefas thing $$ show_fixity @@ -2273,7 +2298,48 @@ showLanguages' show_all dflags = -- ----------------------------------------------------------------------------- -- Completion -completeCmd, completeMacro, completeIdentifier, completeModule, +completeCmd :: String -> GHCi () +completeCmd argLine0 = case parseLine argLine0 of + Just ("repl", resultRange, left) -> do + (unusedLine,compls) <- ghciCompleteWord (reverse left,"") + let compls' = takeRange resultRange compls + liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ] + forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do + liftIO $ print r + _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>") + where + parseLine argLine + | null argLine = Nothing + | null rest1 = Nothing + | otherwise = (,,) dom <$> resRange <*> s + where + (dom, rest1) = breakSpace argLine + (rng, rest2) = breakSpace rest1 + resRange | head rest1 == '"' = parseRange "" + | otherwise = parseRange rng + s | head rest1 == '"' = readMaybe rest1 :: Maybe String + | otherwise = readMaybe rest2 + breakSpace = fmap (dropWhile isSpace) . break isSpace + + takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub + + -- syntax: [n-][m] with semantics "drop (n-1) . take m" + parseRange :: String -> Maybe (Maybe Int,Maybe Int) + parseRange s = case span isDigit s of + (_, "") -> + -- upper limit only + Just (Nothing, bndRead s) + (s1, '-' : s2) + | all isDigit s2 -> + Just (bndRead s1, bndRead s2) + _ -> + Nothing + where + bndRead x = if null x then Nothing else Just (read x) + + + +completeGhciCommand, completeMacro, completeIdentifier, completeModule, completeSetModule, completeSeti, completeShowiOptions, completeHomeModule, completeSetOptions, completeShowOptions, completeHomeModuleOrFile, completeExpression @@ -2281,7 +2347,7 @@ completeCmd, completeMacro, completeIdentifier, completeModule, ghciCompleteWord :: CompletionFunc GHCi ghciCompleteWord line@(left,_) = case firstWord of - ':':cmd | null rest -> completeCmd line + ':':cmd | null rest -> completeGhciCommand line | otherwise -> do completion <- lookupCompletion cmd completion line @@ -2296,7 +2362,7 @@ ghciCompleteWord line@(left,_) = case firstWord of Just (_,_,f) -> return f Nothing -> return completeFilename -completeCmd = wrapCompleter " " $ \w -> do +completeGhciCommand = wrapCompleter " " $ \w -> do macros <- liftIO $ readIORef macros_ref cmds <- ghci_commands `fmap` getGHCiState let macro_names = map (':':) . map cmdName $ macros @@ -2346,7 +2412,7 @@ listHomeModules w = do completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do return (filter (w `isPrefixOf`) opts) - where opts = "args":"prog":"prompt":"editor":"stop":flagList + where opts = "args":"prog":"prompt":"prompt2":"editor":"stop":flagList flagList = map head $ group $ sort allFlags completeSeti = wrapCompleter flagWordBreakChars $ \w -> do @@ -2355,9 +2421,9 @@ completeSeti = wrapCompleter flagWordBreakChars $ \w -> do completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do return (filter (w `isPrefixOf`) opts) - where opts = ["args", "prog", "prompt", "editor", "stop", + where opts = ["args", "prog", "prompt", "prompt2", "editor", "stop", "modules", "bindings", "linker", "breaks", - "context", "packages", "language"] + "context", "packages", "language", "imports"] completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do return (filter (w `isPrefixOf`) ["language"]) @@ -2446,7 +2512,7 @@ enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" enclosingTickSpan md (RealSrcSpan src) = do ticks <- getTickArray md let line = srcSpanStartLine src - ASSERT (inRange (bounds ticks) line) do + ASSERT(inRange (bounds ticks) line) do let toRealSrcSpan (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" toRealSrcSpan (RealSrcSpan s) = s enclosing_spans = [ pan | (_,pan) <- ticks ! line @@ -2947,9 +3013,10 @@ showException se = -- in an exception loop (eg. let a = error a in a) the ^C exception -- may never be delivered. Thanks to Marcin for pointing out the bug. -ghciHandle :: ExceptionMonad m => (SomeException -> m a) -> m a -> m a -ghciHandle h m = gmask $ \restore -> - gcatch (restore m) $ \e -> restore (h e) +ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a +ghciHandle h m = gmask $ \restore -> do + dflags <- getDynFlags + gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e) ghciTry :: GHCi a -> GHCi (Either SomeException a) ghciTry (GHCi m) = GHCi $ \s -> gtry (m s) diff --git a/ghc/Main.hs b/ghc/Main.hs index 35dbf5bf2a..66db90a9f7 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -33,8 +33,7 @@ import Config import Constants import HscTypes import Packages ( dumpPackages ) -import DriverPhases ( Phase(..), isSourceFilename, anyHsc, - startPhase, isHaskellSrcFilename ) +import DriverPhases import BasicTypes ( failed ) import StaticFlags import DynFlags @@ -109,6 +108,7 @@ main = do ShowSupportedExtensions -> showSupportedExtensions ShowVersion -> showVersion ShowNumVersion -> putStrLn cProjectVersion + ShowOptions -> showOptions Right postStartupMode -> -- start our GHC session GHC.runGhc mbMinusB $ do @@ -159,8 +159,6 @@ main' postLoadMode dflags0 args flagWarnings = do dflags2 = dflags1{ ghcMode = mode, hscTarget = lang, ghcLink = link, - -- leave out hscOutName for now - hscOutName = panic "Main.main:hscOutName not set", verbosity = case postLoadMode of DoEval _ -> 0 _other -> 1 @@ -200,7 +198,8 @@ main' postLoadMode dflags0 args flagWarnings = do normal_fileish_paths = map (normalise . unLoc) fileish_args (srcs, objs) = partition_args normal_fileish_paths [] [] - dflags5 = dflags4 { ldInputs = objs ++ ldInputs dflags4 } + dflags5 = dflags4 { ldInputs = map (FileOption "") objs + ++ ldInputs dflags4 } -- we've finished manipulating the DynFlags, update the session _ <- GHC.setSessionDynFlags dflags5 @@ -372,11 +371,13 @@ data PreStartupMode = ShowVersion -- ghc -V/--version | ShowNumVersion -- ghc --numeric-version | ShowSupportedExtensions -- ghc --supported-extensions + | ShowOptions -- ghc --show-options -showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode +showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode showVersionMode = mkPreStartupMode ShowVersion showNumVersionMode = mkPreStartupMode ShowNumVersion showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions +showOptionsMode = mkPreStartupMode ShowOptions mkPreStartupMode :: PreStartupMode -> Mode mkPreStartupMode = Left @@ -520,6 +521,7 @@ mode_flags = , Flag "-version" (PassFlag (setMode showVersionMode)) , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode)) , Flag "-info" (PassFlag (setMode showInfoMode)) + , Flag "-show-options" (PassFlag (setMode showOptionsMode)) , Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode)) , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode)) ] ++ @@ -623,7 +625,7 @@ doMake srcs = do let (hs_srcs, non_hs_srcs) = partition haskellish srcs haskellish (f,Nothing) = - looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f + looksLikeModuleName f || isHaskellUserSrcFilename f || '.' `notElem` f haskellish (_,Just phase) = phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn] @@ -640,7 +642,8 @@ doMake srcs = do o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x) non_hs_srcs dflags <- GHC.getSessionDynFlags - let dflags' = dflags { ldInputs = o_files ++ ldInputs dflags } + let dflags' = dflags { ldInputs = map (FileOption "") o_files + ++ ldInputs dflags } _ <- GHC.setSessionDynFlags dflags' targets <- mapM (uncurry GHC.guessTarget) hs_srcs @@ -693,6 +696,21 @@ showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions showVersion :: IO () showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion) +showOptions :: IO () +showOptions = putStr (unlines availableOptions) + where + availableOptions = map ((:) '-') $ + getFlagNames mode_flags ++ + getFlagNames flagsDynamic ++ + (filterUnwantedStatic . getFlagNames $ flagsStatic) ++ + flagsStaticNames + getFlagNames opts = map getFlagName opts + getFlagName (Flag name _) = name + -- this is a hack to get rid of two unwanted entries that get listed + -- as static flags. Hopefully this hack will disappear one day together + -- with static flags + filterUnwantedStatic = filter (\x -> not (x `elem` ["f", "fno-"])) + showGhcUsage :: DynFlags -> IO () showGhcUsage = showUsage False diff --git a/includes/CodeGen.Platform.hs b/includes/CodeGen.Platform.hs index beff19601d..8007574b10 100644 --- a/includes/CodeGen.Platform.hs +++ b/includes/CodeGen.Platform.hs @@ -381,7 +381,7 @@ activeStgRegs = [ #ifdef REG_SpLim ,SpLim #endif -#if MAX_REAL_SSE_REG != 0 +#if MAX_REAL_XMM_REG != 0 #ifdef REG_F1 ,FloatReg 1 #endif @@ -436,7 +436,7 @@ activeStgRegs = [ #ifdef REG_XMM6 ,XmmReg 6 #endif -#else /* MAX_REAL_SSE_REG == 0 */ +#else /* MAX_REAL_XMM_REG == 0 */ #ifdef REG_F1 ,FloatReg 1 #endif @@ -473,7 +473,7 @@ activeStgRegs = [ #ifdef REG_D6 ,DoubleReg 6 #endif -#endif /* MAX_REAL_SSE_REG == 0 */ +#endif /* MAX_REAL_XMM_REG == 0 */ ] haveRegBase :: Bool @@ -587,7 +587,7 @@ globalRegMaybe (DoubleReg 6) = Just (RealRegSingle REG_D6) # endif # endif -#if MAX_REAL_SSE_REG != 0 +#if MAX_REAL_XMM_REG != 0 globalRegMaybe (XmmReg 1) = Just (RealRegSingle REG_XMM1) globalRegMaybe (XmmReg 2) = Just (RealRegSingle REG_XMM2) globalRegMaybe (XmmReg 3) = Just (RealRegSingle REG_XMM3) diff --git a/includes/Rts.h b/includes/Rts.h index bea4c47246..122637c465 100644 --- a/includes/Rts.h +++ b/includes/Rts.h @@ -203,6 +203,7 @@ INLINE_HEADER Time fsecondsToTime (double t) #include "rts/SpinLock.h" #include "rts/Messages.h" +#include "rts/Threads.h" /* Storage format definitions */ #include "rts/storage/FunTypes.h" @@ -230,7 +231,6 @@ INLINE_HEADER Time fsecondsToTime (double t) #include "rts/Globals.h" #include "rts/IOManager.h" #include "rts/Linker.h" -#include "rts/Threads.h" #include "rts/Ticky.h" #include "rts/Timer.h" #include "rts/Stable.h" diff --git a/includes/ghc.mk b/includes/ghc.mk index 6b92d20837..04cc4aae07 100644 --- a/includes/ghc.mk +++ b/includes/ghc.mk @@ -85,6 +85,11 @@ ifeq "$(CC_LLVM_BACKEND)" "1" @echo "#define llvm_CC_FLAVOR 1" >> $@ endif # +ifeq "$(CC_CLANG_BACKEND)" "1" + @echo >> $@ + @echo "#define clang_CC_FLAVOR 1" >> $@ +endif +# @echo "#endif /* __GHCAUTOCONF_H__ */" >> $@ @echo "Done." @@ -158,19 +163,19 @@ ifneq "$(BINDIST)" "YES" $(includes_DERIVEDCONSTANTS): $$(includes_H_CONFIG) $$(includes_H_PLATFORM) $$(includes_H_FILES) $$(rts_H_FILES) $(includes_GHCCONSTANTS_HASKELL_VALUE): $$(includes_H_CONFIG) $$(includes_H_PLATFORM) $$(includes_H_FILES) $$(rts_H_FILES) -$(includes_DERIVEDCONSTANTS): $(INPLACE_BIN)/deriveConstants$(exeext) | $$(dir $$@)/. +$(includes_DERIVEDCONSTANTS): $(deriveConstants_INPLACE) | $$(dir $$@)/. $< --gen-header -o $@ --tmpdir $(dir $@) $(DERIVE_CONSTANTS_FLAGS) -$(includes_GHCCONSTANTS_HASKELL_TYPE): $(INPLACE_BIN)/deriveConstants$(exeext) | $$(dir $$@)/. +$(includes_GHCCONSTANTS_HASKELL_TYPE): $(deriveConstants_INPLACE) | $$(dir $$@)/. $< --gen-haskell-type -o $@ --tmpdir $(dir $@) $(DERIVE_CONSTANTS_FLAGS) -$(includes_GHCCONSTANTS_HASKELL_VALUE): $(INPLACE_BIN)/deriveConstants$(exeext) | $$(dir $$@)/. +$(includes_GHCCONSTANTS_HASKELL_VALUE): $(deriveConstants_INPLACE) | $$(dir $$@)/. $< --gen-haskell-value -o $@ --tmpdir $(dir $@) $(DERIVE_CONSTANTS_FLAGS) -$(includes_GHCCONSTANTS_HASKELL_WRAPPERS): $(INPLACE_BIN)/deriveConstants$(exeext) | $$(dir $$@)/. +$(includes_GHCCONSTANTS_HASKELL_WRAPPERS): $(deriveConstants_INPLACE) | $$(dir $$@)/. $< --gen-haskell-wrappers -o $@ --tmpdir $(dir $@) $(DERIVE_CONSTANTS_FLAGS) -$(includes_GHCCONSTANTS_HASKELL_EXPORTS): $(INPLACE_BIN)/deriveConstants$(exeext) | $$(dir $$@)/. +$(includes_GHCCONSTANTS_HASKELL_EXPORTS): $(deriveConstants_INPLACE) | $$(dir $$@)/. $< --gen-haskell-exports -o $@ --tmpdir $(dir $@) $(DERIVE_CONSTANTS_FLAGS) endif @@ -180,7 +185,7 @@ endif $(eval $(call clean-target,includes,,\ $(includes_H_CONFIG) $(includes_H_PLATFORM))) -$(eval $(call all-target,includes,,\ +$(eval $(call all-target,includes,\ $(includes_H_CONFIG) $(includes_H_PLATFORM) \ $(includes_GHCCONSTANTS_HASKELL_TYPE) \ $(includes_GHCCONSTANTS_HASKELL_VALUE) \ diff --git a/includes/rts/Constants.h b/includes/rts/Constants.h index 5ff4d4e51e..494abe2b22 100644 --- a/includes/rts/Constants.h +++ b/includes/rts/Constants.h @@ -84,7 +84,7 @@ #define MAX_FLOAT_REG 6 #define MAX_DOUBLE_REG 6 #define MAX_LONG_REG 1 -#define MAX_SSE_REG 6 +#define MAX_XMM_REG 6 /* ----------------------------------------------------------------------------- Semi-Tagging constants @@ -202,31 +202,32 @@ */ #define NotBlocked 0 #define BlockedOnMVar 1 -#define BlockedOnBlackHole 2 -#define BlockedOnRead 3 -#define BlockedOnWrite 4 -#define BlockedOnDelay 5 -#define BlockedOnSTM 6 +#define BlockedOnMVarRead 2 +#define BlockedOnBlackHole 3 +#define BlockedOnRead 4 +#define BlockedOnWrite 5 +#define BlockedOnDelay 6 +#define BlockedOnSTM 7 /* Win32 only: */ -#define BlockedOnDoProc 7 +#define BlockedOnDoProc 8 /* Only relevant for PAR: */ /* blocked on a remote closure represented by a Global Address: */ -#define BlockedOnGA 8 +#define BlockedOnGA 9 /* same as above but without sending a Fetch message */ -#define BlockedOnGA_NoSend 9 +#define BlockedOnGA_NoSend 10 /* Only relevant for THREADED_RTS: */ -#define BlockedOnCCall 10 -#define BlockedOnCCall_Interruptible 11 +#define BlockedOnCCall 11 +#define BlockedOnCCall_Interruptible 12 /* same as above but permit killing the worker thread */ /* Involved in a message sent to tso->msg_cap */ -#define BlockedOnMsgThrowTo 12 +#define BlockedOnMsgThrowTo 13 /* The thread is not on any run queues, but can be woken up by tryWakeupThread() */ -#define ThreadMigrating 13 +#define ThreadMigrating 14 /* * These constants are returned to the scheduler by a thread that has diff --git a/includes/rts/Globals.h b/includes/rts/Globals.h index 720d9674cc..d0d34ef981 100644 --- a/includes/rts/Globals.h +++ b/includes/rts/Globals.h @@ -25,5 +25,6 @@ StgStablePtr getOrSetSystemEventThreadEventManagerStore(StgStablePtr ptr); StgStablePtr getOrSetSystemEventThreadIOManagerThreadStore(StgStablePtr ptr); StgStablePtr getOrSetSystemTimerThreadEventManagerStore(StgStablePtr ptr); StgStablePtr getOrSetSystemTimerThreadIOManagerThreadStore(StgStablePtr ptr); +StgStablePtr getOrSetLibHSghcFastStringTable(StgStablePtr ptr); #endif /* RTS_GLOBALS_H */ diff --git a/includes/rts/PrimFloat.h b/includes/rts/PrimFloat.h index 7d137a7b6c..96a7d25df3 100644 --- a/includes/rts/PrimFloat.h +++ b/includes/rts/PrimFloat.h @@ -14,5 +14,7 @@ StgDouble __int_encodeDouble (I_ j, I_ e); StgFloat __int_encodeFloat (I_ j, I_ e); +StgDouble __word_encodeDouble (W_ j, I_ e); +StgFloat __word_encodeFloat (W_ j, I_ e); #endif /* RTS_PRIMFLOAT_H */ diff --git a/includes/rts/Utils.h b/includes/rts/Utils.h index 1cb52ae83f..119ec5b6a0 100644 --- a/includes/rts/Utils.h +++ b/includes/rts/Utils.h @@ -13,11 +13,6 @@ #ifndef RTS_UTILS_H #define RTS_UTILS_H -// Used in GHC (basicTypes/Unique.lhs, and Data.Unique in the base -// package. -HsInt genSymZh(void); -HsInt resetGenSymZh(void); - /* Alternate to raise(3) for threaded rts, for BSD-based OSes */ int genericRaise(int sig); diff --git a/includes/rts/storage/Closures.h b/includes/rts/storage/Closures.h index 2302b7d2a1..09e702149a 100644 --- a/includes/rts/storage/Closures.h +++ b/includes/rts/storage/Closures.h @@ -80,7 +80,7 @@ typedef struct { typedef struct StgClosure_ { StgHeader header; struct StgClosure_ *payload[FLEXIBLE_ARRAY]; -} *StgClosurePtr; // StgClosure defined in Rts.h +} *StgClosurePtr; // StgClosure defined in rts/Types.h typedef struct { StgThunkHeader header; @@ -191,17 +191,21 @@ typedef struct _StgStableName { typedef struct _StgWeak { /* Weak v */ StgHeader header; - StgClosure *cfinalizer; + StgClosure *cfinalizers; StgClosure *key; StgClosure *value; /* v */ StgClosure *finalizer; struct _StgWeak *link; } StgWeak; -typedef struct _StgDeadWeak { /* Weak v */ +typedef struct _StgCFinalizerList { StgHeader header; - struct _StgWeak *link; -} StgDeadWeak; + StgClosure *link; + void (*fptr)(void); + void *ptr; + void *eptr; + StgWord flag; /* has environment (0 or 1) */ +} StgCFinalizerList; /* Byte code objects. These are fixed size objects with pointers to * four arrays, designed so that a BCO can be easily "re-linked" to diff --git a/includes/rts/storage/GC.h b/includes/rts/storage/GC.h index 80f11d3ee1..fb5e21e832 100644 --- a/includes/rts/storage/GC.h +++ b/includes/rts/storage/GC.h @@ -83,6 +83,8 @@ typedef struct generation_ { StgTSO * threads; // threads in this gen // linked via global_link + StgWeak * weak_ptr_list; // weak pointers in this gen + struct generation_ *to; // destination gen for live objects // stats information @@ -116,6 +118,7 @@ typedef struct generation_ { bdescr * bitmap; // bitmap for compacting collection StgTSO * old_threads; + StgWeak * old_weak_ptr_list; } generation; extern generation * generations; @@ -154,8 +157,11 @@ StgPtr allocate ( Capability *cap, W_ n ); StgPtr allocatePinned ( Capability *cap, W_ n ); /* memory allocator for executable memory */ -void * allocateExec(W_ len, void **exec_addr); -void freeExec (void *p); +typedef void* AdjustorWritable; +typedef void* AdjustorExecutable; + +AdjustorWritable allocateExec(W_ len, AdjustorExecutable *exec_addr); +void freeExec (AdjustorExecutable p); // Used by GC checks in external .cmm code: extern W_ large_alloc_lim; diff --git a/includes/rts/storage/SMPClosureOps.h b/includes/rts/storage/SMPClosureOps.h index 39349874f7..a8ebb5d0ed 100644 --- a/includes/rts/storage/SMPClosureOps.h +++ b/includes/rts/storage/SMPClosureOps.h @@ -11,13 +11,27 @@ #ifdef CMINUSMINUS +/* Lock closure, equivalent to ccall lockClosure but the condition is inlined. + * Arguments are swapped for uniformity with unlockClosure. */ +#if defined(THREADED_RTS) +#define LOCK_CLOSURE(closure, info) \ + if (CInt[n_capabilities] == 1 :: CInt) { \ + info = GET_INFO(closure); \ + } else { \ + ("ptr" info) = ccall reallyLockClosure(closure "ptr"); \ + } +#else +#define LOCK_CLOSURE(closure, info) info = GET_INFO(closure) +#endif + #define unlockClosure(ptr,info) \ prim_write_barrier; \ - StgHeader_info(ptr) = info; + StgHeader_info(ptr) = info; #else -EXTERN_INLINE StgInfoTable *lockClosure(StgClosure *p); +INLINE_HEADER StgInfoTable *lockClosure(StgClosure *p); +EXTERN_INLINE StgInfoTable *reallyLockClosure(StgClosure *p); EXTERN_INLINE StgInfoTable *tryLockClosure(StgClosure *p); EXTERN_INLINE void unlockClosure(StgClosure *p, const StgInfoTable *info); @@ -29,35 +43,58 @@ EXTERN_INLINE void unlockClosure(StgClosure *p, const StgInfoTable *info); * This is used primarily in the implementation of MVars. * -------------------------------------------------------------------------- */ -// We want a callable copy of lockClosure() so that we can refer to it -// from .cmm files compiled using the native codegen. -EXTERN_INLINE StgInfoTable *lockClosure(StgClosure *p) +// We want a callable copy of reallyLockClosure() so that we can refer to it +// from .cmm files compiled using the native codegen, so these are given +// EXTERN_INLINE. C-- should use LOCK_CLOSURE not lockClosure, so we've +// kept it INLINE_HEADER. +EXTERN_INLINE StgInfoTable *reallyLockClosure(StgClosure *p) { StgWord info; do { - nat i = 0; - do { - info = xchg((P_)(void *)&p->header.info, (W_)&stg_WHITEHOLE_info); - if (info != (W_)&stg_WHITEHOLE_info) return (StgInfoTable *)info; - } while (++i < SPIN_COUNT); - yieldThread(); + nat i = 0; + do { + info = xchg((P_)(void *)&p->header.info, (W_)&stg_WHITEHOLE_info); + if (info != (W_)&stg_WHITEHOLE_info) return (StgInfoTable *)info; + } while (++i < SPIN_COUNT); + yieldThread(); } while (1); } +INLINE_HEADER StgInfoTable *lockClosure(StgClosure *p) +{ + if (n_capabilities == 1) { + return (StgInfoTable *)p->header.info; + } + else { + return reallyLockClosure(p); + } +} + +// ToDo: consider splitting tryLockClosure into reallyTryLockClosure, +// same as lockClosure EXTERN_INLINE StgInfoTable *tryLockClosure(StgClosure *p) { StgWord info; - info = xchg((P_)(void *)&p->header.info, (W_)&stg_WHITEHOLE_info); - if (info != (W_)&stg_WHITEHOLE_info) { - return (StgInfoTable *)info; - } else { - return NULL; + if (n_capabilities == 1) { + return (StgInfoTable *)p->header.info; + } + else { + info = xchg((P_)(void *)&p->header.info, (W_)&stg_WHITEHOLE_info); + if (info != (W_)&stg_WHITEHOLE_info) { + return (StgInfoTable *)info; + } else { + return NULL; + } } } #else /* !THREADED_RTS */ EXTERN_INLINE StgInfoTable * +reallyLockClosure(StgClosure *p) +{ return (StgInfoTable *)p->header.info; } + +INLINE_HEADER StgInfoTable * lockClosure(StgClosure *p) { return (StgInfoTable *)p->header.info; } @@ -75,12 +112,12 @@ EXTERN_INLINE void unlockClosure(StgClosure *p, const StgInfoTable *info) } // Handy specialised versions of lockClosure()/unlockClosure() -EXTERN_INLINE void lockTSO(StgTSO *tso); -EXTERN_INLINE void lockTSO(StgTSO *tso) +INLINE_HEADER void lockTSO(StgTSO *tso); +INLINE_HEADER void lockTSO(StgTSO *tso) { lockClosure((StgClosure *)tso); } -EXTERN_INLINE void unlockTSO(StgTSO *tso); -EXTERN_INLINE void unlockTSO(StgTSO *tso) +INLINE_HEADER void unlockTSO(StgTSO *tso); +INLINE_HEADER void unlockTSO(StgTSO *tso) { unlockClosure((StgClosure*)tso, (const StgInfoTable *)&stg_TSO_info); } #endif /* CMINUSMINUS */ diff --git a/includes/stg/MachRegs.h b/includes/stg/MachRegs.h index 76bdb1fc21..a8f2215578 100644 --- a/includes/stg/MachRegs.h +++ b/includes/stg/MachRegs.h @@ -107,7 +107,7 @@ #define MAX_REAL_FLOAT_REG 0 #define MAX_REAL_DOUBLE_REG 0 #define MAX_REAL_LONG_REG 0 -#define MAX_REAL_SSE_REG 0 +#define MAX_REAL_XMM_REG 0 /* ----------------------------------------------------------------------------- The x86-64 register mapping @@ -212,7 +212,7 @@ #define MAX_REAL_FLOAT_REG 6 #define MAX_REAL_DOUBLE_REG 6 #define MAX_REAL_LONG_REG 0 -#define MAX_REAL_SSE_REG 6 +#define MAX_REAL_XMM_REG 6 /* ----------------------------------------------------------------------------- The PowerPC register mapping @@ -565,21 +565,21 @@ # endif #endif -#ifndef MAX_REAL_SSE_REG -# if defined(REG_SSE6) -# define MAX_REAL_SSE_REG 6 -# elif defined(REG_SSE5) -# define MAX_REAL_SSE_REG 5 -# elif defined(REG_SSE4) -# define MAX_REAL_SSE_REG 4 -# elif defined(REG_SSE3) -# define MAX_REAL_SSE_REG 3 -# elif defined(REG_SSE2) -# define MAX_REAL_SSE_REG 2 -# elif defined(REG_SSE1) -# define MAX_REAL_SSE_REG 1 +#ifndef MAX_REAL_XMM_REG +# if defined(REG_XMM6) +# define MAX_REAL_XMM_REG 6 +# elif defined(REG_XMM5) +# define MAX_REAL_XMM_REG 5 +# elif defined(REG_XMM4) +# define MAX_REAL_XMM_REG 4 +# elif defined(REG_XMM3) +# define MAX_REAL_XMM_REG 3 +# elif defined(REG_XMM2) +# define MAX_REAL_XMM_REG 2 +# elif defined(REG_XMM1) +# define MAX_REAL_XMM_REG 1 # else -# define MAX_REAL_SSE_REG 0 +# define MAX_REAL_XMM_REG 0 # endif #endif diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h index b9b4f2304f..b0ed03b814 100644 --- a/includes/stg/MiscClosures.h +++ b/includes/stg/MiscClosures.h @@ -98,6 +98,7 @@ RTS_FUN(stg_BCO); RTS_ENTRY(stg_EVACUATED); RTS_ENTRY(stg_WEAK); RTS_ENTRY(stg_DEAD_WEAK); +RTS_ENTRY(stg_C_FINALIZER_LIST); RTS_ENTRY(stg_STABLE_NAME); RTS_ENTRY(stg_MVAR_CLEAN); RTS_ENTRY(stg_MVAR_DIRTY); @@ -292,7 +293,9 @@ RTS_FUN_DECL(stg_block_noregs); RTS_FUN_DECL(stg_block_blackhole); RTS_FUN_DECL(stg_block_blackhole_finally); RTS_FUN_DECL(stg_block_takemvar); +RTS_FUN_DECL(stg_block_readmvar); RTS_RET(stg_block_takemvar); +RTS_RET(stg_block_readmvar); RTS_FUN_DECL(stg_block_putmvar); RTS_RET(stg_block_putmvar); #ifdef mingw32_HOST_OS @@ -375,8 +378,10 @@ RTS_FUN_DECL(stg_isEmptyMVarzh); RTS_FUN_DECL(stg_newMVarzh); RTS_FUN_DECL(stg_takeMVarzh); RTS_FUN_DECL(stg_putMVarzh); +RTS_FUN_DECL(stg_readMVarzh); RTS_FUN_DECL(stg_tryTakeMVarzh); RTS_FUN_DECL(stg_tryPutMVarzh); +RTS_FUN_DECL(stg_tryReadMVarzh); RTS_FUN_DECL(stg_waitReadzh); RTS_FUN_DECL(stg_waitWritezh); @@ -412,7 +417,7 @@ RTS_FUN_DECL(stg_threadStatuszh); RTS_FUN_DECL(stg_mkWeakzh); RTS_FUN_DECL(stg_mkWeakNoFinalizzerzh); RTS_FUN_DECL(stg_mkWeakForeignzh); -RTS_FUN_DECL(stg_mkWeakForeignEnvzh); +RTS_FUN_DECL(stg_addCFinalizzerToWeakzh); RTS_FUN_DECL(stg_finalizzeWeakzh); RTS_FUN_DECL(stg_deRefWeakzh); @@ -465,7 +470,6 @@ extern StgWord stg_stack_save_entries[]; // Storage.c extern unsigned int RTS_VAR(g0); extern unsigned int RTS_VAR(large_alloc_lim); -extern StgWord RTS_VAR(weak_ptr_list); extern StgWord RTS_VAR(atomic_modify_mutvar_mutex); // RtsFlags @@ -484,6 +488,9 @@ extern StgWord CCS_SYSTEM[]; extern unsigned int RTS_VAR(CC_ID); /* global ids */ extern unsigned int RTS_VAR(CCS_ID); +// Capability.c +extern unsigned int n_capabilities; + #endif #endif /* STGMISCCLOSURES_H */ diff --git a/includes/stg/SMP.h b/includes/stg/SMP.h index bfd6bbcfab..99c25fe355 100644 --- a/includes/stg/SMP.h +++ b/includes/stg/SMP.h @@ -365,9 +365,12 @@ load_load_barrier(void) { /* ---------------------------------------------------------------------- */ #else /* !THREADED_RTS */ -#define write_barrier() /* nothing */ -#define store_load_barrier() /* nothing */ -#define load_load_barrier() /* nothing */ +EXTERN_INLINE void write_barrier(void); +EXTERN_INLINE void store_load_barrier(void); +EXTERN_INLINE void load_load_barrier(void); +EXTERN_INLINE void write_barrier () {} /* nothing */ +EXTERN_INLINE void store_load_barrier() {} /* nothing */ +EXTERN_INLINE void load_load_barrier () {} /* nothing */ #if !IN_STG_CODE || IN_STGCRUN INLINE_HEADER StgWord diff --git a/includes/stg/Ticky.h b/includes/stg/Ticky.h index 182c99654f..6f92a7f864 100644 --- a/includes/stg/Ticky.h +++ b/includes/stg/Ticky.h @@ -46,8 +46,10 @@ extern W_ top_ct[]; #endif EXTERN StgInt ENT_VIA_NODE_ctr INIT(0); -EXTERN StgInt ENT_STATIC_THK_ctr INIT(0); -EXTERN StgInt ENT_DYN_THK_ctr INIT(0); +EXTERN StgInt ENT_STATIC_THK_SINGLE_ctr INIT(0); +EXTERN StgInt ENT_DYN_THK_SINGLE_ctr INIT(0); +EXTERN StgInt ENT_STATIC_THK_MANY_ctr INIT(0); +EXTERN StgInt ENT_DYN_THK_MANY_ctr INIT(0); EXTERN StgInt ENT_STATIC_FUN_DIRECT_ctr INIT(0); EXTERN StgInt ENT_DYN_FUN_DIRECT_ctr INIT(0); EXTERN StgInt ENT_STATIC_CON_ctr INIT(0); @@ -128,7 +130,6 @@ EXTERN StgInt UPD_OLD_IND_ctr INIT(0); EXTERN StgInt UPD_OLD_PERM_IND_ctr INIT(0); EXTERN StgInt UPD_BH_UPDATABLE_ctr INIT(0); -EXTERN StgInt UPD_BH_SINGLE_ENTRY_ctr INIT(0); EXTERN StgInt UPD_CAF_BH_UPDATABLE_ctr INIT(0); EXTERN StgInt UPD_CAF_BH_SINGLE_ENTRY_ctr INIT(0); diff --git a/libffi/ghc.mk b/libffi/ghc.mk index 07d6d3d74c..2e333df6e9 100644 --- a/libffi/ghc.mk +++ b/libffi/ghc.mk @@ -35,8 +35,12 @@ libffi_STATIC_LIB = libffi/build/inst/lib/libffi.a libffi_HEADERS = rts/dist/build/ffi.h \ rts/dist/build/ffitarget.h -LIBFFI_WINDOWS_LIB = ffi-6 -LIBFFI_DLL = lib$(LIBFFI_WINDOWS_LIB).dll +ifeq "$(HostOS_CPP)" "mingw32" +LIBFFI_NAME = ffi-6 +else +LIBFFI_NAME = ffi +endif +LIBFFI_DLL = lib$(LIBFFI_NAME).dll ifeq "$(OSTYPE)" "cygwin" LIBFFI_PATH_MANGLE = PATH=$$(cygpath "$(TOP)")/libffi:$$PATH; export PATH; @@ -51,7 +55,7 @@ $(libffi_STAMP_CONFIGURE): $(TOUCH_DEP) $(call removeFiles,$(libffi_STAMP_STATIC_SHARED_BUILD)) $(call removeFiles,$(libffi_STAMP_STATIC_SHARED_INSTALL)) $(call removeTrees,$(LIBFFI_DIR) libffi/build) - cat ghc-tarballs/libffi/libffi*.tar.gz | $(GZIP_CMD) -d | { cd libffi && $(TAR_CMD) -xf - ; } + cat libffi-tarballs/libffi*.tar.gz | $(GZIP_CMD) -d | { cd libffi && $(TAR_CMD) -xf - ; } mv libffi/libffi-* libffi/build # We have to fake a non-working ln for configure, so that the fallback @@ -82,9 +86,10 @@ $(libffi_STAMP_CONFIGURE): $(TOUCH_DEP) LD=$(LD) \ AR=$(AR_STAGE1) \ NM=$(NM) \ + RANLIB=$(REAL_RANLIB_CMD) \ CFLAGS="$(SRC_CC_OPTS) $(CONF_CC_OPTS_STAGE1) -w" \ LDFLAGS="$(SRC_LD_OPTS) $(CONF_GCC_LINKER_OPTS_STAGE1) -w" \ - "$(SHELL)" configure \ + "$(SHELL)" ./configure \ --prefix=$(TOP)/libffi/build/inst \ --libdir=$(TOP)/libffi/build/inst/lib \ --enable-static=yes \ diff --git a/libraries/Cabal b/libraries/Cabal -Subproject 14c5a3f78c00772cf54c2fd5c920a64d53e6f59 +Subproject 5fa5c41cd9d2c9b4b543312af6919fe3d858865 diff --git a/libraries/Win32 b/libraries/Win32 -Subproject 1f9f7175e747aad7c424f5b12be5b95f15286f0 +Subproject 3da00d80f2fd7d1032e3530e1af1b39fba79aac diff --git a/libraries/haskeline b/libraries/haskeline -Subproject 3a92ddd63d4edc622ad4af044c5b664aa64c3dd +Subproject 40bcd6ac30577d1d240166674d1e328ac52c1fd diff --git a/libraries/primitive b/libraries/primitive -Subproject 75c3379b6d76e914cc3c7ffd290b6b1cad7ea3e +Subproject c6b1e204f0f2a1a0d6cb1df35fa60762b2fe3cd diff --git a/mk/build.mk.sample b/mk/build.mk.sample index e1355cd150..1b05ddee6a 100644 --- a/mk/build.mk.sample +++ b/mk/build.mk.sample @@ -5,6 +5,7 @@ # overall build type, and then tweak the options in the relevant section # below. +# -------- Build profiles ----------------------------------------------------- # Uncomment one of these to select a build profile below: # Full build with max optimisation and everything enabled (very slow build) @@ -33,13 +34,24 @@ # A development build, working on the stage 2 compiler: #BuildFlavour = devel2 -GhcLibWays = $(if $(filter $(DYNAMIC_GHC_PROGRAMS),YES),v dyn,v) +# -------- Miscellaneous variables -------------------------------------------- -# Uncomment this to get prettier build output. +# Set to V = 0 to get prettier build output. # Please use V = 1 when reporting GHC bugs. -# V = 0 +V = 1 + +# After stage 1 and the libraries have been built, you can uncomment this line: + +#stage=2 + +# Then stage 1 will not be touched by the build system, until +# you comment the line again. This is a useful trick for when you're +# working on stage 2 and want to freeze stage 1 and the libraries for +# a while. -# -------- 1. A Performance/Distribution build-------------------------------- +GhcLibWays = $(if $(filter $(DYNAMIC_GHC_PROGRAMS),YES),v dyn,v) + +# ----------- A Performance/Distribution build -------------------------------- ifeq "$(BuildFlavour)" "perf" @@ -58,7 +70,7 @@ endif endif -# ---------------- Perf build using LLVM ------------------------------------- +# ---------------- Perf build using LLVM -------------------------------------- ifeq "$(BuildFlavour)" "perf-llvm" @@ -69,13 +81,12 @@ GhcHcOpts = -Rghc-timing GhcLibHcOpts = -O2 GhcLibWays += p -ifeq "$(PlatformSupportsSharedLibs)" "YES" -GhcLibWays += dyn -endif +DYNAMIC_BY_DEFAULT = NO +DYNAMIC_GHC_PROGRAMS = NO endif -# -------- A Fast build ------------------------------------------------------ +# -------- A Fast build ------------------------------------------------------- ifeq "$(BuildFlavour)" "quickest" @@ -91,7 +102,7 @@ BUILD_DOCBOOK_PDF = NO endif -# -------- A Fast build with optimised libs ---------------------------------- +# -------- A Fast build with optimised libs ----------------------------------- ifeq "$(BuildFlavour)" "quick" @@ -107,7 +118,7 @@ BUILD_DOCBOOK_PDF = NO endif -# -------- A Fast build with optimised libs using LLVM ----------------------- +# -------- A Fast build with optimised libs using LLVM ------------------------ ifeq "$(BuildFlavour)" "quick-llvm" @@ -121,9 +132,12 @@ BUILD_DOCBOOK_HTML = NO BUILD_DOCBOOK_PS = NO BUILD_DOCBOOK_PDF = NO +DYNAMIC_BY_DEFAULT = NO +DYNAMIC_GHC_PROGRAMS = NO + endif -# -------- Profile the stage2 compiler --------------------------------------- +# -------- Profile the stage2 compiler ---------------------------------------- ifeq "$(BuildFlavour)" "prof" @@ -143,8 +157,7 @@ BUILD_DOCBOOK_PDF = NO endif - -# -------- A Development build (stage 1) ------------------------------------- +# -------- A Development build (stage 1) -------------------------------------- ifeq "$(BuildFlavour)" "devel1" @@ -161,7 +174,7 @@ LAX_DEPENDENCIES = YES endif -# -------- A Development build (stage 2) ------------------------------------- +# -------- A Development build (stage 2) -------------------------------------- ifeq "$(BuildFlavour)" "devel2" @@ -176,15 +189,6 @@ BUILD_DOCBOOK_PS = NO BUILD_DOCBOOK_PDF = NO LAX_DEPENDENCIES = YES -# After stage 1 and the libraries have been built, you can uncomment this line: - -# stage=2 - -# Then stage 1 will not be touched by the build system, until -# you comment the line again. This is a useful trick for when you're -# working on stage 2 and want to freeze stage 1 and the libraries for -# a while. - endif # ----------------------------------------------------------------------------- diff --git a/mk/config.mk.in b/mk/config.mk.in index 275c21a803..1129cc2e41 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -95,7 +95,7 @@ TargetElf = YES endif # Some platforms don't support shared libraries -NoSharedLibsPlatformList = +NoSharedLibsPlatformList = arm-unknown-linux powerpc-unknown-linux ifeq "$(SOLARIS_BROKEN_SHLD)" "YES" NoSharedLibsPlatformList += i386-unknown-solaris2 @@ -134,6 +134,12 @@ DYNAMIC_TOO = YES ifeq "$(TargetOS_CPP)" "mingw32" # This doesn't work on Windows yet DYNAMIC_GHC_PROGRAMS = NO +else ifeq "$(TargetOS_CPP)" "freebsd" +# FreeBSD cannot do proper resolution for $ORIGIN (due to a bug in +# rtld(1)), so disable it by default (see #7819). +DYNAMIC_GHC_PROGRAMS = NO +else ifeq "$(PlatformSupportsSharedLibs)" "NO" +DYNAMIC_GHC_PROGRAMS = NO else DYNAMIC_GHC_PROGRAMS = YES endif @@ -383,10 +389,6 @@ BIN_DIST_PREP_DIR = bindistprep/$(BIN_DIST_NAME) BIN_DIST_PREP_TAR = bindistprep/$(BIN_DIST_NAME)-$(TARGETPLATFORM).tar BIN_DIST_PREP_TAR_BZ2 = $(BIN_DIST_PREP_TAR).bz2 BIN_DIST_TAR_BZ2 = $(BIN_DIST_NAME)-$(TARGETPLATFORM).tar.bz2 -BIN_DIST_LIST = bindist-list - -WINDOWS_INSTALLER_BASE = ghc-$(ProjectVersion)-$(TargetArch_CPP)-windows -WINDOWS_INSTALLER = $(WINDOWS_INSTALLER_BASE)$(exeext) # ----------------------------------------------------------------------------- # Utilities programs: flags @@ -444,16 +446,10 @@ ifneq "$(wildcard $(GHC).exe)" "" GHC := $(GHC).exe endif -# Sometimes we want to invoke ghc from the build tree in different -# places (eg. it's handy to have a nofib & a ghc build in the same -# tree). We can refer to "this ghc" as $(GHC_INPLACE): - -GHC_INPLACE = $(GHC_STAGE1) - GHC_STAGE0 = $(GHC) -GHC_STAGE1 = $(INPLACE_BIN)/ghc-stage1$(exeext) -GHC_STAGE2 = $(INPLACE_BIN)/ghc-stage2$(exeext) -GHC_STAGE3 = $(INPLACE_BIN)/ghc-stage3$(exeext) +GHC_STAGE1 = $(ghc-stage1_INPLACE) +GHC_STAGE2 = $(ghc-stage2_INPLACE) +GHC_STAGE3 = $(ghc-stage3_INPLACE) BOOTSTRAPPING_CONF = libraries/bootstrapping.conf @@ -567,6 +563,9 @@ ifeq "$(CrossCompiling)" "YES" SRC_HSC2HS_OPTS_STAGE1 += --cross-compile SRC_HSC2HS_OPTS_STAGE2 += --cross-compile endif +SRC_HSC2HS_OPTS_STAGE0 += --cflag=-D$(HostArch_CPP)_HOST_ARCH=1 --cflag=-D$(HostOS_CPP)_HOST_OS=1 +SRC_HSC2HS_OPTS_STAGE1 += --cflag=-D$(TargetArch_CPP)_HOST_ARCH=1 --cflag=-D$(TargetOS_CPP)_HOST_OS=1 +SRC_HSC2HS_OPTS_STAGE2 += --cflag=-D$(TargetArch_CPP)_HOST_ARCH=1 --cflag=-D$(TargetOS_CPP)_HOST_OS=1 ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32" WINDRES = $(INPLACE_MINGW)/bin/windres @@ -617,7 +616,12 @@ CPP = @CPP@ @CPPFLAGS@ # RAWCPP_FLAGS are the flags to give to cpp (viz, gcc -E) to persuade it to # behave plausibly on Haskell sources. # +# Clang in particular is a bit more annoying, so we suppress some warnings. RAWCPP_FLAGS = -undef -traditional +ifeq "$(CC_CLANG_BACKEND)" "1" +RAWCPP_FLAGS += -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs +endif + FIND = @FindCmd@ # @@ -632,7 +636,8 @@ LN_S = @LN_S@ MV = mv PERL = @PerlCmd@ PIC = pic -RANLIB = @RANLIB@ +RANLIB_CMD = @RANLIB_CMD@ +REAL_RANLIB_CMD = @REAL_RANLIB_CMD@ SED = @SedCmd@ SHELL = /bin/sh @@ -692,10 +697,6 @@ HSCOLOUR_CMD = @HSCOLOUR@ TIME_CMD = @TimeCmd@ -# Set this if you want to use Inno Setup to build a Windows installer -# when you make a bindist -ISCC_CMD = - #----------------------------------------------------------------------------- # DocBook XML stuff diff --git a/mk/project.mk.in b/mk/project.mk.in index e47663fcdb..28692d4cbb 100644 --- a/mk/project.mk.in +++ b/mk/project.mk.in @@ -125,8 +125,11 @@ BuildVendor_CPP = @BuildVendor_CPP@ LeadingUnderscore=@LeadingUnderscore@ # Pin a suffix on executables? If so, what (Windows only). -exeext=@exeext@ -soext=@soext@ +exeext0=@exeext_host@ +exeext1=@exeext_target@ +exeext2=@exeext_target@ +exeext3=@exeext_target@ +soext=@soext_target@ # Windows_Host=YES if on a Windows platform ifneq "$(findstring $(HostOS_CPP), mingw32 cygwin32)" "" @@ -152,4 +155,5 @@ OSTYPE=@OSTYPE@ SOLARIS_BROKEN_SHLD=@SOLARIS_BROKEN_SHLD@ # Do we have a C compiler using an LLVM back end? -CC_LLVM_BACKEND = @CC_LLVM_BACKEND@ +CC_LLVM_BACKEND = @CC_LLVM_BACKEND@ +CC_CLANG_BACKEND = @CC_CLANG_BACKEND@ diff --git a/mk/tree.mk b/mk/tree.mk index 9c2e3daa4e..887e643340 100644 --- a/mk/tree.mk +++ b/mk/tree.mk @@ -1,10 +1,4 @@ -ifneq "$(findstring 3.7, $(MAKE_VERSION))" "" -ifeq "$(findstring 3.79.1, $(MAKE_VERSION))" "" -$(error GNU make version 3.79.1 or later is required.) -endif -endif - ################################################################################ # # Layout of the source tree @@ -42,7 +42,8 @@ # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # localpath tag remotepath # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -ghc-tarballs - ghc-tarballs.git +ghc-tarballs windows ghc-tarballs.git +libffi-tarballs - libffi-tarballs.git utils/hsc2hs - hsc2hs.git utils/haddock - haddock.git libraries/array - packages/array.git diff --git a/rts/Adjustor.c b/rts/Adjustor.c index fbf95df936..873f3acad1 100644 --- a/rts/Adjustor.c +++ b/rts/Adjustor.c @@ -131,8 +131,8 @@ createAdjustor (int cconv, barf("createAdjustor: failed to allocate memory"); } - r = ffi_prep_closure(cl, cif, (void*)wptr, hptr/*userdata*/); - if (r != FFI_OK) barf("ffi_prep_closure failed: %d", r); + r = ffi_prep_closure_loc(cl, cif, (void*)wptr, hptr/*userdata*/, code); + if (r != FFI_OK) barf("ffi_prep_closure_loc failed: %d", r); return (void*)code; } @@ -335,7 +335,7 @@ createAdjustor(int cconv, StgStablePtr hptr, ) { void *adjustor = NULL; - void *code; + void *code = NULL; switch (cconv) { @@ -491,22 +491,15 @@ createAdjustor(int cconv, StgStablePtr hptr, */ { - int i = 0; - int fourthFloating; - char *c; StgWord8 *adj_code; // determine whether we have 4 or more integer arguments, // and therefore need to flush one to the stack. - for (c = typeString; *c != '\0'; c++) { - i++; - if (i == 4) { - fourthFloating = (*c == 'f' || *c == 'd'); - break; - } - } + if ((typeString[0] == '\0') || + (typeString[1] == '\0') || + (typeString[2] == '\0') || + (typeString[3] == '\0')) { - if (i < 4) { adjustor = allocateExec(0x38,&code); adj_code = (StgWord8*)adjustor; @@ -525,6 +518,9 @@ createAdjustor(int cconv, StgStablePtr hptr, } else { + int fourthFloating; + + fourthFloating = (typeString[3] == 'f' || typeString[3] == 'd'); adjustor = allocateExec(0x58,&code); adj_code = (StgWord8*)adjustor; *(StgInt32 *)adj_code = 0x08ec8348; diff --git a/rts/CheckUnload.c b/rts/CheckUnload.c new file mode 100644 index 0000000000..a758b06db3 --- /dev/null +++ b/rts/CheckUnload.c @@ -0,0 +1,303 @@ +/* ---------------------------------------------------------------------------- + * + * (c) The GHC Team, 2013- + * + * Check whether dynamically-loaded object code can be safely + * unloaded, by searching for references to it from the heap and RTS + * data structures. + * + * --------------------------------------------------------------------------*/ + +#include "PosixSource.h" +#include "Rts.h" + +#include "RtsUtils.h" +#include "Hash.h" +#include "LinkerInternals.h" +#include "CheckUnload.h" +#include "sm/Storage.h" +#include "sm/GCThread.h" + +// +// Code that we unload may be referenced from: +// - info pointers in heap objects and stack frames +// - pointers to static objects from the heap +// - StablePtrs to static objects +// +// We can find live static objects after a major GC, so we don't have +// to look at every closure pointer in the heap. However, we do have +// to look at every info pointer. So this is like a heap census +// traversal: we look at the header of every object, but not its +// contents. +// +// On the assumption that there aren't many different info pointers in +// a typical heap, we insert addresses into a hash table. The +// first time we see an address, we check it against the pending +// unloadable objects and if it lies within any of them, we mark that +// object as referenced so that it won't get unloaded in this round. +// + +static void checkAddress (HashTable *addrs, void *addr) +{ + ObjectCode *oc; + + if (!lookupHashTable(addrs, (W_)addr)) { + insertHashTable(addrs, (W_)addr, addr); + + for (oc = unloaded_objects; oc; oc = oc->next) { + if ((W_)addr >= (W_)oc->image && + (W_)addr < (W_)oc->image + oc->fileSize) { + oc->referenced = 1; + break; + } + } + } +} + +static void searchStackChunk (HashTable *addrs, StgPtr sp, StgPtr stack_end) +{ + StgPtr p; + const StgRetInfoTable *info; + + p = sp; + while (p < stack_end) { + info = get_ret_itbl((StgClosure *)p); + + switch (info->i.type) { + case RET_SMALL: + case RET_BIG: + checkAddress(addrs, (void*)info); + break; + + default: + break; + } + + p += stack_frame_sizeW((StgClosure*)p); + } +} + + +static void searchHeapBlocks (HashTable *addrs, bdescr *bd) +{ + StgPtr p; + StgInfoTable *info; + nat size; + rtsBool prim; + + for (; bd != NULL; bd = bd->link) { + + if (bd->flags & BF_PINNED) { + // Assume that objects in PINNED blocks cannot refer to + continue; + } + + p = bd->start; + while (p < bd->free) { + info = get_itbl((StgClosure *)p); + prim = rtsFalse; + + switch (info->type) { + + case THUNK: + size = thunk_sizeW_fromITBL(info); + break; + + case THUNK_1_1: + case THUNK_0_2: + case THUNK_2_0: + size = sizeofW(StgThunkHeader) + 2; + break; + + case THUNK_1_0: + case THUNK_0_1: + case THUNK_SELECTOR: + size = sizeofW(StgThunkHeader) + 1; + break; + + case CONSTR: + case FUN: + case FUN_1_0: + case FUN_0_1: + case FUN_1_1: + case FUN_0_2: + case FUN_2_0: + case CONSTR_1_0: + case CONSTR_0_1: + case CONSTR_1_1: + case CONSTR_0_2: + case CONSTR_2_0: + size = sizeW_fromITBL(info); + break; + + case IND_PERM: + case BLACKHOLE: + case BLOCKING_QUEUE: + prim = rtsTrue; + size = sizeW_fromITBL(info); + break; + + case IND: + // Special case/Delicate Hack: INDs don't normally + // appear, since we're doing this heap census right + // after GC. However, GarbageCollect() also does + // resurrectThreads(), which can update some + // blackholes when it calls raiseAsync() on the + // resurrected threads. So we know that any IND will + // be the size of a BLACKHOLE. + prim = rtsTrue; + size = BLACKHOLE_sizeW(); + break; + + case BCO: + prim = rtsTrue; + size = bco_sizeW((StgBCO *)p); + break; + + case MVAR_CLEAN: + case MVAR_DIRTY: + case TVAR: + case WEAK: + case PRIM: + case MUT_PRIM: + case MUT_VAR_CLEAN: + case MUT_VAR_DIRTY: + prim = rtsTrue; + size = sizeW_fromITBL(info); + break; + + case AP: + prim = rtsTrue; + size = ap_sizeW((StgAP *)p); + break; + + case PAP: + prim = rtsTrue; + size = pap_sizeW((StgPAP *)p); + break; + + case AP_STACK: + { + StgAP_STACK *ap = (StgAP_STACK *)p; + prim = rtsTrue; + size = ap_stack_sizeW(ap); + searchStackChunk(addrs, (StgPtr)ap->payload, + (StgPtr)ap->payload + ap->size); + break; + } + + case ARR_WORDS: + prim = rtsTrue; + size = arr_words_sizeW((StgArrWords*)p); + break; + + case MUT_ARR_PTRS_CLEAN: + case MUT_ARR_PTRS_DIRTY: + case MUT_ARR_PTRS_FROZEN: + case MUT_ARR_PTRS_FROZEN0: + prim = rtsTrue; + size = mut_arr_ptrs_sizeW((StgMutArrPtrs *)p); + break; + + case TSO: + prim = rtsTrue; + size = sizeofW(StgTSO); + break; + + case STACK: { + StgStack *stack = (StgStack*)p; + prim = rtsTrue; + searchStackChunk(addrs, stack->sp, + stack->stack + stack->stack_size); + size = stack_sizeW(stack); + break; + } + + case TREC_CHUNK: + prim = rtsTrue; + size = sizeofW(StgTRecChunk); + break; + + default: + barf("heapCensus, unknown object: %d", info->type); + } + + if (!prim) { + checkAddress(addrs,info); + } + + p += size; + } + } +} + +// +// Check whether we can unload any object code. This is called at the +// appropriate point during a GC, where all the heap data is nice and +// packed together and we have a linked list of the static objects. +// +// The check involves a complete heap traversal, but you only pay for +// this (a) when you have called unloadObj(), and (b) at a major GC, +// which is much more expensive than the traversal we're doing here. +// +void checkUnload (StgClosure *static_objects) +{ + nat g, n; + HashTable *addrs; + StgClosure* p; + const StgInfoTable *info; + ObjectCode *oc, *prev; + gen_workspace *ws; + StgClosure* link; + + if (unloaded_objects == NULL) return; + + // Mark every unloadable object as unreferenced initially + for (oc = unloaded_objects; oc; oc = oc->next) { + IF_DEBUG(linker, debugBelch("Checking whether to unload %s\n", + oc->fileName)); + oc->referenced = rtsFalse; + } + + addrs = allocHashTable(); + + for (p = static_objects; p != END_OF_STATIC_LIST; p = link) { + checkAddress(addrs, p); + info = get_itbl(p); + link = *STATIC_LINK(info, p); + } + + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { + searchHeapBlocks (addrs, generations[g].blocks); + searchHeapBlocks (addrs, generations[g].large_objects); + + for (n = 0; n < n_capabilities; n++) { + ws = &gc_threads[n]->gens[g]; + searchHeapBlocks(addrs, ws->todo_bd); + searchHeapBlocks(addrs, ws->part_list); + searchHeapBlocks(addrs, ws->scavd_list); + } + } + + // Look through the unloadable objects, and any object that is still + // marked as unreferenced can be physically unloaded, because we + // have no references to it. + prev = NULL; + for (oc = unloaded_objects; oc; prev = oc, oc = oc->next) { + if (oc->referenced == 0) { + if (prev == NULL) { + unloaded_objects = oc->next; + } else { + prev->next = oc->next; + } + IF_DEBUG(linker, debugBelch("Unloading object file %s\n", + oc->fileName)); + freeObjectCode(oc); + } else { + IF_DEBUG(linker, debugBelch("Object file still in use: %s\n", + oc->fileName)); + } + } + + freeHashTable(addrs, NULL); +} diff --git a/rts/CheckUnload.h b/rts/CheckUnload.h new file mode 100644 index 0000000000..7d2e5b1321 --- /dev/null +++ b/rts/CheckUnload.h @@ -0,0 +1,20 @@ +/* ---------------------------------------------------------------------------- + * + * (c) The GHC Team, 2013- + * + * Check whether dynamically-loaded object code can be safely + * unloaded, by searching for references to it from the heap and RTS + * data structures. + * + * --------------------------------------------------------------------------*/ + +#ifndef CHECKUNLOAD_H +#define CHECKUNLOAD_H + +#include "BeginPrivate.h" + +void checkUnload (StgClosure *static_objects); + +#include "EndPrivate.h" + +#endif // CHECKUNLOAD_H diff --git a/rts/FrontPanel.c b/rts/FrontPanel.c deleted file mode 100644 index b0b9bced4a..0000000000 --- a/rts/FrontPanel.c +++ /dev/null @@ -1,796 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The GHC Team 2000 - * - * RTS GTK Front Panel - * - * ---------------------------------------------------------------------------*/ - -#ifdef RTS_GTK_FRONTPANEL - -/* Alas, not Posix. */ -/* #include "PosixSource.h" */ - -#include "Rts.h" - -#include "RtsUtils.h" -#include "FrontPanel.h" -#include "Stats.h" -#include "Schedule.h" - -#include <gtk/gtk.h> -#include <unistd.h> -#include <string.h> - -#include "VisSupport.h" -#include "VisWindow.h" - -static GtkWidget *window, *map_drawing_area, *gen_drawing_area; -static GtkWidget *res_drawing_area; -static GtkWidget *continue_but, *stop_but, *quit_but; -static GtkWidget *statusbar; -static GtkWidget *live_label, *allocated_label; -static GtkWidget *footprint_label, *alloc_rate_label; -static GtkWidget *map_ruler, *gen_ruler; -static GtkWidget *res_vruler, *res_hruler; -static GtkWidget *running_label, *b_read_label, *b_write_label, *total_label; -static GtkWidget *b_mvar_label, *b_bh_label, *b_throwto_label, *sleeping_label; - -static guint status_context_id; - -gboolean continue_now = FALSE, stop_now = FALSE, quit = FALSE; -UpdateMode update_mode = Continuous; - -static GdkPixmap *map_pixmap = NULL; -static GdkPixmap *gen_pixmap = NULL; -static GdkPixmap *res_pixmap = NULL; - -#define N_GENS 10 - -static GdkColor - bdescr_color = { 0, 0xffff, 0, 0 }, /* red */ - free_color = { 0, 0, 0, 0xffff }, /* blue */ - gen_colors[N_GENS] = { - { 0, 0, 0xffff, 0 }, - { 0, 0, 0xf000, 0 }, - { 0, 0, 0xe000, 0 }, - { 0, 0, 0xd000, 0 }, - { 0, 0, 0xc000, 0 }, - { 0, 0, 0xb000, 0 }, - { 0, 0, 0xa000, 0 }, - { 0, 0, 0x9000, 0 }, - { 0, 0, 0x8000, 0 }, - { 0, 0, 0x7000, 0 } - }; - -GdkGC *my_gc = NULL; - -static void *mem_start = (void *) 0x50000000; - -static void colorBlock( void *addr, GdkColor *color, - nat block_width, nat block_height, - nat blocks_per_line ); - -static void residencyCensus( void ); -static void updateResidencyGraph( void ); -static void updateThreadsPanel( void ); - -/* Some code pinched from examples/scribble-simple in the GTK+ - * distribution. - */ - -/* Create a new backing pixmap of the appropriate size */ -static gint -configure_event( GtkWidget *widget, GdkEventConfigure *event STG_UNUSED, - GdkPixmap **pixmap ) -{ - if (*pixmap) - gdk_pixmap_unref(*pixmap); - - *pixmap = gdk_pixmap_new(widget->window, - widget->allocation.width, - widget->allocation.height, - -1); - - gdk_draw_rectangle (*pixmap, - widget->style->white_gc, - TRUE, - 0, 0, - widget->allocation.width, - widget->allocation.height); - - debugBelch("configure!\n"); - updateFrontPanel(); - return TRUE; -} - -/* Redraw the screen from the backing pixmap */ -static gint -expose_event( GtkWidget *widget, GdkEventExpose *event, GdkPixmap **pixmap ) -{ - gdk_draw_pixmap(widget->window, - widget->style->fg_gc[GTK_WIDGET_STATE (widget)], - *pixmap, - event->area.x, event->area.y, - event->area.x, event->area.y, - event->area.width, event->area.height); - - return FALSE; -} - -void -initFrontPanel( void ) -{ - GdkColormap *colormap; - GtkWidget *gen_hbox; - - gtk_init( &prog_argc, &prog_argv ); - - window = create_GHC_Front_Panel(); - map_drawing_area = lookup_widget(window, "memmap"); - gen_drawing_area = lookup_widget(window, "generations"); - res_drawing_area = lookup_widget(window, "res_drawingarea"); - stop_but = lookup_widget(window, "stop_but"); - continue_but = lookup_widget(window, "continue_but"); - quit_but = lookup_widget(window, "quit_but"); - statusbar = lookup_widget(window, "statusbar"); - live_label = lookup_widget(window, "live_label"); - footprint_label = lookup_widget(window, "footprint_label"); - allocated_label = lookup_widget(window, "allocated_label"); - alloc_rate_label = lookup_widget(window, "alloc_rate_label"); - gen_hbox = lookup_widget(window, "gen_hbox"); - gen_ruler = lookup_widget(window, "gen_ruler"); - map_ruler = lookup_widget(window, "map_ruler"); - res_vruler = lookup_widget(window, "res_vruler"); - res_hruler = lookup_widget(window, "res_hruler"); - running_label = lookup_widget(window, "running_label"); - b_read_label = lookup_widget(window, "blockread_label"); - b_write_label = lookup_widget(window, "blockwrite_label"); - b_mvar_label = lookup_widget(window, "blockmvar_label"); - b_bh_label = lookup_widget(window, "blockbh_label"); - b_throwto_label = lookup_widget(window, "blockthrowto_label"); - sleeping_label = lookup_widget(window, "sleeping_label"); - total_label = lookup_widget(window, "total_label"); - - status_context_id = - gtk_statusbar_get_context_id( GTK_STATUSBAR(statusbar), "context" ); - - /* hook up some signals for the mem map drawing area */ - gtk_signal_connect (GTK_OBJECT(map_drawing_area), "expose_event", - (GtkSignalFunc)expose_event, &map_pixmap); - gtk_signal_connect (GTK_OBJECT(map_drawing_area), "configure_event", - (GtkSignalFunc)configure_event, &map_pixmap); - - gtk_widget_set_events(map_drawing_area, GDK_EXPOSURE_MASK); - - /* hook up some signals for the gen drawing area */ - gtk_signal_connect (GTK_OBJECT(gen_drawing_area), "expose_event", - (GtkSignalFunc)expose_event, &gen_pixmap); - gtk_signal_connect (GTK_OBJECT(gen_drawing_area), "configure_event", - (GtkSignalFunc)configure_event, &gen_pixmap); - - gtk_widget_set_events(gen_drawing_area, GDK_EXPOSURE_MASK); - - /* hook up some signals for the res drawing area */ - gtk_signal_connect (GTK_OBJECT(res_drawing_area), "expose_event", - (GtkSignalFunc)expose_event, &res_pixmap); - gtk_signal_connect (GTK_OBJECT(res_drawing_area), "configure_event", - (GtkSignalFunc)configure_event, &res_pixmap); - - gtk_widget_set_events(res_drawing_area, GDK_EXPOSURE_MASK); - - /* allocate our colors */ - colormap = gdk_colormap_get_system(); - gdk_colormap_alloc_color(colormap, &bdescr_color, TRUE, TRUE); - gdk_colormap_alloc_color(colormap, &free_color, TRUE, TRUE); - - { - gboolean success[N_GENS]; - gdk_colormap_alloc_colors(colormap, gen_colors, N_GENS, TRUE, - TRUE, success); - if (!success) { barf("can't allocate colors"); } - } - - /* set the labels on the generation histogram */ - { - char buf[64]; - nat g, s; - GtkWidget *label; - - for(g = 0; g < RtsFlags.GcFlags.generations; g++) { - for(s = 0; s < generations[g].n_steps; s++) { - g_snprintf( buf, 64, "%d.%d", g, s ); - label = gtk_label_new( buf ); - gtk_box_pack_start( GTK_BOX(gen_hbox), label, - TRUE, TRUE, 5 ); - gtk_widget_show(label); - } - } - } - - gtk_widget_show(window); - - /* wait for the user to press "Continue" before getting going... */ - gtk_statusbar_push( GTK_STATUSBAR(statusbar), status_context_id, - "Program start"); - gtk_widget_set_sensitive( stop_but, FALSE ); - continue_now = FALSE; - while (continue_now == FALSE) { - gtk_main_iteration(); - } - gtk_statusbar_pop( GTK_STATUSBAR(statusbar), status_context_id ); - gtk_statusbar_push( GTK_STATUSBAR(statusbar), status_context_id, - "Running"); - - gtk_widget_set_sensitive( continue_but, FALSE ); - gtk_widget_set_sensitive( stop_but, TRUE ); - gtk_widget_set_sensitive( quit_but, FALSE ); - - while (gtk_events_pending()) { - gtk_main_iteration(); - } -} - -void -stopFrontPanel( void ) -{ - gtk_widget_set_sensitive( quit_but, TRUE ); - gtk_widget_set_sensitive( continue_but, FALSE ); - gtk_widget_set_sensitive( stop_but, FALSE ); - - updateFrontPanel(); - - gtk_statusbar_push( GTK_STATUSBAR(statusbar), status_context_id, - "Program finished"); - - quit = FALSE; - while (quit == FALSE) { - gtk_main_iteration(); - } -} - -static void -waitForContinue( void ) -{ - gtk_widget_set_sensitive( continue_but, TRUE ); - gtk_widget_set_sensitive( stop_but, FALSE ); - stop_now = FALSE; - continue_now = FALSE; - while (continue_now == FALSE) { - gtk_main_iteration(); - } - gtk_widget_set_sensitive( continue_but, FALSE ); - gtk_widget_set_sensitive( stop_but, TRUE ); -} - -void -updateFrontPanelBeforeGC( nat N ) -{ - char buf[1000]; - - updateFrontPanel(); - - if (update_mode == BeforeGC - || update_mode == BeforeAfterGC - || stop_now == TRUE) { - g_snprintf( buf, 1000, "Stopped (before GC, generation %d)", N ); - gtk_statusbar_push( GTK_STATUSBAR(statusbar), status_context_id, buf ); - waitForContinue(); - gtk_statusbar_pop( GTK_STATUSBAR(statusbar), status_context_id ); - } - - g_snprintf( buf, 1000, "Garbage collecting (generation %d)", N ); - gtk_statusbar_push( GTK_STATUSBAR(statusbar), status_context_id, buf); - - while (gtk_events_pending()) { - gtk_main_iteration(); - } -} - -static void -numLabel( GtkWidget *lbl, nat n ) -{ - char buf[64]; - g_snprintf(buf, 64, "%d", n); - gtk_label_set_text( GTK_LABEL(lbl), buf ); -} - -void -updateFrontPanelAfterGC( nat N, W_ live ) -{ - char buf[1000]; - - gtk_statusbar_pop( GTK_STATUSBAR(statusbar), status_context_id ); - - /* is a major GC? */ - if (N == RtsFlags.GcFlags.generations-1) { - residencyCensus(); - } - - updateFrontPanel(); - - if (update_mode == AfterGC - || update_mode == BeforeAfterGC - || stop_now == TRUE) { - snprintf( buf, 1000, "Stopped (after GC, generation %d)", N ); - gtk_statusbar_push( GTK_STATUSBAR(statusbar), status_context_id, buf ); - waitForContinue(); - gtk_statusbar_pop( GTK_STATUSBAR(statusbar), status_context_id ); - } - - { - double words_to_megs = (1024 * 1024) / sizeof(W_); - double time = mut_user_time(); - - snprintf( buf, 1000, "%.2f", (double)live / words_to_megs ); - gtk_label_set_text( GTK_LABEL(live_label), buf ); - - snprintf( buf, 1000, "%.2f", (double)total_allocated / words_to_megs ); - gtk_label_set_text( GTK_LABEL(allocated_label), buf ); - - snprintf( buf, 1000, "%.2f", - (double)(mblocks_allocated * MBLOCK_SIZE_W) / words_to_megs ); - gtk_label_set_text( GTK_LABEL(footprint_label), buf ); - - if ( time == 0.0 ) - snprintf( buf, 1000, "%.2f", time ); - else - snprintf( buf, 1000, "%.2f", - (double)(total_allocated / words_to_megs) / time ); - gtk_label_set_text( GTK_LABEL(alloc_rate_label), buf ); - } - - while (gtk_events_pending()) { - gtk_main_iteration(); - } -} - -void -updateFrontPanel( void ) -{ - void *m, *a; - bdescr *bd; - - updateThreadsPanel(); - - if (my_gc == NULL) { - my_gc = gdk_gc_new( window->window ); - } - - if (map_pixmap != NULL) { - nat height, width, blocks_per_line, - block_height, block_width, mblock_height; - - height = map_drawing_area->allocation.height; - width = map_drawing_area->allocation.width; - - mblock_height = height / mblocks_allocated; - blocks_per_line = 16; - block_height = mblock_height / - ((MBLOCK_SIZE/BLOCK_SIZE) / blocks_per_line); - while (block_height == 0) { - blocks_per_line *= 2; - block_height = mblock_height / - ((MBLOCK_SIZE/BLOCK_SIZE) / blocks_per_line); - } - block_width = width / blocks_per_line; - - gdk_draw_rectangle (map_pixmap, - map_drawing_area->style->bg_gc[GTK_STATE_NORMAL], - TRUE, - 0, 0, - map_drawing_area->allocation.width, - map_drawing_area->allocation.height); - - for ( m = mem_start; - (char *)m < (char *)mem_start + - (mblocks_allocated * MBLOCK_SIZE); - (char *)m += MBLOCK_SIZE ) { - - /* color the bdescr area first */ - for (a = m; a < FIRST_BLOCK(m); (char *)a += BLOCK_SIZE) { - colorBlock( a, &bdescr_color, - block_width, block_height, blocks_per_line ); - } - -#if 0 /* Segfaults because bd appears to be bogus but != NULL. stolz, 2003-06-24 */ - /* color each block */ - for (; a <= LAST_BLOCK(m); (char *)a += BLOCK_SIZE) { - bd = Bdescr((P_)a); - ASSERT(bd->start == a); - if (bd->flags & BF_FREE) { - colorBlock( a, &free_color, - block_width, block_height, blocks_per_line ); - } else { - colorBlock( a, &gen_colors[bd->gen_no], - block_width, block_height, blocks_per_line ); - } - } -#endif - } - - - { - nat height = map_drawing_area->allocation.height, - block_height, mblock_height; - - block_height = (height / mblocks_allocated) / - ((MBLOCK_SIZE/BLOCK_SIZE) / blocks_per_line); - if (block_height < 1) block_height = 1; - mblock_height = block_height * - ((MBLOCK_SIZE/BLOCK_SIZE) / blocks_per_line); - - gtk_ruler_set_range( GTK_RULER(map_ruler), 0, - (double)(height * mblocks_allocated) / - (double)((mblock_height * mblocks_allocated)), - 0, - (double)(height * mblocks_allocated) / - (double)((mblock_height * mblocks_allocated)) - ); - } - - gtk_widget_draw( map_drawing_area, NULL ); - } - - if (gen_pixmap != NULL) { - - GdkRectangle rect; - nat g, s, columns, column, max_blocks, height_blocks, - width, height; - - gdk_draw_rectangle (gen_pixmap, - gen_drawing_area->style->white_gc, - TRUE, - 0, 0, - gen_drawing_area->allocation.width, - gen_drawing_area->allocation.height); - - height = gen_drawing_area->allocation.height; - width = gen_drawing_area->allocation.width; - - columns = 0; max_blocks = 0; - for(g = 0; g < RtsFlags.GcFlags.generations; g++) { - columns += generations[g].n_steps; - for(s = 0; s < generations[g].n_steps; s++) { - if (generations[g].steps[s].n_blocks > max_blocks) { - max_blocks = generations[g].steps[s].n_blocks; - } - } - } - - /* find a reasonable height value larger than max_blocks */ - { - nat n = 0; - while (max_blocks != 0) { - max_blocks >>= 1; n++; - } - height_blocks = 1 << n; - } - - column = 0; - for(g = 0; g < RtsFlags.GcFlags.generations; g++) { - for(s = 0; s < generations[g].n_steps; s++, column++) { - gdk_gc_set_foreground(my_gc, &gen_colors[g]); - - rect.x = column * (width / columns); - - if (generations[g].steps[s].n_blocks == 0) - rect.y = height; - else - rect.y = height - - (height * generations[g].steps[s].n_blocks - / height_blocks); - - rect.width = (width / columns); - rect.height = height - rect.y; - - gdk_draw_rectangle( gen_pixmap, my_gc, TRUE/*filled*/, - rect.x, rect.y, rect.width, - rect.height ); - } - } - - gtk_ruler_set_range( GTK_RULER(gen_ruler), - height_blocks * BLOCK_SIZE / (1024 * 1024), - 0, 0, - height_blocks * BLOCK_SIZE / (1024 * 1024) - ); - - gtk_widget_draw( gen_drawing_area, NULL ); - } - - if (res_pixmap != NULL) { - updateResidencyGraph(); - } - - while (gtk_events_pending()) { - gtk_main_iteration_do(FALSE/*don't block*/); - } -} - -static void -colorBlock( void *addr, GdkColor *color, - nat block_width, nat block_height, nat blocks_per_line ) -{ - GdkRectangle rect; - nat block_no; - - gdk_gc_set_foreground(my_gc, color); - - block_no = ((char *)addr - (char *)mem_start) / BLOCK_SIZE; - - rect.x = (block_no % blocks_per_line) * block_width; - rect.y = block_no / blocks_per_line * block_height; - rect.width = block_width; - rect.height = block_height; - gdk_draw_rectangle( map_pixmap, my_gc, TRUE/*filled*/, - rect.x, rect.y, rect.width, rect.height ); -} - -static void -updateThreadsPanel( void ) -{ - nat running = 0, - b_read = 0, - b_write = 0, - b_mvar = 0, - b_throwto = 0, - b_bh = 0, - sleeping = 0, - total = 0; - - StgTSO *t; - - for (t = all_threads; t != END_TSO_QUEUE; t = t->global_link) { - switch (t->what_next) { - case ThreadKilled: break; - case ThreadComplete: break; - default: - switch (t->why_blocked) { - case BlockedOnRead: b_read++; break; - case BlockedOnWrite: b_write++; break; - case BlockedOnDelay: sleeping++; break; - case BlockedOnMVar: b_mvar++; break; - case BlockedOnException: b_throwto++; break; - case BlockedOnBlackHole: b_bh++; break; - case NotBlocked: running++; break; - } - } - } - total = running + b_read + b_write + b_mvar + b_throwto + b_bh + sleeping; - numLabel(running_label, running); - numLabel(b_read_label, b_read); - numLabel(b_write_label, b_write); - numLabel(b_mvar_label, b_mvar); - numLabel(b_bh_label, b_bh); - numLabel(b_throwto_label, b_throwto); - numLabel(sleeping_label, sleeping); - numLabel(total_label, total); -} - -typedef enum { Thunk, Fun, Constr, BlackHole, - Array, Thread, Other, N_Cats } ClosureCategory; - -#define N_SLICES 100 - -static nat *res_prof[N_SLICES]; -static double res_time[N_SLICES]; -static nat next_slice = 0; - -static void -residencyCensus( void ) -{ - nat slice = next_slice++, *prof; - bdescr *bd; - nat g, s, size, type; - StgPtr p; - StgInfoTable *info; - - if (slice >= N_SLICES) { - barf("too many slices"); - } - res_prof[slice] = stgMallocBytes(N_Cats * sizeof(nat), "residencyCensus"); - prof = res_prof[slice]; - memset(prof, 0, N_Cats * sizeof(nat)); - - res_time[slice] = mut_user_time(); - - for(g = 0; g < RtsFlags.GcFlags.generations; g++) { - for(s = 0; s < generations[g].n_steps; s++) { - - /* skip over g0s0 if multi-generational */ - if (RtsFlags.GcFlags.generations > 1 && - g == 0 && s == 0) continue; - - if (RtsFlags.GcFlags.generations == 1) { -/* bd = generations[g].steps[s].to_blocks; FIXME to_blocks does not exist */ - } else { - bd = generations[g].steps[s].blocks; - } - - for (; bd != NULL; bd = bd->link) { - - p = bd->start; - - while (p < bd->free) { - info = get_itbl((StgClosure *)p); - type = Other; - - switch (info->type) { - - case CONSTR: - case BCO: - if (((StgClosure *)p)->header.info == &stg_DEAD_WEAK_info) { - size = sizeofW(StgWeak); - type = Other; - break; - } - /* else, fall through... */ - case CONSTR_1_0: - case CONSTR_0_1: - case CONSTR_1_1: - case CONSTR_0_2: - case CONSTR_2_0: - size = sizeW_fromITBL(info); - type = Constr; - break; - - case FUN_1_0: - case FUN_0_1: - size = sizeofW(StgHeader) + 1; - goto fun; - case FUN_1_1: - case FUN_0_2: - case FUN_2_0: - case FUN: - size = sizeW_fromITBL(info); - fun: - type = Fun; - break; - - case THUNK_1_0: - case THUNK_0_1: - case THUNK_SELECTOR: - size = sizeofW(StgHeader) + 2; - goto thunk; - case THUNK_1_1: - case THUNK_0_2: - case THUNK_2_0: - case THUNK: - size = sizeW_fromITBL(info); - thunk: - type = Thunk; - break; - - case BLACKHOLE: -/* case BLACKHOLE_BQ: FIXME: case does not exist */ - size = sizeW_fromITBL(info); - type = BlackHole; - break; - - case AP: - size = pap_sizeW((StgPAP *)p); - type = Thunk; - break; - - case PAP: - size = pap_sizeW((StgPAP *)p); - type = Fun; - break; - - case ARR_WORDS: - size = arr_words_sizeW(stgCast(StgArrWords*,p)); - type = Array; - break; - - case MUT_ARR_PTRS: - case MUT_ARR_PTRS_FROZEN: - size = mut_arr_ptrs_sizeW((StgMutArrPtrs *)p); - type = Array; - break; - - case TSO: - size = tso_sizeW((StgTSO *)p); - type = Thread; - break; - - case WEAK: - case PRIM: - case MVAR: - case MUT_VAR: -/* case MUT_CONS: FIXME: case does not exist */ - case IND_PERM: - size = sizeW_fromITBL(info); - type = Other; - break; - - default: - barf("updateResidencyGraph: strange closure " - "%d", info->type ); - } - - prof[type] += size; - p += size; - } - } - } - } - -} - -static void -updateResidencyGraph( void ) -{ - nat total, prev_total, i, max_res; - double time; - double time_scale = 1; - nat last_slice = next_slice-1; - double res_scale = 1; /* in megabytes, doubles */ - nat *prof; - nat width, height; - GdkPoint points[4]; - - gdk_draw_rectangle (res_pixmap, - res_drawing_area->style->bg_gc[GTK_STATE_NORMAL], - TRUE, - 0, 0, - res_drawing_area->allocation.width, - res_drawing_area->allocation.height); - - if (next_slice == 0) return; - - time = res_time[last_slice]; - while (time > time_scale) { - time_scale *= 2; - } - - max_res = 0; - for (i = 0; i < next_slice; i++) { - prof = res_prof[i]; - total = prof[Thunk] + prof[Fun] + prof[Constr] + - prof[BlackHole] + prof[Array] + prof[Other]; - if (total > max_res) { - max_res = total; - } - } - while (max_res > res_scale) { - res_scale *= 2; - } - - height = res_drawing_area->allocation.height; - width = res_drawing_area->allocation.width; - - points[0].x = 0; - points[0].y = height; - points[1].y = height; - points[3].x = 0; - points[3].y = height; - - gdk_gc_set_foreground(my_gc, &free_color); - - prev_total = 0; - for (i = 0; i < next_slice; i++) { - prof = res_prof[i]; - total = prof[Thunk] + prof[Fun] + prof[Constr] + - prof[BlackHole] + prof[Array] + prof[Other]; - points[1].x = width * res_time[i] / time_scale; - points[2].x = points[1].x; - points[2].y = height - ((height * total) / res_scale); - gdk_draw_polygon(res_pixmap, my_gc, TRUE/*filled*/, points, 4); - points[3] = points[2]; - points[0] = points[1]; - } - - gtk_ruler_set_range( GTK_RULER(res_vruler), - res_scale / ((1024*1024)/sizeof(W_)), - 0, 0, - res_scale / ((1024*1024)/sizeof(W_)) ); - - gtk_ruler_set_range( GTK_RULER(res_hruler), - 0, time_scale, 0, time_scale ); - - - gtk_widget_draw( res_drawing_area, NULL ); -} - -#endif /* RTS_GTK_FRONTPANEL */ diff --git a/rts/FrontPanel.h b/rts/FrontPanel.h deleted file mode 100644 index 84e40d5e1b..0000000000 --- a/rts/FrontPanel.h +++ /dev/null @@ -1,39 +0,0 @@ -/* ----------------------------------------------------------------------------- - * - * (c) The GHC Team 2000-2005 - * - * RTS GTK Front Panel - * - * ---------------------------------------------------------------------------*/ - -#ifndef FRONTPANEL_H -#define FRONTPANEL_H - -#include "BeginPrivate.h" - -#ifdef RTS_GTK_FRONTPANEL - -#include "Rts.h" /* needed because this file gets included by - * auto-generated code */ - -void initFrontPanel( void ); -void stopFrontPanel( void ); -void updateFrontPanelBeforeGC( nat N ); -void updateFrontPanelAfterGC( nat N, W_ live ); -void updateFrontPanel( void ); - - -/* --------- PRIVATE ----------------------------------------- */ - -#include <gdk/gdktypes.h> - -typedef enum { BeforeGC, AfterGC, BeforeAfterGC, Continuous } UpdateMode; -extern UpdateMode update_mode; -extern gboolean continue_now, stop_now, quit; - -#endif /* RTS_GTK_FRONTPANEL */ - -#include "EndPrivate.h" - -#endif /* FRONTPANEL_H */ - diff --git a/rts/Globals.c b/rts/Globals.c index 1aafe21879..2e4b99474f 100644 --- a/rts/Globals.c +++ b/rts/Globals.c @@ -7,8 +7,13 @@ * even when multiple versions of the library are loaded. e.g. see * Data.Typeable and GHC.Conc. * - * If/when we switch to a dynamically-linked GHCi, this can all go - * away, because there would be just one copy of each library. + * How are multiple versions of a library loaded? Examples: + * + * base - a statically-linked ghci has its own copy, so might libraries it + * dynamically loads + * + * libHSghc - a statically-linked ghc has its own copy and so will Core + * plugins it dynamically loads (cf CoreMonad.reinitializeGlobals) * * ---------------------------------------------------------------------------*/ @@ -27,6 +32,7 @@ typedef enum { SystemEventThreadIOManagerThreadStore, SystemTimerThreadEventManagerStore, SystemTimerThreadIOManagerThreadStore, + LibHSghcFastStringTable, MaxStoreKey } StoreKey; @@ -128,3 +134,9 @@ getOrSetSystemTimerThreadIOManagerThreadStore(StgStablePtr ptr) { return getOrSetKey(SystemTimerThreadIOManagerThreadStore,ptr); } + +StgStablePtr +getOrSetLibHSghcFastStringTable(StgStablePtr ptr) +{ + return getOrSetKey(LibHSghcFastStringTable,ptr); +} diff --git a/rts/HeapStackCheck.cmm b/rts/HeapStackCheck.cmm index fbceb7691a..e130cb3660 100644 --- a/rts/HeapStackCheck.cmm +++ b/rts/HeapStackCheck.cmm @@ -487,11 +487,11 @@ stg_block_noregs /* ----------------------------------------------------------------------------- * takeMVar/putMVar-specific blocks * - * Stack layout for a thread blocked in takeMVar: + * Stack layout for a thread blocked in takeMVar/readMVar: * * ret. addr * ptr to MVar (R1) - * stg_block_takemvar_info + * stg_block_takemvar_info (or stg_block_readmvar_info) * * Stack layout for a thread blocked in putMVar: * @@ -531,6 +531,33 @@ stg_block_takemvar /* mvar passed in R1 */ BLOCK_BUT_FIRST(stg_block_takemvar_finally); } +INFO_TABLE_RET ( stg_block_readmvar, RET_SMALL, W_ info_ptr, P_ mvar ) + return () +{ + jump stg_readMVarzh(mvar); +} + +// code fragment executed just before we return to the scheduler +stg_block_readmvar_finally +{ + W_ r1, r3; + r1 = R1; + r3 = R3; + unlockClosure(R3, stg_MVAR_DIRTY_info); + R1 = r1; + R3 = r3; + jump StgReturn [R1]; +} + +stg_block_readmvar /* mvar passed in R1 */ +{ + Sp_adj(-2); + Sp(1) = R1; + Sp(0) = stg_block_readmvar_info; + R3 = R1; // mvar communicated to stg_block_readmvar_finally in R3 + BLOCK_BUT_FIRST(stg_block_readmvar_finally); +} + INFO_TABLE_RET( stg_block_putmvar, RET_SMALL, W_ info_ptr, P_ mvar, P_ val ) return () diff --git a/rts/Linker.c b/rts/Linker.c index 585d1e8451..81a267db1b 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -156,6 +156,10 @@ static /*Str*/HashTable *stablehash; /* List of currently loaded objects */ ObjectCode *objects = NULL; /* initially empty */ +/* List of objects that have been unloaded via unloadObj(), but are waiting + to be actually freed via checkUnload() */ +ObjectCode *unloaded_objects = NULL; /* initially empty */ + static HsInt loadOc( ObjectCode* oc ); static ObjectCode* mkOc( pathchar *path, char *image, int imageSize, char *archiveMemberName @@ -229,6 +233,8 @@ static void machoInitSymbolsWithoutUnderscore( void ); #endif #endif +static void freeProddableBlocks (ObjectCode *oc); + /* on x86_64 we have a problem with relocating symbol references in * code that was compiled without -fPIC. By default, the small memory * model is used, which assumes that symbol references can fit in a @@ -321,7 +327,7 @@ typedef struct _RtsSymbolVal { #define Maybe_Stable_Names SymI_HasProto(stg_mkWeakzh) \ SymI_HasProto(stg_mkWeakNoFinalizzerzh) \ - SymI_HasProto(stg_mkWeakForeignEnvzh) \ + SymI_HasProto(stg_addCFinalizzerToWeakzh) \ SymI_HasProto(stg_makeStableNamezh) \ SymI_HasProto(stg_finalizzeWeakzh) @@ -901,8 +907,10 @@ typedef struct _RtsSymbolVal { SymI_NeedsProto(top_ct) \ \ SymI_HasProto(ENT_VIA_NODE_ctr) \ - SymI_HasProto(ENT_STATIC_THK_ctr) \ - SymI_HasProto(ENT_DYN_THK_ctr) \ + SymI_HasProto(ENT_STATIC_THK_SINGLE_ctr) \ + SymI_HasProto(ENT_STATIC_THK_MANY_ctr) \ + SymI_HasProto(ENT_DYN_THK_SINGLE_ctr) \ + SymI_HasProto(ENT_DYN_THK_MANY_ctr) \ SymI_HasProto(ENT_STATIC_FUN_DIRECT_ctr) \ SymI_HasProto(ENT_DYN_FUN_DIRECT_ctr) \ SymI_HasProto(ENT_STATIC_CON_ctr) \ @@ -970,8 +978,6 @@ typedef struct _RtsSymbolVal { SymI_HasProto(UPD_NEW_PERM_IND_ctr) \ SymI_HasProto(UPD_OLD_IND_ctr) \ SymI_HasProto(UPD_OLD_PERM_IND_ctr) \ - SymI_HasProto(UPD_BH_UPDATABLE_ctr) \ - SymI_HasProto(UPD_BH_SINGLE_ENTRY_ctr) \ SymI_HasProto(UPD_CAF_BH_UPDATABLE_ctr) \ SymI_HasProto(UPD_CAF_BH_SINGLE_ENTRY_ctr) \ SymI_HasProto(GC_SEL_ABANDONED_ctr) \ @@ -1058,6 +1064,7 @@ typedef struct _RtsSymbolVal { SymI_HasProto(stg_yield_to_interpreter) \ SymI_HasProto(stg_block_noregs) \ SymI_HasProto(stg_block_takemvar) \ + SymI_HasProto(stg_block_readmvar) \ SymI_HasProto(stg_block_putmvar) \ MAIN_CAP_SYM \ SymI_HasProto(MallocFailHook) \ @@ -1067,7 +1074,6 @@ typedef struct _RtsSymbolVal { SymI_HasProto(addDLL) \ SymI_HasProto(__int_encodeDouble) \ SymI_HasProto(__word_encodeDouble) \ - SymI_HasProto(__2Int_encodeDouble) \ SymI_HasProto(__int_encodeFloat) \ SymI_HasProto(__word_encodeFloat) \ SymI_HasProto(stg_atomicallyzh) \ @@ -1106,9 +1112,9 @@ typedef struct _RtsSymbolVal { SymI_HasProto(getOrSetSystemEventThreadIOManagerThreadStore) \ SymI_HasProto(getOrSetSystemTimerThreadEventManagerStore) \ SymI_HasProto(getOrSetSystemTimerThreadIOManagerThreadStore) \ + SymI_HasProto(getOrSetLibHSghcFastStringTable) \ SymI_HasProto(getGCStats) \ SymI_HasProto(getGCStatsEnabled) \ - SymI_HasProto(genSymZh) \ SymI_HasProto(genericRaise) \ SymI_HasProto(getProgArgv) \ SymI_HasProto(getFullProgArgv) \ @@ -1281,12 +1287,6 @@ typedef struct _RtsSymbolVal { SymI_HasProto(stg_ap_7_upd_info) \ SymI_HasProto(stg_exit) \ SymI_HasProto(stg_sel_0_upd_info) \ - SymI_HasProto(stg_sel_10_upd_info) \ - SymI_HasProto(stg_sel_11_upd_info) \ - SymI_HasProto(stg_sel_12_upd_info) \ - SymI_HasProto(stg_sel_13_upd_info) \ - SymI_HasProto(stg_sel_14_upd_info) \ - SymI_HasProto(stg_sel_15_upd_info) \ SymI_HasProto(stg_sel_1_upd_info) \ SymI_HasProto(stg_sel_2_upd_info) \ SymI_HasProto(stg_sel_3_upd_info) \ @@ -1296,13 +1296,37 @@ typedef struct _RtsSymbolVal { SymI_HasProto(stg_sel_7_upd_info) \ SymI_HasProto(stg_sel_8_upd_info) \ SymI_HasProto(stg_sel_9_upd_info) \ + SymI_HasProto(stg_sel_10_upd_info) \ + SymI_HasProto(stg_sel_11_upd_info) \ + SymI_HasProto(stg_sel_12_upd_info) \ + SymI_HasProto(stg_sel_13_upd_info) \ + SymI_HasProto(stg_sel_14_upd_info) \ + SymI_HasProto(stg_sel_15_upd_info) \ + SymI_HasProto(stg_sel_0_noupd_info) \ + SymI_HasProto(stg_sel_1_noupd_info) \ + SymI_HasProto(stg_sel_2_noupd_info) \ + SymI_HasProto(stg_sel_3_noupd_info) \ + SymI_HasProto(stg_sel_4_noupd_info) \ + SymI_HasProto(stg_sel_5_noupd_info) \ + SymI_HasProto(stg_sel_6_noupd_info) \ + SymI_HasProto(stg_sel_7_noupd_info) \ + SymI_HasProto(stg_sel_8_noupd_info) \ + SymI_HasProto(stg_sel_9_noupd_info) \ + SymI_HasProto(stg_sel_10_noupd_info) \ + SymI_HasProto(stg_sel_11_noupd_info) \ + SymI_HasProto(stg_sel_12_noupd_info) \ + SymI_HasProto(stg_sel_13_noupd_info) \ + SymI_HasProto(stg_sel_14_noupd_info) \ + SymI_HasProto(stg_sel_15_noupd_info) \ SymI_HasProto(stg_upd_frame_info) \ SymI_HasProto(stg_bh_upd_frame_info) \ SymI_HasProto(suspendThread) \ SymI_HasProto(stg_takeMVarzh) \ + SymI_HasProto(stg_readMVarzh) \ SymI_HasProto(stg_threadStatuszh) \ SymI_HasProto(stg_tryPutMVarzh) \ SymI_HasProto(stg_tryTakeMVarzh) \ + SymI_HasProto(stg_tryReadMVarzh) \ SymI_HasProto(stg_unmaskAsyncExceptionszh) \ SymI_HasProto(unloadObj) \ SymI_HasProto(stg_unsafeThawArrayzh) \ @@ -1500,6 +1524,9 @@ initLinker( void ) linker_init_done = 1; } + objects = NULL; + unloaded_objects = NULL; + #if defined(THREADED_RTS) && (defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO)) initMutex(&dl_mutex); #endif @@ -2026,6 +2053,40 @@ mmap_again: } #endif // USE_MMAP + +void freeObjectCode (ObjectCode *oc) +{ + int pagesize, size, r; + +#ifdef USE_MMAP + + pagesize = getpagesize(); + size = ROUND_UP(oc->fileSize, pagesize); + + r = munmap(oc->image, size); + if (r == -1) { + sysErrorBelch("munmap"); + } + + if (!USE_CONTIGUOUS_MMAP) + { + munmap(oc->symbol_extras, + ROUND_UP(sizeof(SymbolExtra) * oc->n_symbol_extras, pagesize)); + } + +#else + + stgFree(oc->image); + stgFree(oc->symbol_extras); + +#endif + + stgFree(oc->fileName); + stgFree(oc->archiveMemberName); + stgFree(oc); +} + + static ObjectCode* mkOc( pathchar *path, char *image, int imageSize, char *archiveMemberName @@ -2728,7 +2789,7 @@ resolveObjs( void ) HsInt unloadObj( pathchar *path ) { - ObjectCode *oc, *prev; + ObjectCode *oc, *prev, *next; HsBool unloadedAnyObj = HS_BOOL_FALSE; ASSERT(symhash != NULL); @@ -2736,8 +2797,12 @@ unloadObj( pathchar *path ) initLinker(); + IF_DEBUG(linker, debugBelch("unloadObj: %s\n", path)); + prev = NULL; - for (oc = objects; oc; prev = oc, oc = oc->next) { + for (oc = objects; oc; prev = oc, oc = next) { + next = oc->next; + if (!pathcmp(oc->fileName,path)) { /* Remove all the mappings for the symbols within this @@ -2757,22 +2822,27 @@ unloadObj( pathchar *path ) } else { prev->next = oc->next; } + oc->next = unloaded_objects; + unloaded_objects = oc; - // We're going to leave this in place, in case there are - // any pointers from the heap into it: - // #ifdef mingw32_HOST_OS - // If uncommenting, note that currently oc->image is - // not the right address to free on Win64, as we added - // 4 bytes of padding at the start - // VirtualFree(oc->image); - // #else - // stgFree(oc->image); - // #endif - stgFree(oc->fileName); - stgFree(oc->archiveMemberName); + // The data itself and a few other bits (oc->fileName, + // oc->archiveMemberName) are kept until freeObjectCode(), + // which is only called when it has been determined that + // it is safe to unload the object. stgFree(oc->symbols); - stgFree(oc->sections); - stgFree(oc); + + { + Section *s, *nexts; + + for (s = oc->sections; s != NULL; s = nexts) { + nexts = s->next; + stgFree(s); + } + } + + freeProddableBlocks(oc); + + oc->status = OBJECT_UNLOADED; /* This could be a member of an archive so continue * unloading other members. */ @@ -2822,6 +2892,17 @@ checkProddableBlock (ObjectCode *oc, void *addr, size_t size ) barf("checkProddableBlock: invalid fixup in runtime linker: %p", addr); } +static void freeProddableBlocks (ObjectCode *oc) +{ + ProddableBlock *pb, *next; + + for (pb = oc->proddables; pb != NULL; pb = next) { + next = pb->next; + stgFree(pb); + } + oc->proddables = NULL; +} + /* ----------------------------------------------------------------------------- * Section management. */ @@ -2910,6 +2991,7 @@ static int ocAllocateSymbolExtras( ObjectCode* oc, int count, int first ) memcpy(new, oc->image, oc->fileSize); munmap(oc->image, n); oc->image = new; + oc->fileSize = n + (sizeof(SymbolExtra) * count); oc->symbol_extras = (SymbolExtra *) (oc->image + n); } else @@ -4941,6 +5023,7 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC, // Generate veneer SymbolExtra *extra = makeArmSymbolExtra(oc, ELF_R_SYM(info), S+imm+4, 1, is_target_thm); offset = (StgWord32) &extra->jumpIsland - P - 4; + sign = offset >> 31; to_thm = 1; } else if (!is_target_thm && ELF_R_TYPE(info) == R_ARM_THM_CALL) { offset &= ~0x3; diff --git a/rts/LinkerInternals.h b/rts/LinkerInternals.h index 864e0d1f2f..753279d547 100644 --- a/rts/LinkerInternals.h +++ b/rts/LinkerInternals.h @@ -9,7 +9,11 @@ #ifndef LINKERINTERNALS_H #define LINKERINTERNALS_H -typedef enum { OBJECT_LOADED, OBJECT_RESOLVED } OStatus; +typedef enum { + OBJECT_LOADED, + OBJECT_RESOLVED, + OBJECT_UNLOADED +} OStatus; /* Indication of section kinds for loaded objects. Needed by the GC for deciding whether or not a pointer on the stack @@ -82,6 +86,9 @@ typedef struct _ObjectCode { /* ptr to malloc'd lump of memory holding the obj file */ char* image; + /* flag used when deciding whether to unload an object file */ + int referenced; + #ifdef darwin_HOST_OS /* record by how much image has been deliberately misaligned after allocation, so that we can use realloc */ @@ -121,7 +128,10 @@ typedef struct _ObjectCode { ) extern ObjectCode *objects; +extern ObjectCode *unloaded_objects; void exitLinker( void ); +void freeObjectCode (ObjectCode *oc); + #endif /* LINKERINTERNALS_H */ diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index f4e80e9c35..ced15eec99 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -160,16 +160,16 @@ stg_newArrayzh ( W_ n /* words */, gcptr init ) p = arr + SIZEOF_StgMutArrPtrs; for: if (p < arr + WDS(words)) { - W_[p] = init; - p = p + WDS(1); - goto for; + W_[p] = init; + p = p + WDS(1); + goto for; } // Initialise the mark bits with 0 for2: if (p < arr + WDS(size)) { - W_[p] = 0; - p = p + WDS(1); - goto for2; + W_[p] = 0; + p = p + WDS(1); + goto for2; } return (arr); @@ -179,11 +179,11 @@ stg_unsafeThawArrayzh ( gcptr arr ) { // SUBTLETY TO DO WITH THE OLD GEN MUTABLE LIST // - // A MUT_ARR_PTRS lives on the mutable list, but a MUT_ARR_PTRS_FROZEN + // A MUT_ARR_PTRS lives on the mutable list, but a MUT_ARR_PTRS_FROZEN // normally doesn't. However, when we freeze a MUT_ARR_PTRS, we leave // it on the mutable list for the GC to remove (removing something from // the mutable list is not easy). - // + // // So that we can tell whether a MUT_ARR_PTRS_FROZEN is on the mutable list, // when we freeze it we set the info ptr to be MUT_ARR_PTRS_FROZEN0 // to indicate that it is still on the mutable list. @@ -198,11 +198,11 @@ stg_unsafeThawArrayzh ( gcptr arr ) if (StgHeader_info(arr) != stg_MUT_ARR_PTRS_FROZEN0_info) { SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info); recordMutable(arr); - // must be done after SET_INFO, because it ASSERTs closure_MUTABLE() - return (arr); + // must be done after SET_INFO, because it ASSERTs closure_MUTABLE() + return (arr); } else { - SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info); - return (arr); + SET_INFO(arr,stg_MUT_ARR_PTRS_DIRTY_info); + return (arr); } } @@ -229,16 +229,16 @@ stg_newArrayArrayzh ( W_ n /* words */ ) p = arr + SIZEOF_StgMutArrPtrs; for: if (p < arr + WDS(words)) { - W_[p] = arr; - p = p + WDS(1); - goto for; + W_[p] = arr; + p = p + WDS(1); + goto for; } // Initialise the mark bits with 0 for2: if (p < arr + WDS(size)) { - W_[p] = 0; - p = p + WDS(1); - goto for2; + W_[p] = 0; + p = p + WDS(1); + goto for2; } return (arr); @@ -258,7 +258,7 @@ stg_newMutVarzh ( gcptr init ) mv = Hp - SIZEOF_StgMutVar + WDS(1); SET_HDR(mv,stg_MUT_VAR_DIRTY_info,CCCS); StgMutVar_var(mv) = init; - + return (mv); } @@ -283,19 +283,19 @@ stg_atomicModifyMutVarzh ( gcptr mv, gcptr f ) { W_ z, x, y, r, h; - /* If x is the current contents of the MutVar#, then + /* If x is the current contents of the MutVar#, then We want to make the new contents point to (sel_0 (f x)) - + and the return value is - - (sel_1 (f x)) + + (sel_1 (f x)) obviously we can share (f x). z = [stg_ap_2 f x] (max (HS + 2) MIN_UPD_SIZE) - y = [stg_sel_0 z] (max (HS + 1) MIN_UPD_SIZE) + y = [stg_sel_0 z] (max (HS + 1) MIN_UPD_SIZE) r = [stg_sel_1 z] (max (HS + 1) MIN_UPD_SIZE) */ @@ -374,18 +374,14 @@ stg_mkWeakzh ( gcptr key, w = Hp - SIZEOF_StgWeak + WDS(1); SET_HDR(w, stg_WEAK_info, CCCS); - // We don't care about cfinalizer here. - // Should StgWeak_cfinalizer(w) be stg_NO_FINALIZER_closure or - // something else? - - StgWeak_key(w) = key; - StgWeak_value(w) = value; - StgWeak_finalizer(w) = finalizer; - StgWeak_cfinalizer(w) = stg_NO_FINALIZER_closure; + StgWeak_key(w) = key; + StgWeak_value(w) = value; + StgWeak_finalizer(w) = finalizer; + StgWeak_cfinalizers(w) = stg_NO_FINALIZER_closure; ACQUIRE_LOCK(sm_mutex); - StgWeak_link(w) = W_[weak_ptr_list]; - W_[weak_ptr_list] = w; + StgWeak_link(w) = generation_weak_ptr_list(W_[g0]); + generation_weak_ptr_list(W_[g0]) = w; RELEASE_LOCK(sm_mutex); IF_DEBUG(weak, ccall debugBelch(stg_weak_msg,w)); @@ -398,61 +394,62 @@ stg_mkWeakNoFinalizzerzh ( gcptr key, gcptr value ) jump stg_mkWeakzh (key, value, stg_NO_FINALIZER_closure); } -stg_mkWeakForeignEnvzh ( gcptr key, - gcptr val, - W_ fptr, // finalizer - W_ ptr, - W_ flag, // has environment (0 or 1) - W_ eptr ) +STRING(stg_cfinalizer_msg,"Adding a finalizer to %p\n") + +stg_addCFinalizzerToWeakzh ( W_ fptr, // finalizer + W_ ptr, + W_ flag, // has environment (0 or 1) + W_ eptr, + gcptr w ) { - W_ payload_words, words; - gcptr w, p; + W_ c, info; - ALLOC_PRIM (SIZEOF_StgWeak); + LOCK_CLOSURE(w, info); - w = Hp - SIZEOF_StgWeak + WDS(1); - SET_HDR(w, stg_WEAK_info, CCCS); + if (info == stg_DEAD_WEAK_info) { + // Already dead. + unlockClosure(w, info); + return (0); + } - payload_words = 4; - words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words; - ("ptr" p) = ccall allocate(MyCapability() "ptr", words); + ALLOC_PRIM (SIZEOF_StgCFinalizerList) - TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0); - SET_HDR(p, stg_ARR_WORDS_info, CCCS); + c = Hp - SIZEOF_StgCFinalizerList + WDS(1); + SET_HDR(c, stg_C_FINALIZER_LIST_info, CCCS); - StgArrWords_bytes(p) = WDS(payload_words); - StgArrWords_payload(p,0) = fptr; - StgArrWords_payload(p,1) = ptr; - StgArrWords_payload(p,2) = eptr; - StgArrWords_payload(p,3) = flag; + StgCFinalizerList_fptr(c) = fptr; + StgCFinalizerList_ptr(c) = ptr; + StgCFinalizerList_eptr(c) = eptr; + StgCFinalizerList_flag(c) = flag; - // We don't care about the value here. - // Should StgWeak_value(w) be stg_NO_FINALIZER_closure or something else? + StgCFinalizerList_link(c) = StgWeak_cfinalizers(w); + StgWeak_cfinalizers(w) = c; - StgWeak_key(w) = key; - StgWeak_value(w) = val; - StgWeak_finalizer(w) = stg_NO_FINALIZER_closure; - StgWeak_cfinalizer(w) = p; + unlockClosure(w, info); - ACQUIRE_LOCK(sm_mutex); - StgWeak_link(w) = W_[weak_ptr_list]; - W_[weak_ptr_list] = w; - RELEASE_LOCK(sm_mutex); + recordMutable(w); - IF_DEBUG(weak, ccall debugBelch(stg_weak_msg,w)); + IF_DEBUG(weak, ccall debugBelch(stg_cfinalizer_msg,w)); - return (w); + return (1); } stg_finalizzeWeakzh ( gcptr w ) { - gcptr f, arr; + gcptr f, list; + W_ info; + + LOCK_CLOSURE(w, info); // already dead? - if (GET_INFO(w) == stg_DEAD_WEAK_info) { + if (info == stg_DEAD_WEAK_info) { + unlockClosure(w, info); return (0,stg_NO_FINALIZER_closure); } + f = StgWeak_finalizer(w); + list = StgWeak_cfinalizers(w); + // kill it #ifdef PROFILING // @LDV profiling @@ -461,7 +458,7 @@ stg_finalizzeWeakzh ( gcptr w ) // LDV_recordDead_FILL_SLOP_DYNAMIC((StgClosure *)w); // or, LDV_recordDead(): // LDV_recordDead((StgClosure *)w, sizeofW(StgWeak) - sizeofW(StgProfHeader)); - // Furthermore, when PROFILING is turned on, dead weak pointers are exactly as + // Furthermore, when PROFILING is turned on, dead weak pointers are exactly as // large as weak pointers, so there is no need to fill the slop, either. // See stg_DEAD_WEAK_info in StgMiscClosures.hc. #endif @@ -469,19 +466,12 @@ stg_finalizzeWeakzh ( gcptr w ) // // Todo: maybe use SET_HDR() and remove LDV_recordCreate()? // - SET_INFO(w,stg_DEAD_WEAK_info); - LDV_RECORD_CREATE(w); - - f = StgWeak_finalizer(w); - arr = StgWeak_cfinalizer(w); + unlockClosure(w, stg_DEAD_WEAK_info); - StgDeadWeak_link(w) = StgWeak_link(w); + LDV_RECORD_CREATE(w); - if (arr != stg_NO_FINALIZER_closure) { - ccall runCFinalizer(StgArrWords_payload(arr,0), - StgArrWords_payload(arr,1), - StgArrWords_payload(arr,2), - StgArrWords_payload(arr,3)); + if (list != stg_NO_FINALIZER_closure) { + ccall runCFinalizers(list); } /* return the finalizer */ @@ -494,10 +484,21 @@ stg_finalizzeWeakzh ( gcptr w ) stg_deRefWeakzh ( gcptr w ) { - W_ code; + W_ code, info; gcptr val; - if (GET_INFO(w) == stg_WEAK_info) { + info = GET_INFO(w); + + if (info == stg_WHITEHOLE_info) { + // w is locked by another thread. Now it's not immediately clear if w is + // alive or not. We use lockClosure to wait for the info pointer to become + // something other than stg_WHITEHOLE_info. + + LOCK_CLOSURE(w, info); + unlockClosure(w, info); + } + + if (info == stg_WEAK_info) { code = 1; val = StgWeak_value(w); } else { @@ -512,7 +513,7 @@ stg_deRefWeakzh ( gcptr w ) -------------------------------------------------------------------------- */ stg_decodeFloatzuIntzh ( F_ arg ) -{ +{ W_ p; W_ mp_tmp1; W_ mp_tmp_w; @@ -521,16 +522,16 @@ stg_decodeFloatzuIntzh ( F_ arg ) mp_tmp1 = Sp - WDS(1); mp_tmp_w = Sp - WDS(2); - + /* Perform the operation */ ccall __decodeFloat_Int(mp_tmp1 "ptr", mp_tmp_w "ptr", arg); - + /* returns: (Int# (mantissa), Int# (exponent)) */ return (W_[mp_tmp1], W_[mp_tmp_w]); } stg_decodeDoublezu2Intzh ( D_ arg ) -{ +{ W_ p; W_ mp_tmp1; W_ mp_tmp2; @@ -564,13 +565,13 @@ stg_forkzh ( gcptr closure ) gcptr threadid; - ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr", - RtsFlags_GcFlags_initialStkSize(RtsFlags), + ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr", + RtsFlags_GcFlags_initialStkSize(RtsFlags), closure "ptr"); /* start blocked if the current thread is blocked */ StgTSO_flags(threadid) = %lobits16( - TO_W_(StgTSO_flags(threadid)) | + TO_W_(StgTSO_flags(threadid)) | TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE)); ccall scheduleThread(MyCapability() "ptr", threadid "ptr"); @@ -578,7 +579,7 @@ stg_forkzh ( gcptr closure ) // context switch soon, but not immediately: we don't want every // forkIO to force a context-switch. Capability_context_switch(MyCapability()) = 1 :: CInt; - + return (threadid); } @@ -588,13 +589,13 @@ again: MAYBE_GC(again); gcptr threadid; - ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr", - RtsFlags_GcFlags_initialStkSize(RtsFlags), + ("ptr" threadid) = ccall createIOThread( MyCapability() "ptr", + RtsFlags_GcFlags_initialStkSize(RtsFlags), closure "ptr"); /* start blocked if the current thread is blocked */ StgTSO_flags(threadid) = %lobits16( - TO_W_(StgTSO_flags(threadid)) | + TO_W_(StgTSO_flags(threadid)) | TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE)); ccall scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr"); @@ -602,7 +603,7 @@ again: MAYBE_GC(again); // context switch soon, but not immediately: we don't want every // forkIO to force a context-switch. Capability_context_switch(MyCapability()) = 1 :: CInt; - + return (threadid); } @@ -1014,7 +1015,7 @@ retry_pop_stack: } } - // We've reached the ATOMICALLY_FRAME: attempt to wait + // We've reached the ATOMICALLY_FRAME: attempt to wait ASSERT(frame_type == ATOMICALLY_FRAME); if (outer != NO_TREC) { // We called retry while checking invariants, so abort the current @@ -1152,9 +1153,9 @@ stg_writeTVarzh (P_ tvar, /* :: TVar a */ stg_isEmptyMVarzh ( P_ mvar /* :: MVar a */ ) { if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) { - return (1); + return (1); } else { - return (0); + return (0); } } @@ -1163,7 +1164,7 @@ stg_newMVarzh () W_ mvar; ALLOC_PRIM_ (SIZEOF_StgMVar, stg_newMVarzh); - + mvar = Hp - SIZEOF_StgMVar + WDS(1); SET_HDR(mvar,stg_MVAR_DIRTY_info,CCCS); // MVARs start dirty: generation 0 has no mutable list @@ -1191,21 +1192,16 @@ stg_takeMVarzh ( P_ mvar /* :: MVar a */ ) { W_ val, info, tso, q; -#if defined(THREADED_RTS) - ("ptr" info) = ccall lockClosure(mvar "ptr"); -#else - info = GET_INFO(mvar); -#endif - - if (info == stg_MVAR_CLEAN_info) { - ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); - } + LOCK_CLOSURE(mvar, info); /* If the MVar is empty, put ourselves on its blocking queue, * and wait until we're woken up. */ if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) { - + if (info == stg_MVAR_CLEAN_info) { + ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); + } + // We want to put the heap check down here in the slow path, // but be careful to unlock the closure before returning to // the RTS if the check fails. @@ -1220,30 +1216,32 @@ stg_takeMVarzh ( P_ mvar /* :: MVar a */ ) StgMVarTSOQueue_link(q) = END_TSO_QUEUE; StgMVarTSOQueue_tso(q) = CurrentTSO; - if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { - StgMVar_head(mvar) = q; - } else { + if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { + StgMVar_head(mvar) = q; + } else { StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q; ccall recordClosureMutated(MyCapability() "ptr", StgMVar_tail(mvar)); - } - StgTSO__link(CurrentTSO) = q; - StgTSO_block_info(CurrentTSO) = mvar; - StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16; - StgMVar_tail(mvar) = q; - + } + StgTSO__link(CurrentTSO) = q; + StgTSO_block_info(CurrentTSO) = mvar; + StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16; + StgMVar_tail(mvar) = q; + jump stg_block_takemvar(mvar); } - + /* we got the value... */ val = StgMVar_value(mvar); - + q = StgMVar_head(mvar); loop: if (q == stg_END_TSO_QUEUE_closure) { /* No further putMVars, MVar is now empty */ StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure; - unlockClosure(mvar, stg_MVAR_DIRTY_info); + // If the MVar is not already dirty, then we don't need to make + // it dirty, as it is empty with nothing blocking on it. + unlockClosure(mvar, info); return (val); } if (StgHeader_info(q) == stg_IND_info || @@ -1251,9 +1249,13 @@ loop: q = StgInd_indirectee(q); goto loop; } - + // There are putMVar(s) waiting... wake up the first thread on the queue - + + if (info == stg_MVAR_CLEAN_info) { + ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); + } + tso = StgMVarTSOQueue_tso(q); StgMVar_head(mvar) = StgMVarTSOQueue_link(q); if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { @@ -1270,11 +1272,11 @@ loop: // indicate that the MVar operation has now completed. StgTSO__link(tso) = stg_END_TSO_QUEUE_closure; - + // no need to mark the TSO dirty, we have only written END_TSO_QUEUE. ccall tryWakeupThread(MyCapability() "ptr", tso); - + unlockClosure(mvar, stg_MVAR_DIRTY_info); return (val); } @@ -1283,48 +1285,43 @@ stg_tryTakeMVarzh ( P_ mvar /* :: MVar a */ ) { W_ val, info, tso, q; -#if defined(THREADED_RTS) - ("ptr" info) = ccall lockClosure(mvar "ptr"); -#else - info = GET_INFO(mvar); -#endif - - /* If the MVar is empty, put ourselves on its blocking queue, - * and wait until we're woken up. - */ + LOCK_CLOSURE(mvar, info); + + /* If the MVar is empty, return 0. */ if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) { #if defined(THREADED_RTS) unlockClosure(mvar, info); #endif - /* HACK: we need a pointer to pass back, - * so we abuse NO_FINALIZER_closure - */ - return (0, stg_NO_FINALIZER_closure); - } - - if (info == stg_MVAR_CLEAN_info) { - ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); + /* HACK: we need a pointer to pass back, + * so we abuse NO_FINALIZER_closure + */ + return (0, stg_NO_FINALIZER_closure); } /* we got the value... */ val = StgMVar_value(mvar); - + q = StgMVar_head(mvar); loop: if (q == stg_END_TSO_QUEUE_closure) { /* No further putMVars, MVar is now empty */ StgMVar_value(mvar) = stg_END_TSO_QUEUE_closure; - unlockClosure(mvar, stg_MVAR_DIRTY_info); + unlockClosure(mvar, info); return (1, val); } + if (StgHeader_info(q) == stg_IND_info || StgHeader_info(q) == stg_MSG_NULL_info) { q = StgInd_indirectee(q); goto loop; } - + // There are putMVar(s) waiting... wake up the first thread on the queue - + + if (info == stg_MVAR_CLEAN_info) { + ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); + } + tso = StgMVarTSOQueue_tso(q); StgMVar_head(mvar) = StgMVarTSOQueue_link(q); if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { @@ -1341,11 +1338,11 @@ loop: // indicate that the MVar operation has now completed. StgTSO__link(tso) = stg_END_TSO_QUEUE_closure; - + // no need to mark the TSO dirty, we have only written END_TSO_QUEUE. ccall tryWakeupThread(MyCapability() "ptr", tso); - + unlockClosure(mvar, stg_MVAR_DIRTY_info); return (1,val); } @@ -1355,18 +1352,14 @@ stg_putMVarzh ( P_ mvar, /* :: MVar a */ { W_ info, tso, q; -#if defined(THREADED_RTS) - ("ptr" info) = ccall lockClosure(mvar "ptr"); -#else - info = GET_INFO(mvar); -#endif - - if (info == stg_MVAR_CLEAN_info) { - ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); - } + LOCK_CLOSURE(mvar, info); if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) { + if (info == stg_MVAR_CLEAN_info) { + ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); + } + // We want to put the heap check down here in the slow path, // but be careful to unlock the closure before returning to // the RTS if the check fails. @@ -1381,27 +1374,30 @@ stg_putMVarzh ( P_ mvar, /* :: MVar a */ StgMVarTSOQueue_link(q) = END_TSO_QUEUE; StgMVarTSOQueue_tso(q) = CurrentTSO; - if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { - StgMVar_head(mvar) = q; - } else { + if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { + StgMVar_head(mvar) = q; + } else { StgMVarTSOQueue_link(StgMVar_tail(mvar)) = q; ccall recordClosureMutated(MyCapability() "ptr", StgMVar_tail(mvar)); - } - StgTSO__link(CurrentTSO) = q; - StgTSO_block_info(CurrentTSO) = mvar; - StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16; - StgMVar_tail(mvar) = q; + } + StgTSO__link(CurrentTSO) = q; + StgTSO_block_info(CurrentTSO) = mvar; + StgTSO_why_blocked(CurrentTSO) = BlockedOnMVar::I16; + StgMVar_tail(mvar) = q; jump stg_block_putmvar(mvar,val); } - + q = StgMVar_head(mvar); loop: if (q == stg_END_TSO_QUEUE_closure) { - /* No further takes, the MVar is now full. */ - StgMVar_value(mvar) = val; - unlockClosure(mvar, stg_MVAR_DIRTY_info); + /* No further takes, the MVar is now full. */ + if (info == stg_MVAR_CLEAN_info) { + ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); + } + StgMVar_value(mvar) = val; + unlockClosure(mvar, stg_MVAR_DIRTY_info); return (); } if (StgHeader_info(q) == stg_IND_info || @@ -1410,16 +1406,19 @@ loop: goto loop; } - // There are takeMVar(s) waiting: wake up the first one - + // There are readMVar/takeMVar(s) waiting: wake up the first one + tso = StgMVarTSOQueue_tso(q); StgMVar_head(mvar) = StgMVarTSOQueue_link(q); if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure; } - ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16); ASSERT(StgTSO_block_info(tso) == mvar); + // save why_blocked here, because waking up the thread destroys + // this information + W_ why_blocked; + why_blocked = TO_W_(StgTSO_why_blocked(tso)); // actually perform the takeMVar W_ stack; @@ -1432,10 +1431,19 @@ loop: if (TO_W_(StgStack_dirty(stack)) == 0) { ccall dirty_STACK(MyCapability() "ptr", stack "ptr"); } - + ccall tryWakeupThread(MyCapability() "ptr", tso); - unlockClosure(mvar, stg_MVAR_DIRTY_info); + // If it was an readMVar, then we can still do work, + // so loop back. (XXX: This could take a while) + if (why_blocked == BlockedOnMVarRead) { + q = StgMVarTSOQueue_link(q); + goto loop; + } + + ASSERT(why_blocked == BlockedOnMVar); + + unlockClosure(mvar, info); return (); } @@ -1445,29 +1453,25 @@ stg_tryPutMVarzh ( P_ mvar, /* :: MVar a */ { W_ info, tso, q; -#if defined(THREADED_RTS) - ("ptr" info) = ccall lockClosure(mvar "ptr"); -#else - info = GET_INFO(mvar); -#endif + LOCK_CLOSURE(mvar, info); if (StgMVar_value(mvar) != stg_END_TSO_QUEUE_closure) { #if defined(THREADED_RTS) - unlockClosure(mvar, info); + unlockClosure(mvar, info); #endif - return (0); - } - - if (info == stg_MVAR_CLEAN_info) { - ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); + return (0); } q = StgMVar_head(mvar); loop: if (q == stg_END_TSO_QUEUE_closure) { - /* No further takes, the MVar is now full. */ - StgMVar_value(mvar) = val; - unlockClosure(mvar, stg_MVAR_DIRTY_info); + /* No further takes, the MVar is now full. */ + if (info == stg_MVAR_CLEAN_info) { + ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); + } + + StgMVar_value(mvar) = val; + unlockClosure(mvar, stg_MVAR_DIRTY_info); return (1); } if (StgHeader_info(q) == stg_IND_info || @@ -1477,15 +1481,18 @@ loop: } // There are takeMVar(s) waiting: wake up the first one - + tso = StgMVarTSOQueue_tso(q); StgMVar_head(mvar) = StgMVarTSOQueue_link(q); if (StgMVar_head(mvar) == stg_END_TSO_QUEUE_closure) { StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure; } - ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16); ASSERT(StgTSO_block_info(tso) == mvar); + // save why_blocked here, because waking up the thread destroys + // this information + W_ why_blocked; + why_blocked = TO_W_(StgTSO_why_blocked(tso)); // actually perform the takeMVar W_ stack; @@ -1494,17 +1501,87 @@ loop: // indicate that the MVar operation has now completed. StgTSO__link(tso) = stg_END_TSO_QUEUE_closure; - + if (TO_W_(StgStack_dirty(stack)) == 0) { ccall dirty_STACK(MyCapability() "ptr", stack "ptr"); } - + ccall tryWakeupThread(MyCapability() "ptr", tso); - unlockClosure(mvar, stg_MVAR_DIRTY_info); + // If it was an readMVar, then we can still do work, + // so loop back. (XXX: This could take a while) + if (why_blocked == BlockedOnMVarRead) { + q = StgMVarTSOQueue_link(q); + goto loop; + } + + ASSERT(why_blocked == BlockedOnMVar); + + unlockClosure(mvar, info); return (1); } +stg_readMVarzh ( P_ mvar, /* :: MVar a */ ) +{ + W_ val, info, tso, q; + + LOCK_CLOSURE(mvar, info); + + /* If the MVar is empty, put ourselves on the blocked readers + * list and wait until we're woken up. + */ + if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) { + + if (info == stg_MVAR_CLEAN_info) { + ccall dirty_MVAR(BaseReg "ptr", mvar "ptr"); + } + + ALLOC_PRIM_WITH_CUSTOM_FAILURE + (SIZEOF_StgMVarTSOQueue, + unlockClosure(mvar, stg_MVAR_DIRTY_info); + GC_PRIM_P(stg_readMVarzh, mvar)); + + q = Hp - SIZEOF_StgMVarTSOQueue + WDS(1); + + // readMVars are pushed to the front of the queue, so + // they get handled immediately + SET_HDR(q, stg_MVAR_TSO_QUEUE_info, CCS_SYSTEM); + StgMVarTSOQueue_link(q) = StgMVar_head(mvar); + StgMVarTSOQueue_tso(q) = CurrentTSO; + + StgTSO__link(CurrentTSO) = q; + StgTSO_block_info(CurrentTSO) = mvar; + StgTSO_why_blocked(CurrentTSO) = BlockedOnMVarRead::I16; + StgMVar_head(mvar) = q; + + if (StgMVar_tail(mvar) == stg_END_TSO_QUEUE_closure) { + StgMVar_tail(mvar) = q; + } + + jump stg_block_readmvar(mvar); + } + + val = StgMVar_value(mvar); + + unlockClosure(mvar, info); + return (val); +} + +stg_tryReadMVarzh ( P_ mvar, /* :: MVar a */ ) +{ + W_ val, info, tso, q; + + LOCK_CLOSURE(mvar, info); + + if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) { + return (0, stg_NO_FINALIZER_closure); + } + + val = StgMVar_value(mvar); + + unlockClosure(mvar, info); + return (1, val); +} /* ----------------------------------------------------------------------------- Stable pointer primitives @@ -1566,23 +1643,23 @@ stg_newBCOzh ( P_ instrs, bco = Hp - bytes + WDS(1); SET_HDR(bco, stg_BCO_info, CCCS); - + StgBCO_instrs(bco) = instrs; StgBCO_literals(bco) = literals; StgBCO_ptrs(bco) = ptrs; StgBCO_arity(bco) = HALF_W_(arity); StgBCO_size(bco) = HALF_W_(words); - + // Copy the arity/bitmap info into the BCO W_ i; i = 0; for: if (i < BYTE_ARR_WDS(bitmap_arr)) { - StgBCO_bitmap(bco,i) = StgArrWords_payload(bitmap_arr,i); - i = i + 1; - goto for; + StgBCO_bitmap(bco,i) = StgArrWords_payload(bitmap_arr,i); + i = i + 1; + goto for; } - + return (bco); } @@ -1602,10 +1679,10 @@ stg_mkApUpd0zh ( P_ bco ) ap = Hp - SIZEOF_StgAP + WDS(1); SET_HDR(ap, stg_AP_info, CCCS); - + StgAP_n_args(ap) = HALF_W_(0); StgAP_fun(ap) = bco; - + return (ap); } @@ -1625,14 +1702,14 @@ stg_unpackClosurezh ( P_ closure ) nptrs = 0; goto out; } - case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1, + case THUNK, THUNK_1_0, THUNK_0_1, THUNK_2_0, THUNK_1_1, THUNK_0_2, THUNK_STATIC, AP, PAP, AP_STACK, BCO : { ptrs = 0; nptrs = 0; goto out; } default: { - ptrs = TO_W_(%INFO_PTRS(info)); + ptrs = TO_W_(%INFO_PTRS(info)); nptrs = TO_W_(%INFO_NPTRS(info)); goto out; }} @@ -1658,22 +1735,22 @@ out: p = 0; for: if(p < ptrs) { - W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(clos,p); - p = p + 1; - goto for; + W_[ptrs_arr + SIZEOF_StgMutArrPtrs + WDS(p)] = StgClosure_payload(clos,p); + p = p + 1; + goto for; } /* We can leave the card table uninitialised, since the array is allocated in the nursery. The GC will fill it in if/when the array is promoted. */ - + SET_HDR(nptrs_arr, stg_ARR_WORDS_info, CCCS); StgArrWords_bytes(nptrs_arr) = WDS(nptrs); p = 0; for2: if(p < nptrs) { - W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(clos, p+ptrs); - p = p + 1; - goto for2; + W_[BYTE_ARR_CTS(nptrs_arr) + WDS(p)] = StgClosure_payload(clos, p+ptrs); + p = p + 1; + goto for2; } return (info, ptrs_arr, nptrs_arr); } @@ -1685,13 +1762,13 @@ for2: /* Add a thread to the end of the blocked queue. (C-- version of the C * macro in Schedule.h). */ -#define APPEND_TO_BLOCKED_QUEUE(tso) \ - ASSERT(StgTSO__link(tso) == END_TSO_QUEUE); \ - if (W_[blocked_queue_hd] == END_TSO_QUEUE) { \ - W_[blocked_queue_hd] = tso; \ - } else { \ +#define APPEND_TO_BLOCKED_QUEUE(tso) \ + ASSERT(StgTSO__link(tso) == END_TSO_QUEUE); \ + if (W_[blocked_queue_hd] == END_TSO_QUEUE) { \ + W_[blocked_queue_hd] = tso; \ + } else { \ ccall setTSOLink(MyCapability() "ptr", W_[blocked_queue_tl] "ptr", tso); \ - } \ + } \ W_[blocked_queue_tl] = tso; stg_waitReadzh ( W_ fd ) @@ -1748,7 +1825,7 @@ stg_delayzh ( W_ us_delay ) /* could probably allocate this on the heap instead */ ("ptr" ares) = ccall stgMallocBytes(SIZEOF_StgAsyncIOResult, - stg_delayzh_malloc_str); + stg_delayzh_malloc_str); (reqID) = ccall addDelayRequest(us_delay); StgAsyncIOResult_reqID(ares) = reqID; StgAsyncIOResult_len(ares) = 0; @@ -1775,14 +1852,14 @@ stg_delayzh ( W_ us_delay ) t = W_[sleeping_queue]; while: if (t != END_TSO_QUEUE && StgTSO_block_info(t) < target) { - prev = t; - t = StgTSO__link(t); - goto while; + prev = t; + t = StgTSO__link(t); + goto while; } StgTSO__link(CurrentTSO) = t; if (prev == NULL) { - W_[sleeping_queue] = CurrentTSO; + W_[sleeping_queue] = CurrentTSO; } else { ccall setTSOLink(MyCapability() "ptr", prev "ptr", CurrentTSO); } @@ -1896,7 +1973,7 @@ stg_asyncDoProczh ( W_ proc, W_ param ) * | -------+-----> A <-------+------- | * | update | BLACKHOLE | marked_update | * +-----------+ +---------------+ - * | | | | + * | | | | * ... ... * | | +---------------+ * +-----------+ @@ -1941,7 +2018,7 @@ stg_noDuplicatezh /* no arg list: explicit stack layout */ SAVE_THREAD_STATE(); ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16); ccall threadPaused (MyCapability() "ptr", CurrentTSO "ptr"); - + if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) { jump stg_threadFinished []; } else { diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c index 11f518a87d..edc4a91193 100644 --- a/rts/RaiseAsync.c +++ b/rts/RaiseAsync.c @@ -294,6 +294,7 @@ check_target: } case BlockedOnMVar: + case BlockedOnMVarRead: { /* To establish ownership of this TSO, we need to acquire a @@ -318,7 +319,7 @@ check_target: // we have the MVar, let's check whether the thread // is still blocked on the same MVar. - if (target->why_blocked != BlockedOnMVar + if ((target->why_blocked != BlockedOnMVar && target->why_blocked != BlockedOnMVarRead) || (StgMVar *)target->block_info.closure != mvar) { unlockClosure((StgClosure *)mvar, info); goto retry; @@ -637,6 +638,7 @@ removeFromQueues(Capability *cap, StgTSO *tso) goto done; case BlockedOnMVar: + case BlockedOnMVarRead: removeFromMVarBlockedQueue(tso); goto done; diff --git a/rts/RaiseAsync.h b/rts/RaiseAsync.h index 336ab30e33..d804f6bc64 100644 --- a/rts/RaiseAsync.h +++ b/rts/RaiseAsync.h @@ -49,6 +49,7 @@ interruptible(StgTSO *t) { switch (t->why_blocked) { case BlockedOnMVar: + case BlockedOnMVarRead: case BlockedOnMsgThrowTo: case BlockedOnRead: case BlockedOnWrite: diff --git a/rts/RetainerProfile.c b/rts/RetainerProfile.c index 4e7ed3e222..dc21149d98 100644 --- a/rts/RetainerProfile.c +++ b/rts/RetainerProfile.c @@ -1672,6 +1672,7 @@ inner_loop: retainClosure(tso->bq, c, c_child_r); retainClosure(tso->trec, c, c_child_r); if ( tso->why_blocked == BlockedOnMVar + || tso->why_blocked == BlockedOnMVarRead || tso->why_blocked == BlockedOnBlackHole || tso->why_blocked == BlockedOnMsgThrowTo ) { @@ -1767,9 +1768,12 @@ computeRetainerSet( void ) // // The following code assumes that WEAK objects are considered to be roots // for retainer profilng. - for (weak = weak_ptr_list; weak != NULL; weak = weak->link) - // retainRoot((StgClosure *)weak); - retainRoot(NULL, (StgClosure **)&weak); + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { + for (weak = generations[g].weak_ptr_list; weak != NULL; weak = weak->link) { + // retainRoot((StgClosure *)weak); + retainRoot(NULL, (StgClosure **)&weak); + } + } // Consider roots from the stable ptr table. markStableTables(retainRoot, NULL); diff --git a/rts/RtsAPI.c b/rts/RtsAPI.c index ec19b169b6..720b732323 100644 --- a/rts/RtsAPI.c +++ b/rts/RtsAPI.c @@ -522,7 +522,16 @@ rts_checkSchedStatus (char* site, Capability *cap) stg_exit(EXIT_FAILURE); case Interrupted: errorBelch("%s: interrupted", site); - stg_exit(EXIT_FAILURE); +#ifdef THREADED_RTS + // The RTS is shutting down, and the process will probably + // soon exit. We don't want to preempt the shutdown + // by exiting the whole process here, so we just terminate the + // current thread. Don't forget to release the cap first though. + rts_unlock(cap); + shutdownThread(); +#else + stg_exit(EXIT_FAILURE); +#endif default: errorBelch("%s: Return code (%d) not ok",(site),(rc)); stg_exit(EXIT_FAILURE); diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c index 3f38c8ac1f..1e541a0201 100644 --- a/rts/RtsFlags.c +++ b/rts/RtsFlags.c @@ -52,7 +52,7 @@ wchar_t **win32_prog_argv = NULL; #endif /* - * constants, used later + * constants, used later */ #define RTS 1 #define PGM 0 @@ -111,9 +111,6 @@ void initRtsFlagsDefaults(void) RtsFlags.GcFlags.compact = rtsFalse; RtsFlags.GcFlags.compactThreshold = 30.0; RtsFlags.GcFlags.sweep = rtsFalse; -#ifdef RTS_GTK_FRONTPANEL - RtsFlags.GcFlags.frontpanel = rtsFalse; -#endif RtsFlags.GcFlags.idleGCDelayTime = USToTime(300000); // 300ms #ifdef THREADED_RTS RtsFlags.GcFlags.doIdleGC = rtsTrue; @@ -260,9 +257,6 @@ usage_text[] = { " -t[<file>] One-line GC statistics (if <file> omitted, uses stderr)", " -s[<file>] Summary GC statistics (if <file> omitted, uses stderr)", " -S[<file>] Detailed GC statistics (if <file> omitted, uses stderr)", -#ifdef RTS_GTK_FRONTPANEL -" -f Display front panel (requires X11 & GTK+)", -#endif "", "", " -Z Don't squeeze out update frames on stack overflow", @@ -292,7 +286,7 @@ usage_text[] = { " -hb<bio>... closures with specified biographies (lag,drag,void,use)", "", " -R<size> Set the maximum retainer set size (default: 8)", -"", +"", " -L<chars> Maximum length of a cost-centre stack in a heap profile", " (default: 25)", "", @@ -438,9 +432,9 @@ static void splitRtsFlags(const char *s) while (isspace(*c1)) { c1++; }; c2 = c1; while (!isspace(*c2) && *c2 != '\0') { c2++; }; - + if (c1 == c2) { break; } - + t = stgMallocBytes(c2-c1+1, "RtsFlags.c:splitRtsFlags()"); strncpy(t, c1, c2-c1); t[c2-c1] = '\0'; @@ -449,7 +443,7 @@ static void splitRtsFlags(const char *s) c1 = c2; } while (*c1 != '\0'); } - + /* ----------------------------------------------------------------------------- Parse the command line arguments, collecting options for the RTS. @@ -780,15 +774,15 @@ error = rtsTrue; case 'F': OPTION_UNSAFE; RtsFlags.GcFlags.oldGenFactor = atof(rts_argv[arg]+2); - + if (RtsFlags.GcFlags.oldGenFactor < 0) bad_option( rts_argv[arg] ); break; - + case 'D': OPTION_SAFE; DEBUG_BUILD_ONLY( - { + { char *c; for (c = rts_argv[arg] + 2; *c != '\0'; c++) { @@ -908,13 +902,6 @@ error = rtsTrue; } break; -#ifdef RTS_GTK_FRONTPANEL - case 'f': - OPTION_UNSAFE; - RtsFlags.GcFlags.frontpanel = rtsTrue; - break; -#endif - case 'I': /* idle GC delay */ OPTION_UNSAFE; if (rts_argv[arg][2] == '\0') { @@ -951,7 +938,7 @@ error = rtsTrue; goto stats; stats: - { + { int r; if (rts_argv[arg][2] != '\0') { OPTION_UNSAFE; @@ -1060,7 +1047,7 @@ error = rtsTrue; RtsFlags.ProfFlags.modSelector = left; break; case 'D': - case 'd': // closure descr select + case 'd': // closure descr select RtsFlags.ProfFlags.descrSelector = left; break; case 'Y': @@ -1114,12 +1101,12 @@ error = rtsTrue; break; } break; - + default: errorBelch("invalid heap profile option: %s",rts_argv[arg]); error = rtsTrue; } - ) + ) #endif /* PROFILING */ break; @@ -1266,7 +1253,7 @@ error = rtsTrue; RtsFlags.TickyFlags.showTickyStats = rtsTrue; - { + { int r; if (rts_argv[arg][2] != '\0') { OPTION_UNSAFE; @@ -1426,7 +1413,7 @@ static void normaliseRtsOpts (void) if (RtsFlags.ProfFlags.heapProfileInterval > 0) { RtsFlags.ProfFlags.heapProfileIntervalTicks = - RtsFlags.ProfFlags.heapProfileInterval / + RtsFlags.ProfFlags.heapProfileInterval / RtsFlags.MiscFlags.tickInterval; } else { RtsFlags.ProfFlags.heapProfileIntervalTicks = 0; @@ -1538,7 +1525,7 @@ decodeSize(const char *flag, nat offset, StgWord64 min, StgWord64 max) m = atof(s); c = s[strlen(s)-1]; - if (c == 'g' || c == 'G') + if (c == 'g' || c == 'G') m *= 1024*1024*1024; else if (c == 'm' || c == 'M') m *= 1024*1024; @@ -1801,7 +1788,7 @@ void setWin32ProgArgv(int argc, wchar_t *argv[]) { int i; - + freeWin32ProgArgv(); win32_prog_argc = argc; @@ -1809,7 +1796,7 @@ setWin32ProgArgv(int argc, wchar_t *argv[]) win32_prog_argv = NULL; return; } - + win32_prog_argv = stgCallocBytes(argc + 1, sizeof (wchar_t *), "setWin32ProgArgv 1"); for (i = 0; i < argc; i++) { diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c index 7b7d488e2b..39c5ef1f94 100644 --- a/rts/RtsStartup.c +++ b/rts/RtsStartup.c @@ -38,10 +38,6 @@ #include "FileLock.h" void exitLinker( void ); // there is no Linker.h file to include -#if defined(RTS_GTK_FRONTPANEL) -#include "FrontPanel.h" -#endif - #if defined(PROFILING) # include "ProfHeap.h" # include "RetainerProfile.h" @@ -237,17 +233,11 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config) initDefaultHandlers(); } #endif - + #if defined(mingw32_HOST_OS) && !defined(THREADED_RTS) startupAsyncIO(); #endif -#ifdef RTS_GTK_FRONTPANEL - if (RtsFlags.GcFlags.frontpanel) { - initFrontPanel(); - } -#endif - #if X86_INIT_FPU x86_init_fpu(); #endif @@ -293,7 +283,7 @@ hs_add_root(void (*init_root)(void) STG_UNUSED) * False ==> threads doing foreign calls may return in the * future, but will immediately block on a mutex. * (capability->lock). - * + * * If this RTS is a DLL that we're about to unload, then you want * safe=True, otherwise the thread might return to code that has been * unloaded. If this is a standalone program that is about to exit, @@ -305,6 +295,8 @@ hs_add_root(void (*init_root)(void) STG_UNUSED) static void hs_exit_(rtsBool wait_foreign) { + nat g; + if (hs_init_count <= 0) { errorBelch("warning: too many hs_exit()s"); return; @@ -317,7 +309,7 @@ hs_exit_(rtsBool wait_foreign) /* start timing the shutdown */ stat_startExit(); - + OnExitHook(); flushStdHandles(); @@ -335,8 +327,10 @@ hs_exit_(rtsBool wait_foreign) exitScheduler(wait_foreign); /* run C finalizers for all active weak pointers */ - runAllCFinalizers(weak_ptr_list); - + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { + runAllCFinalizers(generations[g].weak_ptr_list); + } + #if defined(RTS_USER_SIGNALS) if (RtsFlags.MiscFlags.install_signal_handlers) { freeSignalHandlers(); @@ -348,7 +342,7 @@ hs_exit_(rtsBool wait_foreign) exitTimer(wait_foreign); // set the terminal settings back to what they were -#if !defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) resetTerminalSettings(); #endif @@ -357,14 +351,14 @@ hs_exit_(rtsBool wait_foreign) /* stop timing the shutdown, we're about to print stats */ stat_endExit(); - + /* shutdown the hpc support (if needed) */ exitHpc(); // clean up things from the storage manager's point of view. // also outputs the stats (+RTS -s) info. exitStorage(); - + /* free the tasks */ freeScheduler(); @@ -385,13 +379,7 @@ hs_exit_(rtsBool wait_foreign) freeThreadLabelTable(); #endif -#ifdef RTS_GTK_FRONTPANEL - if (RtsFlags.GcFlags.frontpanel) { - stopFrontPanel(); - } -#endif - -#if defined(PROFILING) +#if defined(PROFILING) reportCCSProfiling(); #endif @@ -479,15 +467,15 @@ shutdownHaskellAndSignal(int sig) } #endif -/* +/* * called from STG-land to exit the program */ void (*exitFn)(int) = 0; -void +void stg_exit(int n) -{ +{ if (exitFn) (*exitFn)(n); exit(n); diff --git a/rts/RtsUtils.c b/rts/RtsUtils.c index fcbb757c05..cb9002c361 100644 --- a/rts/RtsUtils.c +++ b/rts/RtsUtils.c @@ -137,26 +137,6 @@ heapOverflow(void) } /* ----------------------------------------------------------------------------- - genSym stuff, used by GHC itself for its splitting unique supply. - - ToDo: put this somewhere sensible. - ------------------------------------------------------------------------- */ - -static HsInt __GenSymCounter = 0; - -HsInt -genSymZh(void) -{ - return(__GenSymCounter++); -} -HsInt -resetGenSymZh(void) /* it's your funeral */ -{ - __GenSymCounter=0; - return(__GenSymCounter); -} - -/* ----------------------------------------------------------------------------- Get the current time as a string. Used in profiling reports. -------------------------------------------------------------------------- */ @@ -905,8 +905,12 @@ static StgBool check_read_only(StgTRecHeader *trec STG_UNUSED) { s = e -> tvar; if (entry_is_read_only(e)) { TRACE("%p : check_read_only for TVar %p, saw %ld", trec, s, e -> num_updates); - if (s -> num_updates != e -> num_updates) { - // ||s -> current_value != e -> expected_value) { + + // Note we need both checks and in this order as the TVar could be + // locked by another transaction that is committing but has not yet + // incremented `num_updates` (See #7815). + if (s -> current_value != e -> expected_value || + s -> num_updates != e -> num_updates) { TRACE("%p : mismatch", trec); result = FALSE; BREAK_FOR_EACH; diff --git a/rts/Schedule.c b/rts/Schedule.c index abd317cc62..408146f195 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -947,6 +947,7 @@ scheduleDetectDeadlock (Capability **pcap, Task *task) case BlockedOnBlackHole: case BlockedOnMsgThrowTo: case BlockedOnMVar: + case BlockedOnMVarRead: throwToSingleThreaded(cap, task->incall->tso, (StgClosure *)nonTermination_closure); return; @@ -1437,7 +1438,7 @@ scheduleDoGC (Capability **pcap, Task *task USED_IF_THREADS, rtsBool heap_census; nat collect_gen; #ifdef THREADED_RTS - rtsBool gc_type; + StgWord8 gc_type; nat i, sync; StgTSO *tso; #endif @@ -2722,7 +2723,19 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception) tso->stackobj->sp = p; return STOP_FRAME; - case CATCH_RETRY_FRAME: + case CATCH_RETRY_FRAME: { + StgTRecHeader *trec = tso -> trec; + StgTRecHeader *outer = trec -> enclosing_trec; + debugTrace(DEBUG_stm, + "found CATCH_RETRY_FRAME at %p during raise", p); + debugTrace(DEBUG_stm, "trec=%p outer=%p", trec, outer); + stmAbortTransaction(cap, trec); + stmFreeAbortedTRec(cap, trec); + tso -> trec = outer; + p = next; + continue; + } + default: p = next; continue; @@ -2831,6 +2844,7 @@ resurrectThreads (StgTSO *threads) switch (tso->why_blocked) { case BlockedOnMVar: + case BlockedOnMVarRead: /* Called by GC - sched_mutex lock is currently held. */ throwToSingleThreaded(cap, tso, (StgClosure *)blockedIndefinitelyOnMVar_closure); diff --git a/rts/StgCRun.c b/rts/StgCRun.c index f0fa6c7c5e..a45c52fd02 100644 --- a/rts/StgCRun.c +++ b/rts/StgCRun.c @@ -118,8 +118,10 @@ StgWord8 *win32AllocStack(void) #ifdef darwin_HOST_OS #define STG_GLOBAL ".globl " +#define STG_HIDDEN ".private_extern " #else #define STG_GLOBAL ".global " +#define STG_HIDDEN ".hidden " #endif /* @@ -164,6 +166,9 @@ StgRunIsImplementedInAssembler(void) { __asm__ volatile ( STG_GLOBAL STG_RUN "\n" +#if !defined(mingw32_HOST_OS) + STG_HIDDEN STG_RUN "\n" +#endif STG_RUN ":\n\t" /* @@ -236,7 +241,13 @@ StgRunIsImplementedInAssembler(void) #ifdef x86_64_HOST_ARCH -extern StgRegTable * StgRun(StgFunPtr f, StgRegTable *basereg); +#define STG_GLOBAL ".globl " + +#ifdef darwin_HOST_OS +#define STG_HIDDEN ".private_extern " +#else +#define STG_HIDDEN ".hidden " +#endif static void GNUC3_ATTRIBUTE(used) StgRunIsImplementedInAssembler(void) @@ -245,7 +256,10 @@ StgRunIsImplementedInAssembler(void) /* * save callee-saves registers on behalf of the STG code. */ - ".globl " STG_RUN "\n" + STG_GLOBAL STG_RUN "\n" +#if !defined(mingw32_HOST_OS) + STG_HIDDEN STG_RUN "\n" +#endif STG_RUN ":\n\t" "subq %1, %%rsp\n\t" "movq %%rsp, %%rax\n\t" @@ -400,7 +414,13 @@ StgRun(StgFunPtr f, StgRegTable *basereg) { #ifdef powerpc_HOST_ARCH -extern StgRegTable * StgRun(StgFunPtr f, StgRegTable *basereg); +#define STG_GLOBAL ".globl " + +#ifdef darwin_HOST_OS +#define STG_HIDDEN ".private_extern " +#else +#define STG_HIDDEN ".hidden " +#endif #ifdef darwin_HOST_OS void StgRunIsImplementedInAssembler(void) @@ -408,11 +428,12 @@ void StgRunIsImplementedInAssembler(void) #if HAVE_SUBSECTIONS_VIA_SYMBOLS // if the toolchain supports deadstripping, we have to // prevent it here (it tends to get confused here). - __asm__ volatile (".no_dead_strip _StgRunIsImplementedInAssembler"); + __asm__ volatile (".no_dead_strip _StgRunIsImplementedInAssembler\n"); #endif __asm__ volatile ( - "\n.globl _StgRun\n" - "_StgRun:\n" + STG_GLOBAL STG_RUN "\n" + STG_HIDDEN STG_RUN "\n" + STG_RUN ":\n" "\tmflr r0\n" "\tbl saveFP # f14\n" "\tstmw r13,-220(r1)\n" @@ -446,6 +467,7 @@ StgRunIsImplementedInAssembler(void) { __asm__ volatile ( "\t.globl StgRun\n" + "\t.hidden StgRun\n" "\t.type StgRun,@function\n" "StgRun:\n" "\tmflr 0\n" @@ -518,8 +540,6 @@ StgRunIsImplementedInAssembler(void) #ifdef powerpc64_HOST_ARCH #ifdef linux_HOST_OS -extern StgRegTable * StgRun(StgFunPtr f, StgRegTable *basereg); - static void GNUC3_ATTRIBUTE(used) StgRunIsImplementedInAssembler(void) { @@ -534,6 +554,7 @@ StgRunIsImplementedInAssembler(void) ".section \".opd\",\"aw\"\n" ".align 3\n" ".globl StgRun\n" + ".hidden StgRun\n" "StgRun:\n" "\t.quad\t.StgRun,.TOC.@tocbase,0\n" "\t.size StgRun,24\n" diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm index 28a41ad681..9484031832 100644 --- a/rts/StgMiscClosures.cmm +++ b/rts/StgMiscClosures.cmm @@ -439,6 +439,15 @@ INFO_TABLE_CONSTR(stg_DEAD_WEAK,0,5,0,CONSTR,"DEAD_WEAK","DEAD_WEAK") { foreign "C" barf("DEAD_WEAK object entered!") never returns; } /* ---------------------------------------------------------------------------- + C finalizer lists + + Singly linked lists that chain multiple C finalizers on a weak pointer. + ------------------------------------------------------------------------- */ + +INFO_TABLE_CONSTR(stg_C_FINALIZER_LIST,1,4,0,CONSTR,"C_FINALIZER_LIST","C_FINALIZER_LIST") +{ foreign "C" barf("C_FINALIZER_LIST object entered!") never returns; } + +/* ---------------------------------------------------------------------------- NO_FINALIZER This is a static nullary constructor (like []) that we use to mark an empty diff --git a/rts/StgPrimFloat.c b/rts/StgPrimFloat.c index e523f328c3..3b80d6f388 100644 --- a/rts/StgPrimFloat.c +++ b/rts/StgPrimFloat.c @@ -43,29 +43,6 @@ #define __abs(a) (( (a) >= 0 ) ? (a) : (-(a))) -StgDouble -__2Int_encodeDouble (I_ j_high, I_ j_low, I_ e) -{ - StgDouble r; - - /* assuming 32 bit ints */ - ASSERT(sizeof(int ) == 4 ); - - r = (StgDouble)((unsigned int)j_high); - r *= 4294967296.0; /* exp2f(32); */ - r += (StgDouble)((unsigned int)j_low); - - /* Now raise to the exponent */ - if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */ - r = ldexp(r, e); - - /* sign is encoded in the size */ - if (j_high < 0) - r = -r; - - return r; -} - /* Special version for words */ StgDouble __word_encodeDouble (W_ j, I_ e) diff --git a/rts/StgPrimFloat.h b/rts/StgPrimFloat.h index cd5da46326..edd7b472b7 100644 --- a/rts/StgPrimFloat.h +++ b/rts/StgPrimFloat.h @@ -14,11 +14,8 @@ /* grimy low-level support functions defined in StgPrimFloat.c */ void __decodeDouble_2Int (I_ *man_sign, W_ *man_high, W_ *man_low, I_ *exp, StgDouble dbl); void __decodeFloat_Int (I_ *man, I_ *exp, StgFloat flt); -StgDouble __2Int_encodeDouble (I_ j_high, I_ j_low, I_ e); -StgDouble __word_encodeDouble (W_ j, I_ e); -StgFloat __word_encodeFloat (W_ j, I_ e); -// __int_encodeDouble and __int_encodeFloat are public, declared in +// __{int,word}_encode{Float,Double} are public, declared in // includes/rts/PrimFloat.h. #include "EndPrivate.h" diff --git a/rts/StgStdThunks.cmm b/rts/StgStdThunks.cmm index 53e4cb1d23..979f7498ca 100644 --- a/rts/StgStdThunks.cmm +++ b/rts/StgStdThunks.cmm @@ -111,10 +111,10 @@ SELECTOR_CODE_UPD(15) UPD_BH_UPDATABLE(node); \ LDV_ENTER(node); \ selectee = StgThunk_payload(node,0); \ + ENTER_CCS_THUNK(node); \ if (NEED_EVAL(selectee)) { \ - ENTER_CCS_THUNK(node); \ SAVE_CCS; \ - (P_ constr) = call %GET_ENTRY(selectee) (selectee); \ + (P_ constr) = call %GET_ENTRY(UNTAG_IF_PROF(selectee)) (selectee); \ RESTORE_CCS; \ selectee = constr; \ } \ diff --git a/rts/Threads.c b/rts/Threads.c index b6176163ad..f2b800512e 100644 --- a/rts/Threads.c +++ b/rts/Threads.c @@ -84,7 +84,7 @@ createThread(Capability *cap, W_ size) stack_size = round_to_mblocks(size - sizeofW(StgTSO)); stack = (StgStack *)allocate(cap, stack_size); TICK_ALLOC_STACK(stack_size); - SET_HDR(stack, &stg_STACK_info, CCS_SYSTEM); + SET_HDR(stack, &stg_STACK_info, cap->r.rCCCS); stack->stack_size = stack_size - sizeofW(StgStack); stack->sp = stack->stack + stack->stack_size; stack->dirty = 1; @@ -255,6 +255,7 @@ tryWakeupThread (Capability *cap, StgTSO *tso) switch (tso->why_blocked) { case BlockedOnMVar: + case BlockedOnMVarRead: { if (tso->_link == END_TSO_QUEUE) { tso->block_info.closure = (StgClosure*)END_TSO_QUEUE; @@ -575,7 +576,7 @@ threadStackOverflow (Capability *cap, StgTSO *tso) chunk_size * sizeof(W_)); new_stack = (StgStack*) allocate(cap, chunk_size); - SET_HDR(new_stack, &stg_STACK_info, CCS_SYSTEM); + SET_HDR(new_stack, &stg_STACK_info, old_stack->header.prof.ccs); TICK_ALLOC_STACK(chunk_size); new_stack->dirty = 0; // begin clean, we'll mark it dirty below @@ -734,6 +735,9 @@ printThreadBlockage(StgTSO *tso) case BlockedOnMVar: debugBelch("is blocked on an MVar @ %p", tso->block_info.closure); break; + case BlockedOnMVarRead: + debugBelch("is blocked on atomic MVar read @ %p", tso->block_info.closure); + break; case BlockedOnBlackHole: debugBelch("is blocked on a black hole %p", ((StgBlockingQueue*)tso->block_info.bh->bh)); diff --git a/rts/Ticky.c b/rts/Ticky.c index 0d33c43d79..e1e981b6df 100644 --- a/rts/Ticky.c +++ b/rts/Ticky.c @@ -75,7 +75,8 @@ PrintTickyInfo(void) tot_adm_wds + tot_gds_wds + tot_slp_wds; #endif - unsigned long tot_thk_enters = ENT_STATIC_THK_ctr + ENT_DYN_THK_ctr; + unsigned long tot_thk_enters = ENT_STATIC_THK_MANY_ctr + ENT_DYN_THK_MANY_ctr + + ENT_STATIC_THK_SINGLE_ctr + ENT_DYN_THK_SINGLE_ctr; unsigned long tot_con_enters = ENT_STATIC_CON_ctr + ENT_DYN_CON_ctr; unsigned long tot_fun_direct_enters = ENT_STATIC_FUN_DIRECT_ctr + ENT_DYN_FUN_DIRECT_ctr; @@ -452,8 +453,12 @@ PrintTickyInfo(void) PR_CTR(ENT_PAP_ctr); PR_CTR(ENT_AP_STACK_ctr); PR_CTR(ENT_BH_ctr); - PR_CTR(ENT_STATIC_THK_ctr); - PR_CTR(ENT_DYN_THK_ctr); + PR_CTR(ENT_STATIC_THK_SINGLE_ctr); + PR_CTR(ENT_STATIC_THK_MANY_ctr); + PR_CTR(ENT_DYN_THK_SINGLE_ctr); + PR_CTR(ENT_DYN_THK_MANY_ctr); + PR_CTR(UPD_CAF_BH_UPDATABLE_ctr); + PR_CTR(UPD_CAF_BH_SINGLE_ENTRY_ctr); PR_CTR(SLOW_CALL_fast_v16_ctr); PR_CTR(SLOW_CALL_fast_v_ctr); @@ -547,10 +552,6 @@ PrintTickyInfo(void) PR_CTR(UPD_PAP_IN_NEW_ctr); PR_CTR(UPD_PAP_IN_PLACE_ctr); - PR_CTR(UPD_BH_UPDATABLE_ctr); - PR_CTR(UPD_BH_SINGLE_ENTRY_ctr); - PR_CTR(UPD_CAF_BH_UPDATABLE_ctr); - PR_CTR(UPD_CAF_BH_SINGLE_ENTRY_ctr); /* krc: put off till later...*/ #if FALSE diff --git a/rts/Trace.c b/rts/Trace.c index 78dfead450..21901891cb 100644 --- a/rts/Trace.c +++ b/rts/Trace.c @@ -179,6 +179,7 @@ static char *thread_stop_reasons[] = { [ThreadFinished] = "finished", [THREAD_SUSPENDED_FOREIGN_CALL] = "suspended while making a foreign call", [6 + BlockedOnMVar] = "blocked on an MVar", + [6 + BlockedOnMVarRead] = "blocked on an atomic MVar read", [6 + BlockedOnBlackHole] = "blocked on a black hole", [6 + BlockedOnRead] = "blocked on a read operation", [6 + BlockedOnWrite] = "blocked on a write operation", diff --git a/rts/Weak.c b/rts/Weak.c index 5546514243..98ac7603b7 100644 --- a/rts/Weak.c +++ b/rts/Weak.c @@ -16,18 +16,19 @@ #include "Prelude.h" #include "Trace.h" -// ForeignPtrs with C finalizers rely on weak pointers inside weak_ptr_list -// to always be in the same order. - -StgWeak *weak_ptr_list; - void -runCFinalizer(void *fn, void *ptr, void *env, StgWord flag) +runCFinalizers(StgCFinalizerList *list) { - if (flag) - ((void (*)(void *, void *))fn)(env, ptr); - else - ((void (*)(void *))fn)(ptr); + StgCFinalizerList *head; + for (head = list; + (StgClosure *)head != &stg_NO_FINALIZER_closure; + head = (StgCFinalizerList *)head->link) + { + if (head->flag) + ((void (*)(void *, void *))head->fptr)(head->eptr, head->ptr); + else + ((void (*)(void *))head->fptr)(head->ptr); + } } void @@ -42,15 +43,7 @@ runAllCFinalizers(StgWeak *list) } for (w = list; w; w = w->link) { - StgArrWords *farr; - - farr = (StgArrWords *)UNTAG_CLOSURE(w->cfinalizer); - - if ((StgClosure *)farr != &stg_NO_FINALIZER_closure) - runCFinalizer((void *)farr->payload[0], - (void *)farr->payload[1], - (void *)farr->payload[2], - farr->payload[3]); + runCFinalizers((StgCFinalizerList *)w->cfinalizers); } if (task != NULL) { @@ -91,8 +84,6 @@ scheduleFinalizers(Capability *cap, StgWeak *list) // count number of finalizers, and kill all the weak pointers first... n = 0; for (w = list; w; w = w->link) { - StgArrWords *farr; - // Better not be a DEAD_WEAK at this stage; the garbage // collector removes DEAD_WEAKs from the weak pointer list. ASSERT(w->header.info != &stg_DEAD_WEAK_info); @@ -101,13 +92,7 @@ scheduleFinalizers(Capability *cap, StgWeak *list) n++; } - farr = (StgArrWords *)UNTAG_CLOSURE(w->cfinalizer); - - if ((StgClosure *)farr != &stg_NO_FINALIZER_closure) - runCFinalizer((void *)farr->payload[0], - (void *)farr->payload[1], - (void *)farr->payload[2], - farr->payload[3]); + runCFinalizers((StgCFinalizerList *)w->cfinalizers); #ifdef PROFILING // A weak pointer is inherently used, so we do not need to call diff --git a/rts/Weak.h b/rts/Weak.h index 9b230f94de..fbdf18a861 100644 --- a/rts/Weak.h +++ b/rts/Weak.h @@ -14,9 +14,9 @@ #include "BeginPrivate.h" extern rtsBool running_finalizers; -extern StgWeak * weak_ptr_list; +extern StgWeak * dead_weak_ptr_list; -void runCFinalizer(void *fn, void *ptr, void *env, StgWord flag); +void runCFinalizers(StgCFinalizerList *list); void runAllCFinalizers(StgWeak *w); void scheduleFinalizers(Capability *cap, StgWeak *w); void markWeakList(void); diff --git a/rts/ghc.mk b/rts/ghc.mk index b7651b09cf..4cc8e8de34 100644 --- a/rts/ghc.mk +++ b/rts/ghc.mk @@ -24,7 +24,7 @@ rts_WAYS = $(GhcLibWays) $(filter-out $(GhcLibWays),$(GhcRTSWays)) rts_dist_WAYS = $(rts_WAYS) ALL_RTS_LIBS = $(foreach way,$(rts_WAYS),rts/dist/build/libHSrts$($(way)_libsuf)) -all_rts : $(ALL_RTS_LIBS) +$(eval $(call all-target,rts,$(ALL_RTS_LIBS))) # ----------------------------------------------------------------------------- # Defining the sources @@ -68,10 +68,14 @@ DTRACEPROBES_H = rts/dist/build/RtsProbes.h rts_H_FILES += $(DTRACEPROBES_H) endif -# collect the -l flags that we need to link the rts dyn lib. -rts/libs.depend : $$(ghc-pkg_INPLACE) - "$(ghc-pkg_INPLACE)" field rts extra-libraries \ - | sed -e 's/^extra-libraries: //' -e 's/\([a-z0-9]*\)[ ]*/-l\1 /g' > $@ +# collect the -l and -L flags that we need to link the rts dyn lib. +# Note that, as sed on OS X doesn't handle \+, we use [^ ][^ ]* rather +# than [^ ]\+ +rts/dist/libs.depend : $$(ghc-pkg_INPLACE) | $$(dir $$@)/. + "$(ghc-pkg_INPLACE)" --simple-output field rts extra-libraries \ + | sed -e 's/\([^ ][^ ]*\)/-l\1/g' > $@ + "$(ghc-pkg_INPLACE)" --simple-output field rts library-dirs \ + | sed -e 's/\([^ ][^ ]*\)/-L\1/g' >> $@ # ---------------------------------------------------------------------------- @@ -105,13 +109,13 @@ endif ifneq "$(BINDIST)" "YES" ifneq "$(UseSystemLibFFI)" "YES" ifeq "$(HostOS_CPP)" "mingw32" -rts/dist/build/libffi.dll: libffi/build/inst/bin/$(LIBFFI_DLL) +rts/dist/build/$(LIBFFI_DLL): libffi/build/inst/bin/$(LIBFFI_DLL) cp $< $@ else # This is a little hacky. We don't know the SO version, so we only # depend on libffi.so, but copy libffi.so* -rts/dist/build/libffi$(soext): libffi/build/inst/lib/libffi$(soext) - cp libffi/build/inst/lib/libffi$(soext)* rts/dist/build +rts/dist/build/lib$(LIBFFI_NAME)$(soext): libffi/build/inst/lib/lib$(LIBFFI_NAME)$(soext) + cp libffi/build/inst/lib/lib$(LIBFFI_NAME)$(soext)* rts/dist/build endif endif endif @@ -170,7 +174,7 @@ endif rts_dist_$1_CC_OPTS += -DRtsWay=\"rts_$1\" ifneq "$$(UseSystemLibFFI)" "YES" -rts_dist_FFI_SO = rts/dist/build/libffi$$(soext) +rts_dist_FFI_SO = rts/dist/build/lib$$(LIBFFI_NAME)$$(soext) else rts_dist_FFI_SO = endif @@ -178,26 +182,28 @@ endif # Making a shared library for the RTS. ifneq "$$(findstring dyn, $1)" "" ifeq "$$(HostOS_CPP)" "mingw32" -$$(rts_$1_LIB) : $$(rts_$1_OBJS) $$(ALL_RTS_DEF_LIBS) rts/libs.depend rts/dist/build/libffi.dll +$$(rts_$1_LIB) : $$(rts_$1_OBJS) $$(ALL_RTS_DEF_LIBS) rts/dist/libs.depend rts/dist/build/$$(LIBFFI_DLL) "$$(RM)" $$(RM_OPTS) $$@ "$$(rts_dist_HC)" -package-name rts -shared -dynamic -dynload deploy \ - -no-auto-link-packages -Lrts/dist/build -lffi `cat rts/libs.depend` $$(rts_$1_OBJS) $$(ALL_RTS_DEF_LIBS) -o $$@ + -no-auto-link-packages -Lrts/dist/build -l$$(LIBFFI_NAME) \ + `cat rts/dist/libs.depend` $$(rts_$1_OBJS) $$(ALL_RTS_DEF_LIBS) -o $$@ else ifneq "$$(UseSystemLibFFI)" "YES" -LIBFFI_LIBS = -Lrts/dist/build -lffi +LIBFFI_LIBS = -Lrts/dist/build -l$$(LIBFFI_NAME) ifeq "$$(TargetElf)" "YES" -LIBFFI_LIBS += -optl-Wl,-rpath -optl-Wl,'$$$$ORIGIN' +LIBFFI_LIBS += -optl-Wl,-rpath -optl-Wl,'$$$$ORIGIN' -optl-Wl,-z -optl-Wl,origin endif else -# flags will be taken care of in rts/libs.depend +# flags will be taken care of in rts/dist/libs.depend LIBFFI_LIBS = endif -$$(rts_$1_LIB) : $$(rts_$1_OBJS) $$(rts_$1_DTRACE_OBJS) rts/libs.depend $$(rts_dist_FFI_SO) +$$(rts_$1_LIB) : $$(rts_$1_OBJS) $$(rts_$1_DTRACE_OBJS) rts/dist/libs.depend $$(rts_dist_FFI_SO) "$$(RM)" $$(RM_OPTS) $$@ "$$(rts_dist_HC)" -package-name rts -shared -dynamic -dynload deploy \ - -no-auto-link-packages $$(LIBFFI_LIBS) `cat rts/libs.depend` $$(rts_$1_OBJS) \ + -no-auto-link-packages $$(LIBFFI_LIBS) `cat rts/dist/libs.depend` $$(rts_$1_OBJS) \ $$(rts_$1_DTRACE_OBJS) -o $$@ + $(call relative-dynlib-references,rts,dist,1) endif else $$(rts_$1_LIB) : $$(rts_$1_OBJS) $$(rts_$1_DTRACE_OBJS) @@ -206,8 +212,8 @@ $$(rts_$1_LIB) : $$(rts_$1_OBJS) $$(rts_$1_DTRACE_OBJS) $$(AR_OPTS_STAGE1) $$(EXTRA_AR_ARGS_STAGE1) $$@ ifneq "$$(UseSystemLibFFI)" "YES" -$$(rts_$1_LIB) : rts/dist/build/libCffi$$($1_libsuf) -rts/dist/build/libCffi$$($1_libsuf): libffi/build/inst/lib/libffi.a +$$(rts_$1_LIB) : rts/dist/build/libC$$(LIBFFI_NAME)$$($1_libsuf) +rts/dist/build/libC$$(LIBFFI_NAME)$$($1_libsuf): libffi/build/inst/lib/libffi.a cp $$< $$@ endif @@ -220,7 +226,7 @@ endef # And expand the above for each way: $(foreach way,$(rts_WAYS),$(eval $(call build-rts-way,$(way)))) -$(eval $(call distdir-opts,rts,dist)) +$(eval $(call distdir-opts,rts,dist,1)) #----------------------------------------------------------------------------- # Flags for compiling every file @@ -418,7 +424,9 @@ rts/win32/ThrIOManager_CC_OPTS += -w # for details # Without this, thread_obj will not be inlined (at least on x86 with GCC 4.1.0) +ifneq "$(CC_CLANG_BACKEND)" "1" rts/sm/Compact_CC_OPTS += -finline-limit=2500 +endif # -O3 helps unroll some loops (especially in copy() with a constant argument). rts/sm/Evac_CC_OPTS += -funroll-loops @@ -469,7 +477,7 @@ else # UseSystemLibFFI==YES rts_PACKAGE_CPP_OPTS += -DFFI_INCLUDE_DIR= rts_PACKAGE_CPP_OPTS += -DFFI_LIB_DIR= -rts_PACKAGE_CPP_OPTS += '-DFFI_LIB="Cffi"' +rts_PACKAGE_CPP_OPTS += '-DFFI_LIB="C$(LIBFFI_NAME)"' endif @@ -479,9 +487,12 @@ endif rts_WAYS_DASHED = $(subst $(space),,$(patsubst %,-%,$(strip $(rts_WAYS)))) rts_dist_depfile_base = rts/dist/build/.depend$(rts_WAYS_DASHED) -rts_dist_C_SRCS = $(rts_C_SRCS) $(rts_thr_EXTRA_C_SRCS) -rts_dist_S_SRCS = $(rts_S_SRCS) -rts_dist_C_FILES = $(rts_C_SRCS) $(rts_thr_EXTRA_C_SRCS) $(rts_S_SRCS) +rts_dist_C_SRCS = $(rts_C_SRCS) $(rts_thr_EXTRA_C_SRCS) +rts_dist_S_SRCS = $(rts_S_SRCS) +rts_dist_CMM_SRCS = $(rts_CMM_SRCS) +rts_dist_C_FILES = $(rts_dist_C_SRCS) +rts_dist_S_FILES = $(rts_dist_S_SRCS) +rts_dist_CMM_FILES = $(rts_dist_CMM_SRCS) # Hack: we define every way-related option here, so that we get (hopefully) # a superset of the dependencies. To do this properly, we should generate @@ -549,8 +560,8 @@ rts/package.conf.inplace : $(includes_H_CONFIG) $(includes_H_PLATFORM) RTS_INSTALL_LIBS += $(ALL_RTS_LIBS) ifneq "$(UseSystemLibFFI)" "YES" -RTS_INSTALL_LIBS += $(wildcard rts/dist/build/libffi*$(soext)*) -RTS_INSTALL_LIBS += $(foreach w,$(filter-out %dyn,$(rts_WAYS)),rts/dist/build/libCffi$($w_libsuf)) +RTS_INSTALL_LIBS += $(wildcard rts/dist/build/lib$(LIBFFI_NAME)*$(soext)*) +RTS_INSTALL_LIBS += $(foreach w,$(filter-out %dyn,$(rts_WAYS)),rts/dist/build/libC$(LIBFFI_NAME)$($w_libsuf)) endif ifneq "$(UseSystemLibFFI)" "YES" diff --git a/rts/package.conf.in b/rts/package.conf.in index 9aef05dbb5..010305f83d 100644 --- a/rts/package.conf.in +++ b/rts/package.conf.in @@ -3,12 +3,12 @@ #include "ghcconfig.h" #include "rts/Config.h" -name: rts -version: 1.0 +name: rts +version: 1.0 id: builtin_rts -license: BSD3 -maintainer: glasgow-haskell-users@haskell.org -exposed: True +license: BSD3 +maintainer: glasgow-haskell-users@haskell.org +exposed: True exposed-modules: hidden-modules: @@ -16,33 +16,36 @@ hidden-modules: import-dirs: #ifdef INSTALLING -library-dirs: LIB_DIR"/rts-1.0" PAPI_LIB_DIR +library-dirs: LIB_DIR"/rts-1.0" PAPI_LIB_DIR FFI_LIB_DIR #else /* !INSTALLING */ -library-dirs: TOP"/rts/dist/build" PAPI_LIB_DIR +library-dirs: TOP"/rts/dist/build" PAPI_LIB_DIR FFI_LIB_DIR #endif hs-libraries: "HSrts" FFI_LIB extra-libraries: #ifdef HAVE_LIBM - "m" /* for ldexp() */ + "m" /* for ldexp() */ #endif #ifdef HAVE_LIBRT - , "rt" + , "rt" #endif #ifdef HAVE_LIBDL - , "dl" + , "dl" #endif #ifdef HAVE_LIBFFI , "ffi" #endif #ifdef mingw32_HOST_OS - ,"wsock32" /* for the linker */ - ,"gdi32" /* for the linker */ - ,"winmm" /* for the linker */ + ,"wsock32" /* for the linker */ + ,"gdi32" /* for the linker */ + ,"winmm" /* for the linker */ +#endif +#ifdef freebsd_HOST_OS + , "pthread" /* for pthread_getthreadid_np() */ #endif #if defined(DEBUG) && defined(HAVE_LIBBFD) - ,"bfd", "iberty" /* for debugging */ + ,"bfd", "iberty" /* for debugging */ #endif #ifdef HAVE_LIBMINGWEX # ifndef INSTALLING /* Bundled Mingw is behind */ @@ -50,100 +53,100 @@ extra-libraries: # endif #endif #if USE_PAPI - , "papi" + , "papi" #endif #ifdef INSTALLING -include-dirs: INCLUDE_DIR PAPI_INCLUDE_DIR +include-dirs: INCLUDE_DIR PAPI_INCLUDE_DIR #else /* !INSTALLING */ include-dirs: TOP"/rts/dist/build" TOP"/includes" TOP"/includes/dist-derivedconstants/header" #endif -includes: Stg.h +includes: Stg.h hugs-options: cc-options: ld-options: #ifdef LEADING_UNDERSCORE - "-u", "_ghczmprim_GHCziTypes_Izh_static_info" - , "-u", "_ghczmprim_GHCziTypes_Czh_static_info" - , "-u", "_ghczmprim_GHCziTypes_Fzh_static_info" - , "-u", "_ghczmprim_GHCziTypes_Dzh_static_info" - , "-u", "_base_GHCziPtr_Ptr_static_info" - , "-u", "_ghczmprim_GHCziTypes_Wzh_static_info" - , "-u", "_base_GHCziInt_I8zh_static_info" - , "-u", "_base_GHCziInt_I16zh_static_info" - , "-u", "_base_GHCziInt_I32zh_static_info" - , "-u", "_base_GHCziInt_I64zh_static_info" - , "-u", "_base_GHCziWord_W8zh_static_info" - , "-u", "_base_GHCziWord_W16zh_static_info" - , "-u", "_base_GHCziWord_W32zh_static_info" - , "-u", "_base_GHCziWord_W64zh_static_info" - , "-u", "_base_GHCziStable_StablePtr_static_info" - , "-u", "_ghczmprim_GHCziTypes_Izh_con_info" - , "-u", "_ghczmprim_GHCziTypes_Czh_con_info" - , "-u", "_ghczmprim_GHCziTypes_Fzh_con_info" - , "-u", "_ghczmprim_GHCziTypes_Dzh_con_info" - , "-u", "_base_GHCziPtr_Ptr_con_info" - , "-u", "_base_GHCziPtr_FunPtr_con_info" - , "-u", "_base_GHCziStable_StablePtr_con_info" - , "-u", "_ghczmprim_GHCziTypes_False_closure" - , "-u", "_ghczmprim_GHCziTypes_True_closure" - , "-u", "_base_GHCziPack_unpackCString_closure" - , "-u", "_base_GHCziIOziException_stackOverflow_closure" - , "-u", "_base_GHCziIOziException_heapOverflow_closure" - , "-u", "_base_ControlziExceptionziBase_nonTermination_closure" - , "-u", "_base_GHCziIOziException_blockedIndefinitelyOnMVar_closure" - , "-u", "_base_GHCziIOziException_blockedIndefinitelyOnSTM_closure" - , "-u", "_base_ControlziExceptionziBase_nestedAtomically_closure" - , "-u", "_base_GHCziWeak_runFinalizzerBatch_closure" - , "-u", "_base_GHCziTopHandler_flushStdHandles_closure" - , "-u", "_base_GHCziTopHandler_runIO_closure" - , "-u", "_base_GHCziTopHandler_runNonIO_closure" - , "-u", "_base_GHCziConcziIO_ensureIOManagerIsRunning_closure" - , "-u", "_base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" - , "-u", "_base_GHCziConcziSync_runSparks_closure" - , "-u", "_base_GHCziConcziSignal_runHandlers_closure" + "-Wl,-u,_ghczmprim_GHCziTypes_Izh_static_info" + , "-Wl,-u,_ghczmprim_GHCziTypes_Czh_static_info" + , "-Wl,-u,_ghczmprim_GHCziTypes_Fzh_static_info" + , "-Wl,-u,_ghczmprim_GHCziTypes_Dzh_static_info" + , "-Wl,-u,_base_GHCziPtr_Ptr_static_info" + , "-Wl,-u,_ghczmprim_GHCziTypes_Wzh_static_info" + , "-Wl,-u,_base_GHCziInt_I8zh_static_info" + , "-Wl,-u,_base_GHCziInt_I16zh_static_info" + , "-Wl,-u,_base_GHCziInt_I32zh_static_info" + , "-Wl,-u,_base_GHCziInt_I64zh_static_info" + , "-Wl,-u,_base_GHCziWord_W8zh_static_info" + , "-Wl,-u,_base_GHCziWord_W16zh_static_info" + , "-Wl,-u,_base_GHCziWord_W32zh_static_info" + , "-Wl,-u,_base_GHCziWord_W64zh_static_info" + , "-Wl,-u,_base_GHCziStable_StablePtr_static_info" + , "-Wl,-u,_ghczmprim_GHCziTypes_Izh_con_info" + , "-Wl,-u,_ghczmprim_GHCziTypes_Czh_con_info" + , "-Wl,-u,_ghczmprim_GHCziTypes_Fzh_con_info" + , "-Wl,-u,_ghczmprim_GHCziTypes_Dzh_con_info" + , "-Wl,-u,_base_GHCziPtr_Ptr_con_info" + , "-Wl,-u,_base_GHCziPtr_FunPtr_con_info" + , "-Wl,-u,_base_GHCziStable_StablePtr_con_info" + , "-Wl,-u,_ghczmprim_GHCziTypes_False_closure" + , "-Wl,-u,_ghczmprim_GHCziTypes_True_closure" + , "-Wl,-u,_base_GHCziPack_unpackCString_closure" + , "-Wl,-u,_base_GHCziIOziException_stackOverflow_closure" + , "-Wl,-u,_base_GHCziIOziException_heapOverflow_closure" + , "-Wl,-u,_base_ControlziExceptionziBase_nonTermination_closure" + , "-Wl,-u,_base_GHCziIOziException_blockedIndefinitelyOnMVar_closure" + , "-Wl,-u,_base_GHCziIOziException_blockedIndefinitelyOnSTM_closure" + , "-Wl,-u,_base_ControlziExceptionziBase_nestedAtomically_closure" + , "-Wl,-u,_base_GHCziWeak_runFinalizzerBatch_closure" + , "-Wl,-u,_base_GHCziTopHandler_flushStdHandles_closure" + , "-Wl,-u,_base_GHCziTopHandler_runIO_closure" + , "-Wl,-u,_base_GHCziTopHandler_runNonIO_closure" + , "-Wl,-u,_base_GHCziConcziIO_ensureIOManagerIsRunning_closure" + , "-Wl,-u,_base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" + , "-Wl,-u,_base_GHCziConcziSync_runSparks_closure" + , "-Wl,-u,_base_GHCziConcziSignal_runHandlers_closure" #else - "-u", "ghczmprim_GHCziTypes_Izh_static_info" - , "-u", "ghczmprim_GHCziTypes_Czh_static_info" - , "-u", "ghczmprim_GHCziTypes_Fzh_static_info" - , "-u", "ghczmprim_GHCziTypes_Dzh_static_info" - , "-u", "base_GHCziPtr_Ptr_static_info" - , "-u", "ghczmprim_GHCziTypes_Wzh_static_info" - , "-u", "base_GHCziInt_I8zh_static_info" - , "-u", "base_GHCziInt_I16zh_static_info" - , "-u", "base_GHCziInt_I32zh_static_info" - , "-u", "base_GHCziInt_I64zh_static_info" - , "-u", "base_GHCziWord_W8zh_static_info" - , "-u", "base_GHCziWord_W16zh_static_info" - , "-u", "base_GHCziWord_W32zh_static_info" - , "-u", "base_GHCziWord_W64zh_static_info" - , "-u", "base_GHCziStable_StablePtr_static_info" - , "-u", "ghczmprim_GHCziTypes_Izh_con_info" - , "-u", "ghczmprim_GHCziTypes_Czh_con_info" - , "-u", "ghczmprim_GHCziTypes_Fzh_con_info" - , "-u", "ghczmprim_GHCziTypes_Dzh_con_info" - , "-u", "base_GHCziPtr_Ptr_con_info" - , "-u", "base_GHCziPtr_FunPtr_con_info" - , "-u", "base_GHCziStable_StablePtr_con_info" - , "-u", "ghczmprim_GHCziTypes_False_closure" - , "-u", "ghczmprim_GHCziTypes_True_closure" - , "-u", "base_GHCziPack_unpackCString_closure" - , "-u", "base_GHCziIOziException_stackOverflow_closure" - , "-u", "base_GHCziIOziException_heapOverflow_closure" - , "-u", "base_ControlziExceptionziBase_nonTermination_closure" - , "-u", "base_GHCziIOziException_blockedIndefinitelyOnMVar_closure" - , "-u", "base_GHCziIOziException_blockedIndefinitelyOnSTM_closure" - , "-u", "base_ControlziExceptionziBase_nestedAtomically_closure" - , "-u", "base_GHCziWeak_runFinalizzerBatch_closure" - , "-u", "base_GHCziTopHandler_flushStdHandles_closure" - , "-u", "base_GHCziTopHandler_runIO_closure" - , "-u", "base_GHCziTopHandler_runNonIO_closure" - , "-u", "base_GHCziConcziIO_ensureIOManagerIsRunning_closure" - , "-u", "base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" - , "-u", "base_GHCziConcziSync_runSparks_closure" - , "-u", "base_GHCziConcziSignal_runHandlers_closure" + "-Wl,-u,ghczmprim_GHCziTypes_Izh_static_info" + , "-Wl,-u,ghczmprim_GHCziTypes_Czh_static_info" + , "-Wl,-u,ghczmprim_GHCziTypes_Fzh_static_info" + , "-Wl,-u,ghczmprim_GHCziTypes_Dzh_static_info" + , "-Wl,-u,base_GHCziPtr_Ptr_static_info" + , "-Wl,-u,ghczmprim_GHCziTypes_Wzh_static_info" + , "-Wl,-u,base_GHCziInt_I8zh_static_info" + , "-Wl,-u,base_GHCziInt_I16zh_static_info" + , "-Wl,-u,base_GHCziInt_I32zh_static_info" + , "-Wl,-u,base_GHCziInt_I64zh_static_info" + , "-Wl,-u,base_GHCziWord_W8zh_static_info" + , "-Wl,-u,base_GHCziWord_W16zh_static_info" + , "-Wl,-u,base_GHCziWord_W32zh_static_info" + , "-Wl,-u,base_GHCziWord_W64zh_static_info" + , "-Wl,-u,base_GHCziStable_StablePtr_static_info" + , "-Wl,-u,ghczmprim_GHCziTypes_Izh_con_info" + , "-Wl,-u,ghczmprim_GHCziTypes_Czh_con_info" + , "-Wl,-u,ghczmprim_GHCziTypes_Fzh_con_info" + , "-Wl,-u,ghczmprim_GHCziTypes_Dzh_con_info" + , "-Wl,-u,base_GHCziPtr_Ptr_con_info" + , "-Wl,-u,base_GHCziPtr_FunPtr_con_info" + , "-Wl,-u,base_GHCziStable_StablePtr_con_info" + , "-Wl,-u,ghczmprim_GHCziTypes_False_closure" + , "-Wl,-u,ghczmprim_GHCziTypes_True_closure" + , "-Wl,-u,base_GHCziPack_unpackCString_closure" + , "-Wl,-u,base_GHCziIOziException_stackOverflow_closure" + , "-Wl,-u,base_GHCziIOziException_heapOverflow_closure" + , "-Wl,-u,base_ControlziExceptionziBase_nonTermination_closure" + , "-Wl,-u,base_GHCziIOziException_blockedIndefinitelyOnMVar_closure" + , "-Wl,-u,base_GHCziIOziException_blockedIndefinitelyOnSTM_closure" + , "-Wl,-u,base_ControlziExceptionziBase_nestedAtomically_closure" + , "-Wl,-u,base_GHCziWeak_runFinalizzerBatch_closure" + , "-Wl,-u,base_GHCziTopHandler_flushStdHandles_closure" + , "-Wl,-u,base_GHCziTopHandler_runIO_closure" + , "-Wl,-u,base_GHCziTopHandler_runNonIO_closure" + , "-Wl,-u,base_GHCziConcziIO_ensureIOManagerIsRunning_closure" + , "-Wl,-u,base_GHCziConcziIO_ioManagerCapabilitiesChanged_closure" + , "-Wl,-u,base_GHCziConcziSync_runSparks_closure" + , "-Wl,-u,base_GHCziConcziSignal_runHandlers_closure" #endif /* Pick up static libraries in preference over dynamic if in earlier search @@ -151,7 +154,7 @@ ld-options: * The used option is specific to the Darwin linker. */ #ifdef darwin_HOST_OS - , "-Wl,-search_paths_first" + , "-Wl,-search_paths_first" #endif #if defined(darwin_HOST_OS) && !defined(x86_64_HOST_ARCH) diff --git a/rts/posix/Itimer.c b/rts/posix/Itimer.c index b99ff8970b..4bcc3a1c2e 100644 --- a/rts/posix/Itimer.c +++ b/rts/posix/Itimer.c @@ -45,6 +45,20 @@ #include <string.h> /* + * timer_create doesn't exist and setitimer doesn't fire on iOS, so we're using + * a pthreads-based implementation. It may be to do with interference with the + * signals of the debugger. Revisit. See #7723. + */ +#if defined(ios_HOST_OS) +#define USE_PTHREAD_FOR_ITIMER +#endif + +#if defined(USE_PTHREAD_FOR_ITIMER) +#include <pthread.h> +#include <unistd.h> +#endif + +/* * We use a realtime timer by default. I found this much more * reliable than a CPU timer: * @@ -107,6 +121,7 @@ static timer_t timer; static Time itimer_interval = DEFAULT_TICK_INTERVAL; +#if !defined(USE_PTHREAD_FOR_ITIMER) static void install_vtalrm_handler(TickProc handle_tick) { struct sigaction action; @@ -132,13 +147,33 @@ static void install_vtalrm_handler(TickProc handle_tick) stg_exit(EXIT_FAILURE); } } +#endif + +#if defined(USE_PTHREAD_FOR_ITIMER) +static volatile int itimer_enabled; +static void *itimer_thread_func(void *_handle_tick) +{ + TickProc handle_tick = _handle_tick; + while (1) { + usleep(TimeToUS(itimer_interval)); + switch (itimer_enabled) { + case 1: handle_tick(0); break; + case 2: itimer_enabled = 0; + } + } + return NULL; +} +#endif void initTicker (Time interval, TickProc handle_tick) { itimer_interval = interval; -#if defined(USE_TIMER_CREATE) +#if defined(USE_PTHREAD_FOR_ITIMER) + pthread_t tid; + pthread_create(&tid, NULL, itimer_thread_func, (void*)handle_tick); +#elif defined(USE_TIMER_CREATE) { struct sigevent ev; @@ -153,15 +188,18 @@ initTicker (Time interval, TickProc handle_tick) stg_exit(EXIT_FAILURE); } } -#endif - install_vtalrm_handler(handle_tick); +#else + install_vtalrm_handler(handle_tick); +#endif } void startTicker(void) { -#if defined(USE_TIMER_CREATE) +#if defined(USE_PTHREAD_FOR_ITIMER) + itimer_enabled = 1; +#elif defined(USE_TIMER_CREATE) { struct itimerspec it; @@ -193,7 +231,14 @@ startTicker(void) void stopTicker(void) { -#if defined(USE_TIMER_CREATE) +#if defined(USE_PTHREAD_FOR_ITIMER) + if (itimer_enabled == 1) { + itimer_enabled = 2; + /* Wait for the thread to confirm it won't generate another tick. */ + while (itimer_enabled != 0) + sched_yield(); + } +#elif defined(USE_TIMER_CREATE) struct itimerspec it; it.it_value.tv_sec = 0; diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c index 7c89418ab9..247f1a01c6 100644 --- a/rts/sm/Compact.c +++ b/rts/sm/Compact.c @@ -442,6 +442,7 @@ thread_TSO (StgTSO *tso) thread_(&tso->global_link); if ( tso->why_blocked == BlockedOnMVar + || tso->why_blocked == BlockedOnMVarRead || tso->why_blocked == BlockedOnBlackHole || tso->why_blocked == BlockedOnMsgThrowTo || tso->why_blocked == NotBlocked @@ -620,7 +621,7 @@ thread_obj (StgInfoTable *info, StgPtr p) case WEAK: { StgWeak *w = (StgWeak *)p; - thread(&w->cfinalizer); + thread(&w->cfinalizers); thread(&w->key); thread(&w->value); thread(&w->finalizer); @@ -917,17 +918,20 @@ compact(StgClosure *static_objects) markScheduler((evac_fn)thread_root, NULL); // the weak pointer lists... - if (weak_ptr_list != NULL) { - thread((void *)&weak_ptr_list); + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { + if (generations[g].weak_ptr_list != NULL) { + thread((void *)&generations[g].weak_ptr_list); + } } - if (old_weak_ptr_list != NULL) { - thread((void *)&old_weak_ptr_list); // tmp + + if (dead_weak_ptr_list != NULL) { + thread((void *)&dead_weak_ptr_list); // tmp } // mutable lists for (g = 1; g < RtsFlags.GcFlags.generations; g++) { - bdescr *bd; - StgPtr p; + bdescr *bd; + StgPtr p; for (n = 0; n < n_capabilities; n++) { for (bd = capabilities[n].mut_lists[g]; bd != NULL; bd = bd->link) { diff --git a/rts/sm/GC.c b/rts/sm/GC.c index dfebd55334..1b2cb12212 100644 --- a/rts/sm/GC.c +++ b/rts/sm/GC.c @@ -6,7 +6,7 @@ * * Documentation on the architecture of the Garbage Collector can be * found in the online commentary: - * + * * http://hackage.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/GC * * ---------------------------------------------------------------------------*/ @@ -41,15 +41,13 @@ #include "Prelude.h" #include "RtsSignals.h" #include "STM.h" -#if defined(RTS_GTK_FRONTPANEL) -#include "FrontPanel.h" -#endif #include "Trace.h" #include "RetainerProfile.h" #include "LdvProfile.h" #include "RaiseAsync.h" #include "Papi.h" #include "Stable.h" +#include "CheckUnload.h" #include <string.h> // for memset() #include <unistd.h> @@ -75,13 +73,13 @@ * linking objects on to the list. We use a stack-type list, consing * objects on the front as they are added (this means that the * scavenge phase is depth-first, not breadth-first, but that - * shouldn't matter). + * shouldn't matter). * * A separate list is kept for objects that have been scavenged * already - this is so that we can zero all the marks afterwards. * * An object is on the list if its static link field is non-zero; this - * means that we have to mark the end of the list with '1', not NULL. + * means that we have to mark the end of the list with '1', not NULL. * * Extra notes for generational GC: * @@ -103,7 +101,7 @@ rtsBool major_gc; /* Data used for allocation area sizing. */ -static W_ g0_pcnt_kept = 30; // percentage of g0 live at last minor GC +static W_ g0_pcnt_kept = 30; // percentage of g0 live at last minor GC /* Mut-list stats */ #ifdef DEBUG @@ -216,7 +214,7 @@ GarbageCollect (nat collect_gen, // this is the main thread SET_GCT(gc_threads[cap->no]); - // tell the stats department that we've started a GC + // tell the stats department that we've started a GC stat_startGC(cap, gct); // lock the StablePtr table @@ -235,7 +233,7 @@ GarbageCollect (nat collect_gen, mutlist_OTHERS = 0; #endif - // attribute any costs to CCS_GC + // attribute any costs to CCS_GC #ifdef PROFILING for (n = 0; n < n_capabilities; n++) { save_CCS[n] = capabilities[n].r.rCCCS; @@ -254,7 +252,7 @@ GarbageCollect (nat collect_gen, // It's not always a good idea to do load balancing in parallel // GC. In particular, for a parallel program we don't want to // lose locality by moving cached data into another CPU's cache - // (this effect can be quite significant). + // (this effect can be quite significant). // // We could have a more complex way to deterimine whether to do // work stealing or not, e.g. it might be a good idea to do it @@ -283,14 +281,8 @@ GarbageCollect (nat collect_gen, debugTrace(DEBUG_gc, "GC (gen %d, using %d thread(s))", N, n_gc_threads); -#ifdef RTS_GTK_FRONTPANEL - if (RtsFlags.GcFlags.frontpanel) { - updateFrontPanelBeforeGC(N); - } -#endif - #ifdef DEBUG - // check for memory leaks if DEBUG is on + // check for memory leaks if DEBUG is on memInventory(DEBUG_gc); #endif @@ -401,10 +393,10 @@ GarbageCollect (nat collect_gen, scavenge_until_all_done(); // The other threads are now stopped. We might recurse back to // here, but from now on this is the only thread. - + // must be last... invariant is that everything is fully // scavenged at this point. - if (traverseWeakPtrList()) { // returns rtsTrue if evaced something + if (traverseWeakPtrList()) { // returns rtsTrue if evaced something inc_running(); continue; } @@ -451,7 +443,7 @@ GarbageCollect (nat collect_gen, // Finally: compact or sweep the oldest generation. if (major_gc && oldest_gen->mark) { - if (oldest_gen->compact) + if (oldest_gen->compact) compact(gct->scavenged_static_objects); else sweep(oldest_gen); @@ -460,7 +452,7 @@ GarbageCollect (nat collect_gen, copied = 0; par_max_copied = 0; par_tot_copied = 0; - { + { nat i; for (i=0; i < n_gc_threads; i++) { if (n_gc_threads > 1) { @@ -494,7 +486,7 @@ GarbageCollect (nat collect_gen, for (g = 0; g < RtsFlags.GcFlags.generations; g++) { if (g == N) { - generations[g].collections++; // for stats + generations[g].collections++; // for stats if (n_gc_threads > 1) generations[g].par_collections++; } @@ -521,7 +513,7 @@ GarbageCollect (nat collect_gen, bdescr *next, *prev; gen = &generations[g]; - // for generations we collected... + // for generations we collected... if (g <= N) { /* free old memory and shift to-space into from-space for all @@ -532,12 +524,12 @@ GarbageCollect (nat collect_gen, { // tack the new blocks on the end of the existing blocks if (gen->old_blocks != NULL) { - + prev = NULL; for (bd = gen->old_blocks; bd != NULL; bd = next) { - + next = bd->link; - + if (!(bd->flags & BF_MARKED)) { if (prev == NULL) { @@ -551,17 +543,17 @@ GarbageCollect (nat collect_gen, else { gen->n_words += bd->free - bd->start; - + // NB. this step might not be compacted next // time, so reset the BF_MARKED flags. // They are set before GC if we're going to // compact. (search for BF_MARKED above). bd->flags &= ~BF_MARKED; - + // between GCs, all blocks in the heap except // for the nursery have the BF_EVACUATED flag set. bd->flags |= BF_EVACUATED; - + prev = bd; } } @@ -606,8 +598,8 @@ GarbageCollect (nat collect_gen, dbl_link_onto(bd, &gen->large_objects); gen->n_large_words += bd->free - bd->start; } - - // add the new blocks we promoted during this GC + + // add the new blocks we promoted during this GC gen->n_large_blocks += gen->n_scavenged_large_blocks; } @@ -634,7 +626,7 @@ GarbageCollect (nat collect_gen, // update the max size of older generations after a major GC resize_generations(); - + // Free the mark stack. if (mark_stack_top_bd != NULL) { debugTrace(DEBUG_gc, "mark stack: %d blocks", @@ -670,11 +662,15 @@ GarbageCollect (nat collect_gen, resetNurseries(); + if (major_gc) { + checkUnload (gct->scavenged_static_objects); + } + // mark the garbage collected CAFs as dead -#if 0 && defined(DEBUG) // doesn't work at the moment +#if 0 && defined(DEBUG) // doesn't work at the moment if (major_gc) { gcCAFs(); } #endif - + #ifdef PROFILING // resetStaticObjectForRetainerProfiling() must be called before // zeroing below. @@ -683,7 +679,7 @@ GarbageCollect (nat collect_gen, resetStaticObjectForRetainerProfiling(gct->scavenged_static_objects); #endif - // zero the scavenged static object list + // zero the scavenged static object list if (major_gc) { nat i; if (n_gc_threads == 1) { @@ -708,7 +704,7 @@ GarbageCollect (nat collect_gen, // Start any pending finalizers. Must be after // updateStableTables() and stableUnlock() (see #4221). RELEASE_SM_LOCK; - scheduleFinalizers(cap, old_weak_ptr_list); + scheduleFinalizers(cap, dead_weak_ptr_list); ACQUIRE_SM_LOCK; // check sanity after GC @@ -750,11 +746,11 @@ GarbageCollect (nat collect_gen, IF_DEBUG(gc, statDescribeGens()); #ifdef DEBUG - // symbol-table based profiling + // symbol-table based profiling /* heapCensus(to_blocks); */ /* ToDo */ #endif - // restore enclosing cost centre + // restore enclosing cost centre #ifdef PROFILING for (n = 0; n < n_capabilities; n++) { capabilities[n].r.rCCCS = save_CCS[n]; @@ -762,17 +758,11 @@ GarbageCollect (nat collect_gen, #endif #ifdef DEBUG - // check for memory leaks if DEBUG is on + // check for memory leaks if DEBUG is on memInventory(DEBUG_gc); #endif -#ifdef RTS_GTK_FRONTPANEL - if (RtsFlags.GcFlags.frontpanel) { - updateFrontPanelAfterGC( N, live ); - } -#endif - - // ok, GC over: tell the stats department what happened. + // ok, GC over: tell the stats department what happened. stat_endGC(cap, gct, live_words, copied, live_blocks * BLOCK_SIZE_W - live_words /* slop */, N, n_gc_threads, par_max_copied, par_tot_copied); @@ -821,7 +811,7 @@ new_gc_thread (nat n, gc_thread *t) t->gc_count = 0; init_gc_thread(t); - + #ifdef USE_PAPI t->papi_events = -1; #endif @@ -832,7 +822,7 @@ new_gc_thread (nat n, gc_thread *t) ws->gen = &generations[g]; ASSERT(g == ws->gen->no); ws->my_gct = t; - + // We want to call // alloc_todo_block(ws,0); // but can't, because it uses gct which isn't set up at this point. @@ -960,7 +950,7 @@ any_work (void) if (mark_stack_bd != NULL && !mark_stack_empty()) { return rtsTrue; } - + // Check for global work in any step. We don't need to check for // local work, because we have already exited scavenge_loop(), // which means there is no local work for this thread. @@ -991,13 +981,13 @@ any_work (void) #endif return rtsFalse; -} +} static void scavenge_until_all_done (void) { DEBUG_ONLY( nat r ); - + loop: #if defined(THREADED_RTS) @@ -1023,7 +1013,7 @@ loop: traceEventGcIdle(gct->cap); debugTrace(DEBUG_gc, "%d GC threads still running", r); - + while (gc_running_threads != 0) { // usleep(1); if (any_work()) { @@ -1033,10 +1023,10 @@ loop: } // any_work() does not remove the work from the queue, it // just checks for the presence of work. If we find any, - // then we increment gc_running_threads and go back to + // then we increment gc_running_threads and go back to // scavenge_loop() to perform any pending work. } - + traceEventGcDone(gct->cap); } @@ -1065,7 +1055,7 @@ gcWorkerThread (Capability *cap) gct->wakeup = GC_THREAD_STANDING_BY; debugTrace(DEBUG_gc, "GC thread %d standing by...", gct->thread_index); ACQUIRE_SPIN_LOCK(&gct->gc_spin); - + #ifdef USE_PAPI // start performance counters in this thread... if (gct->papi_events == -1) { @@ -1084,7 +1074,7 @@ gcWorkerThread (Capability *cap) scavenge_capability_mut_lists(cap); scavenge_until_all_done(); - + if (!DEBUG_IS_ON) { clearNursery(cap); } @@ -1107,7 +1097,7 @@ gcWorkerThread (Capability *cap) // Wait until we're told to continue RELEASE_SPIN_LOCK(&gct->gc_spin); gct->wakeup = GC_THREAD_WAITING_TO_CONTINUE; - debugTrace(DEBUG_gc, "GC thread %d waiting to continue...", + debugTrace(DEBUG_gc, "GC thread %d waiting to continue...", gct->thread_index); ACQUIRE_SPIN_LOCK(&gct->mut_spin); debugTrace(DEBUG_gc, "GC thread %d on my way...", gct->thread_index); @@ -1213,7 +1203,7 @@ releaseGCThreads (Capability *cap USED_IF_THREADS) if (i == me || gc_threads[i]->idle) continue; if (gc_threads[i]->wakeup != GC_THREAD_WAITING_TO_CONTINUE) barf("releaseGCThreads"); - + gc_threads[i]->wakeup = GC_THREAD_INACTIVE; ACQUIRE_SPIN_LOCK(&gc_threads[i]->gc_spin); RELEASE_SPIN_LOCK(&gc_threads[i]->mut_spin); @@ -1222,7 +1212,7 @@ releaseGCThreads (Capability *cap USED_IF_THREADS) #endif /* ---------------------------------------------------------------------------- - Initialise a generation that is to be collected + Initialise a generation that is to be collected ------------------------------------------------------------------------- */ static void @@ -1293,7 +1283,7 @@ prepare_collected_gen (generation *gen) for (bd = gen->old_blocks; bd; bd = bd->link) { bd->flags &= ~BF_EVACUATED; } - + // mark the large objects as from-space for (bd = gen->large_objects; bd; bd = bd->link) { bd->flags &= ~BF_EVACUATED; @@ -1304,7 +1294,7 @@ prepare_collected_gen (generation *gen) StgWord bitmap_size; // in bytes bdescr *bitmap_bdescr; StgWord *bitmap; - + bitmap_size = gen->n_old_blocks * BLOCK_SIZE / (sizeof(W_)*BITS_PER_BYTE); if (bitmap_size > 0) { @@ -1312,19 +1302,19 @@ prepare_collected_gen (generation *gen) / BLOCK_SIZE); gen->bitmap = bitmap_bdescr; bitmap = bitmap_bdescr->start; - + debugTrace(DEBUG_gc, "bitmap_size: %d, bitmap: %p", bitmap_size, bitmap); - + // don't forget to fill it with zeros! memset(bitmap, 0, bitmap_size); - + // For each block in this step, point to its bitmap from the // block descriptor. for (bd=gen->old_blocks; bd != NULL; bd = bd->link) { bd->u.bitmap = bitmap; bitmap += BLOCK_SIZE_W / (sizeof(W_)*BITS_PER_BYTE); - + // Also at this point we set the BF_MARKED flag // for this block. The invariant is that // BF_MARKED is always unset, except during GC @@ -1355,7 +1345,7 @@ stash_mut_list (Capability *cap, nat gen_no) } /* ---------------------------------------------------------------------------- - Initialise a generation that is *not* to be collected + Initialise a generation that is *not* to be collected ------------------------------------------------------------------------- */ static void @@ -1388,10 +1378,10 @@ collect_gct_blocks (void) nat g; gen_workspace *ws; bdescr *bd, *prev; - + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { ws = &gct->gens[g]; - + // there may still be a block attached to ws->todo_bd; // leave it there to use next time. @@ -1400,7 +1390,7 @@ collect_gct_blocks (void) ASSERT(gct->scan_bd == NULL); ASSERT(countBlocks(ws->scavd_list) == ws->n_scavd_blocks); - + prev = NULL; for (bd = ws->scavd_list; bd != NULL; bd = bd->link) { ws->gen->n_words += bd->free - bd->start; @@ -1409,7 +1399,7 @@ collect_gct_blocks (void) if (prev != NULL) { prev->link = ws->gen->blocks; ws->gen->blocks = ws->scavd_list; - } + } ws->gen->n_blocks += ws->n_scavd_blocks; ws->scavd_list = NULL; @@ -1492,9 +1482,9 @@ mark_root(void *user USED_IF_THREADS, StgClosure **root) saved_gct = gct; #endif SET_GCT(user); - + evacuate(root); - + SET_GCT(saved_gct); } @@ -1519,7 +1509,7 @@ zero_static_object_list(StgClosure* first_static) /* ---------------------------------------------------------------------------- Reset the sizes of the older generations when we do a major collection. - + CURRENT STRATEGY: make all generations except zero the same size. We have to stay within the maximum heap size, and leave a certain percentage of the maximum heap size available to allocate into. @@ -1534,7 +1524,7 @@ resize_generations (void) W_ live, size, min_alloc, words; const W_ max = RtsFlags.GcFlags.maxHeapSize; const W_ gens = RtsFlags.GcFlags.generations; - + // live in the oldest generations if (oldest_gen->live_estimate != 0) { words = oldest_gen->live_estimate; @@ -1543,11 +1533,11 @@ resize_generations (void) } live = (words + BLOCK_SIZE_W - 1) / BLOCK_SIZE_W + oldest_gen->n_large_blocks; - + // default max size for all generations except zero size = stg_max(live * RtsFlags.GcFlags.oldGenFactor, RtsFlags.GcFlags.minOldGenSize); - + if (RtsFlags.GcFlags.heapSizeSuggestionAuto) { if (max > 0) { RtsFlags.GcFlags.heapSizeSuggestion = stg_min(max, size); @@ -1564,7 +1554,7 @@ resize_generations (void) // certain percentage of the maximum heap size (default: 30%). if (RtsFlags.GcFlags.compact || (max > 0 && - oldest_gen->n_blocks > + oldest_gen->n_blocks > (RtsFlags.GcFlags.compactThreshold * max) / 100)) { oldest_gen->mark = 1; oldest_gen->compact = 1; @@ -1584,14 +1574,14 @@ resize_generations (void) // different if compaction is turned on, because we don't need // to double the space required to collect the old generation. if (max != 0) { - + // this test is necessary to ensure that the calculations // below don't have any negative results - we're working // with unsigned values here. if (max < min_alloc) { heapOverflow(); } - + if (oldest_gen->compact) { if ( (size + (size - 1) * (gens - 2) * 2) + min_alloc > max ) { size = (max - min_alloc) / ((gens - 1) * 2 - 1); @@ -1601,17 +1591,17 @@ resize_generations (void) size = (max - min_alloc) / ((gens - 1) * 2); } } - + if (size < live) { heapOverflow(); } } - + #if 0 debugBelch("live: %d, min_alloc: %d, size : %d, max = %d\n", live, min_alloc, size, max); #endif - + for (g = 0; g < gens; g++) { generations[g].max_blocks = size; } @@ -1630,7 +1620,7 @@ resize_nursery (void) if (RtsFlags.GcFlags.generations == 1) { // Two-space collector: W_ blocks; - + /* set up a new nursery. Allocate a nursery size based on a * function of the amount of live data (by default a factor of 2) * Use the blocks from the old nursery if possible, freeing up any @@ -1640,25 +1630,25 @@ resize_nursery (void) * size accordingly. If the nursery is the same size as the live * data (L), then we need 3L bytes. We can reduce the size of the * nursery to bring the required memory down near 2L bytes. - * + * * A normal 2-space collector would need 4L bytes to give the same * performance we get from 3L bytes, reducing to the same * performance at 2L bytes. */ blocks = generations[0].n_blocks; - + if ( RtsFlags.GcFlags.maxHeapSize != 0 && - blocks * RtsFlags.GcFlags.oldGenFactor * 2 > + blocks * RtsFlags.GcFlags.oldGenFactor * 2 > RtsFlags.GcFlags.maxHeapSize ) { - long adjusted_blocks; // signed on purpose - int pc_free; - + long adjusted_blocks; // signed on purpose + int pc_free; + adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks); - - debugTrace(DEBUG_gc, "near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld", + + debugTrace(DEBUG_gc, "near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks); - + pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize; if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even * be < 0 */ { @@ -1678,7 +1668,7 @@ resize_nursery (void) } else // Generational collector { - /* + /* * If the user has given us a suggested heap size, adjust our * allocation area to make best use of the memory available. */ @@ -1688,7 +1678,7 @@ resize_nursery (void) StgWord needed; calcNeeded(rtsFalse, &needed); // approx blocks needed at next GC - + /* Guess how much will be live in generation 0 step 0 next time. * A good approximation is obtained by finding the * percentage of g0 that was live at the last minor GC. @@ -1703,7 +1693,7 @@ resize_nursery (void) g0_pcnt_kept = ((copied / (BLOCK_SIZE_W - 10)) * 100) / countNurseryBlocks(); } - + /* Estimate a size for the allocation area based on the * information available. We might end up going slightly under * or over the suggested heap size, but we should be pretty @@ -1716,14 +1706,14 @@ resize_nursery (void) * where 'needed' is the amount of memory needed at the next * collection for collecting all gens except g0. */ - blocks = + blocks = (((long)RtsFlags.GcFlags.heapSizeSuggestion - (long)needed) * 100) / (100 + (long)g0_pcnt_kept); - + if (blocks < (long)min_nursery) { blocks = min_nursery; } - + resizeNurseries((W_)blocks); } else @@ -1744,7 +1734,7 @@ resize_nursery (void) whenever the program tries to enter a garbage collected CAF. Any garbage collected CAFs are taken off the CAF list at the same - time. + time. -------------------------------------------------------------------------- */ #if 0 && defined(DEBUG) @@ -1762,14 +1752,14 @@ gcCAFs(void) pp = &caf_list; while (p != NULL) { - + info = get_itbl(p); ASSERT(info->type == IND_STATIC); if (STATIC_LINK(info,p) == NULL) { debugTrace(DEBUG_gccafs, "CAF gc'd at 0x%04lx", (long)p); - // black hole it + // black hole it SET_INFO(p,&stg_BLACKHOLE_info); p = STATIC_LINK2(info,p); *pp = p; @@ -1782,6 +1772,6 @@ gcCAFs(void) } - debugTrace(DEBUG_gccafs, "%d CAFs live", i); + debugTrace(DEBUG_gccafs, "%d CAFs live", i); } #endif diff --git a/rts/sm/GCThread.h b/rts/sm/GCThread.h index 7aacb4eb51..748b0687fa 100644 --- a/rts/sm/GCThread.h +++ b/rts/sm/GCThread.h @@ -122,7 +122,7 @@ typedef struct gc_thread_ { OSThreadId id; // The OS thread that this struct belongs to SpinLock gc_spin; SpinLock mut_spin; - volatile rtsBool wakeup; + volatile StgWord8 wakeup; #endif nat thread_index; // a zero based index identifying the thread rtsBool idle; // sitting out of this GC cycle diff --git a/rts/sm/GCUtils.c b/rts/sm/GCUtils.c index 996b5f6280..d8633f98ea 100644 --- a/rts/sm/GCUtils.c +++ b/rts/sm/GCUtils.c @@ -161,6 +161,7 @@ push_scanned_block (bdescr *bd, gen_workspace *ws) StgPtr todo_block_full (nat size, gen_workspace *ws) { + rtsBool urgent_to_push, can_extend; StgPtr p; bdescr *bd; @@ -174,20 +175,49 @@ todo_block_full (nat size, gen_workspace *ws) ASSERT(bd->link == NULL); ASSERT(bd->gen == ws->gen); - // If the global list is not empty, or there's not much work in - // this block to push, and there's enough room in - // this block to evacuate the current object, then just increase - // the limit. - if (!looksEmptyWSDeque(ws->todo_q) || - (ws->todo_free - bd->u.scan < WORK_UNIT_WORDS / 2)) { - if (ws->todo_free + size < bd->start + bd->blocks * BLOCK_SIZE_W) { - ws->todo_lim = stg_min(bd->start + bd->blocks * BLOCK_SIZE_W, - ws->todo_lim + stg_max(WORK_UNIT_WORDS,size)); - debugTrace(DEBUG_gc, "increasing limit for %p to %p", bd->start, ws->todo_lim); - p = ws->todo_free; - ws->todo_free += size; - return p; - } + // We intentionally set ws->todo_lim lower than the full size of + // the block, so that we can push out some work to the global list + // and get the parallel threads working as soon as possible. + // + // So when ws->todo_lim is reached, we end up here and have to + // decide whether it's worth pushing out the work we have or not. + // If we have enough room in the block to evacuate the current + // object, and it's not urgent to push this work, then we just + // extend the limit and keep going. Where "urgent" is defined as: + // the global pool is empty, and there's enough work in this block + // to make it worth pushing. + // + urgent_to_push = + looksEmptyWSDeque(ws->todo_q) && + (ws->todo_free - bd->u.scan >= WORK_UNIT_WORDS / 2); + + // We can extend the limit for the current block if there's enough + // room for the current object, *and* we're not into the second or + // subsequent block of a large block. The second condition occurs + // when we evacuate an object that is larger than a block. In + // that case, alloc_todo_block() sets todo_lim to be exactly the + // size of the large object, and we don't evacuate any more + // objects into this block. The reason is that the rest of the GC + // is not set up to handle objects that start in the second or + // later blocks of a group. We just about manage this in the + // nursery (see scheduleHandleHeapOverflow()) so evacuate() can + // handle this, but other parts of the GC can't. We could + // probably fix this, but it's a rare case anyway. + // + can_extend = + ws->todo_free + size <= bd->start + bd->blocks * BLOCK_SIZE_W + && ws->todo_free < ws->todo_bd->start + BLOCK_SIZE_W; + + if (!urgent_to_push && can_extend) + { + ws->todo_lim = stg_min(bd->start + bd->blocks * BLOCK_SIZE_W, + ws->todo_lim + stg_max(WORK_UNIT_WORDS,size)); + debugTrace(DEBUG_gc, "increasing limit for %p to %p", + bd->start, ws->todo_lim); + p = ws->todo_free; + ws->todo_free += size; + + return p; } gct->copied += ws->todo_free - bd->free; @@ -201,12 +231,19 @@ todo_block_full (nat size, gen_workspace *ws) { // If this block does not have enough space to allocate the // current object, but it also doesn't have any work to push, then - // push it on to the scanned list. It cannot be empty, because - // then there would be enough room to copy the current object. + // push it on to the scanned list. if (bd->u.scan == bd->free) { - ASSERT(bd->free != bd->start); - push_scanned_block(bd, ws); + if (bd->free == bd->start) { + // Normally the block would not be empty, because then + // there would be enough room to copy the current + // object. However, if the object we're copying is + // larger than a block, then we might have an empty + // block here. + freeGroup(bd); + } else { + push_scanned_block(bd, ws); + } } // Otherwise, push this block out to the global list. else diff --git a/rts/sm/MarkStack.h b/rts/sm/MarkStack.h index db79ca4520..e2319a544d 100644 --- a/rts/sm/MarkStack.h +++ b/rts/sm/MarkStack.h @@ -12,7 +12,7 @@ * ---------------------------------------------------------------------------*/ #ifndef SM_MARKSTACK_H -#define SM_MARKSTACk_H +#define SM_MARKSTACK_H #include "BeginPrivate.h" diff --git a/rts/sm/MarkWeak.c b/rts/sm/MarkWeak.c index d57f7a094b..f0ab5d19d7 100644 --- a/rts/sm/MarkWeak.c +++ b/rts/sm/MarkWeak.c @@ -75,164 +75,133 @@ typedef enum { WeakPtrs, WeakThreads, WeakDone } WeakStage; static WeakStage weak_stage; -/* Weak pointers - */ -StgWeak *old_weak_ptr_list; // also pending finaliser list -StgWeak *weak_ptr_list_tail; +// List of weak pointers whose key is dead +StgWeak *dead_weak_ptr_list; // List of threads found to be unreachable StgTSO *resurrected_threads; -static void resurrectUnreachableThreads (generation *gen); -static rtsBool tidyThreadList (generation *gen); +static void collectDeadWeakPtrs (generation *gen); +static rtsBool tidyWeakList (generation *gen); +static rtsBool resurrectUnreachableThreads (generation *gen); +static void tidyThreadList (generation *gen); void initWeakForGC(void) { - old_weak_ptr_list = weak_ptr_list; - weak_ptr_list = NULL; - weak_ptr_list_tail = NULL; - weak_stage = WeakPtrs; + nat g; + + for (g = 0; g <= N; g++) { + generation *gen = &generations[g]; + gen->old_weak_ptr_list = gen->weak_ptr_list; + gen->weak_ptr_list = NULL; + } + + weak_stage = WeakThreads; + dead_weak_ptr_list = NULL; resurrected_threads = END_TSO_QUEUE; } rtsBool traverseWeakPtrList(void) { - StgWeak *w, **last_w, *next_w; - StgClosure *new; rtsBool flag = rtsFalse; - const StgInfoTable *info; switch (weak_stage) { case WeakDone: return rtsFalse; - case WeakPtrs: - /* doesn't matter where we evacuate values/finalizers to, since - * these pointers are treated as roots (iff the keys are alive). - */ - gct->evac_gen_no = 0; - - last_w = &old_weak_ptr_list; - for (w = old_weak_ptr_list; w != NULL; w = next_w) { - - /* There might be a DEAD_WEAK on the list if finalizeWeak# was - * called on a live weak pointer object. Just remove it. - */ - if (w->header.info == &stg_DEAD_WEAK_info) { - next_w = ((StgDeadWeak *)w)->link; - *last_w = next_w; - continue; - } - - info = get_itbl((StgClosure *)w); - switch (info->type) { - - case WEAK: - /* Now, check whether the key is reachable. - */ - new = isAlive(w->key); - if (new != NULL) { - w->key = new; - // evacuate the value and finalizer - evacuate(&w->value); - evacuate(&w->finalizer); - // remove this weak ptr from the old_weak_ptr list - *last_w = w->link; - next_w = w->link; - - // and put it on the new weak ptr list. - // NB. we must retain the order of the weak_ptr_list (#7160) - if (weak_ptr_list == NULL) { - weak_ptr_list = w; - } else { - weak_ptr_list_tail->link = w; - } - weak_ptr_list_tail = w; - w->link = NULL; - flag = rtsTrue; - - debugTrace(DEBUG_weak, - "weak pointer still alive at %p -> %p", - w, w->key); - continue; - } - else { - last_w = &(w->link); - next_w = w->link; - continue; - } - - default: - barf("traverseWeakPtrList: not WEAK"); - } - } - - /* If we didn't make any changes, then we can go round and kill all - * the dead weak pointers. The old_weak_ptr list is used as a list - * of pending finalizers later on. - */ - if (flag == rtsFalse) { - for (w = old_weak_ptr_list; w; w = w->link) { - evacuate(&w->finalizer); - } - - // Next, move to the WeakThreads stage after fully - // scavenging the finalizers we've just evacuated. - weak_stage = WeakThreads; - } - - return rtsTrue; - case WeakThreads: - /* Now deal with the step->threads lists, which behave somewhat like + /* Now deal with the gen->threads lists, which behave somewhat like * the weak ptr list. If we discover any threads that are about to * become garbage, we wake them up and administer an exception. */ { nat g; - // Traverse thread lists for generations we collected... -// ToDo when we have one gen per capability: -// for (n = 0; n < n_capabilities; n++) { -// if (tidyThreadList(&nurseries[n])) { -// flag = rtsTrue; -// } -// } for (g = 0; g <= N; g++) { - if (tidyThreadList(&generations[g])) { + tidyThreadList(&generations[g]); + } + + // Use weak pointer relationships (value is reachable if + // key is reachable): + for (g = 0; g <= N; g++) { + if (tidyWeakList(&generations[g])) { flag = rtsTrue; } } + + // if we evacuated anything new, we must scavenge thoroughly + // before we can determine which threads are unreachable. + if (flag) return rtsTrue; - /* If we evacuated any threads, we need to go back to the scavenger. - */ + // Resurrect any threads which were unreachable + for (g = 0; g <= N; g++) { + if (resurrectUnreachableThreads(&generations[g])) { + flag = rtsTrue; + } + } + + // Next, move to the WeakPtrs stage after fully + // scavenging the finalizers we've just evacuated. + weak_stage = WeakPtrs; + + // if we evacuated anything new, we must scavenge thoroughly + // before entering the WeakPtrs stage. if (flag) return rtsTrue; - /* And resurrect any threads which were about to become garbage. + // otherwise, fall through... + } + + case WeakPtrs: + { + nat g; + + // resurrecting threads might have made more weak pointers + // alive, so traverse those lists again: + for (g = 0; g <= N; g++) { + if (tidyWeakList(&generations[g])) { + flag = rtsTrue; + } + } + + /* If we didn't make any changes, then we can go round and kill all + * the dead weak pointers. The dead_weak_ptr list is used as a list + * of pending finalizers later on. */ - { - nat g; + if (flag == rtsFalse) { for (g = 0; g <= N; g++) { - resurrectUnreachableThreads(&generations[g]); + collectDeadWeakPtrs(&generations[g]); } + + weak_stage = WeakDone; // *now* we're done, } - - weak_stage = WeakDone; // *now* we're done, + return rtsTrue; // but one more round of scavenging, please } - + default: barf("traverse_weak_ptr_list"); return rtsTrue; } } - static void resurrectUnreachableThreads (generation *gen) +static void collectDeadWeakPtrs (generation *gen) +{ + StgWeak *w, *next_w; + for (w = gen->old_weak_ptr_list; w != NULL; w = next_w) { + evacuate(&w->finalizer); + next_w = w->link; + w->link = dead_weak_ptr_list; + dead_weak_ptr_list = w; + } +} + +static rtsBool resurrectUnreachableThreads (generation *gen) { StgTSO *t, *tmp, *next; + rtsBool flag = rtsFalse; for (t = gen->old_threads; t != END_TSO_QUEUE; t = next) { next = t->global_link; @@ -250,14 +219,89 @@ traverseWeakPtrList(void) evacuate((StgClosure **)&tmp); tmp->global_link = resurrected_threads; resurrected_threads = tmp; + flag = rtsTrue; } } + return flag; } -static rtsBool tidyThreadList (generation *gen) +static rtsBool tidyWeakList(generation *gen) { - StgTSO *t, *tmp, *next, **prev; + StgWeak *w, **last_w, *next_w; + const StgInfoTable *info; + StgClosure *new; rtsBool flag = rtsFalse; + last_w = &gen->old_weak_ptr_list; + for (w = gen->old_weak_ptr_list; w != NULL; w = next_w) { + + /* There might be a DEAD_WEAK on the list if finalizeWeak# was + * called on a live weak pointer object. Just remove it. + */ + if (w->header.info == &stg_DEAD_WEAK_info) { + next_w = w->link; + *last_w = next_w; + continue; + } + + info = get_itbl((StgClosure *)w); + switch (info->type) { + + case WEAK: + /* Now, check whether the key is reachable. + */ + new = isAlive(w->key); + if (new != NULL) { + generation *new_gen; + + w->key = new; + + // Find out which generation this weak ptr is in, and + // move it onto the weak ptr list of that generation. + + new_gen = Bdescr((P_)w)->gen; + gct->evac_gen_no = new_gen->no; + + // evacuate the value and finalizer + evacuate(&w->value); + evacuate(&w->finalizer); + // remove this weak ptr from the old_weak_ptr list + *last_w = w->link; + next_w = w->link; + + // and put it on the correct weak ptr list. + w->link = new_gen->weak_ptr_list; + new_gen->weak_ptr_list = w; + flag = rtsTrue; + + if (gen->no != new_gen->no) { + debugTrace(DEBUG_weak, + "moving weak pointer %p from %d to %d", + w, gen->no, new_gen->no); + } + + + debugTrace(DEBUG_weak, + "weak pointer still alive at %p -> %p", + w, w->key); + continue; + } + else { + last_w = &(w->link); + next_w = w->link; + continue; + } + + default: + barf("tidyWeakList: not WEAK: %d, %p", info->type, w); + } + } + + return flag; +} + +static void tidyThreadList (generation *gen) +{ + StgTSO *t, *tmp, *next, **prev; prev = &gen->old_threads; @@ -297,45 +341,45 @@ static rtsBool tidyThreadList (generation *gen) new_gen->threads = t; } } - - return flag; } /* ----------------------------------------------------------------------------- Evacuate every weak pointer object on the weak_ptr_list, and update the link fields. - - ToDo: with a lot of weak pointers, this will be expensive. We - should have a per-GC weak pointer list, just like threads. -------------------------------------------------------------------------- */ void markWeakPtrList ( void ) { - StgWeak *w, **last_w; + nat g; + + for (g = 0; g <= N; g++) { + generation *gen = &generations[g]; + StgWeak *w, **last_w; - last_w = &weak_ptr_list; - for (w = weak_ptr_list; w; w = w->link) { - // w might be WEAK, EVACUATED, or DEAD_WEAK (actually CON_STATIC) here + last_w = &gen->weak_ptr_list; + for (w = gen->weak_ptr_list; w != NULL; w = w->link) { + // w might be WEAK, EVACUATED, or DEAD_WEAK (actually CON_STATIC) here #ifdef DEBUG - { // careful to do this assertion only reading the info ptr - // once, because during parallel GC it might change under our feet. - const StgInfoTable *info; - info = w->header.info; - ASSERT(IS_FORWARDING_PTR(info) - || info == &stg_DEAD_WEAK_info - || INFO_PTR_TO_STRUCT(info)->type == WEAK); - } + { // careful to do this assertion only reading the info ptr + // once, because during parallel GC it might change under our feet. + const StgInfoTable *info; + info = w->header.info; + ASSERT(IS_FORWARDING_PTR(info) + || info == &stg_DEAD_WEAK_info + || INFO_PTR_TO_STRUCT(info)->type == WEAK); + } #endif - evacuate((StgClosure **)last_w); - w = *last_w; - if (w->header.info == &stg_DEAD_WEAK_info) { - last_w = &(((StgDeadWeak*)w)->link); - } else { - last_w = &(w->link); - } - } + evacuate((StgClosure **)last_w); + w = *last_w; + if (w->header.info == &stg_DEAD_WEAK_info) { + last_w = &(w->link); + } else { + last_w = &(w->link); + } + } + } } diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c index f0e1659e12..9b579abbbc 100644 --- a/rts/sm/Sanity.c +++ b/rts/sm/Sanity.c @@ -519,6 +519,7 @@ checkTSO(StgTSO *tso) info == &stg_WHITEHOLE_info); // happens due to STM doing lockTSO() if ( tso->why_blocked == BlockedOnMVar + || tso->why_blocked == BlockedOnMVarRead || tso->why_blocked == BlockedOnBlackHole || tso->why_blocked == BlockedOnMsgThrowTo || tso->why_blocked == NotBlocked diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c index 6137f6d862..e0cc688b95 100644 --- a/rts/sm/Scav.c +++ b/rts/sm/Scav.c @@ -71,6 +71,7 @@ scavengeTSO (StgTSO *tso) evacuate((StgClosure **)&tso->_link); if ( tso->why_blocked == BlockedOnMVar + || tso->why_blocked == BlockedOnMVarRead || tso->why_blocked == BlockedOnBlackHole || tso->why_blocked == BlockedOnMsgThrowTo || tso->why_blocked == NotBlocked diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c index 5c4e54f98d..a5337bc5b2 100644 --- a/rts/sm/Storage.c +++ b/rts/sm/Storage.c @@ -29,6 +29,9 @@ #include "Trace.h" #include "GC.h" #include "Evac.h" +#if defined(ios_HOST_OS) +#include "Hash.h" +#endif #include <string.h> @@ -90,6 +93,8 @@ initGeneration (generation *gen, int g) #endif gen->threads = END_TSO_QUEUE; gen->old_threads = END_TSO_QUEUE; + gen->weak_ptr_list = NULL; + gen->old_weak_ptr_list = NULL; } void @@ -166,7 +171,6 @@ initStorage (void) generations[0].max_blocks = 0; - weak_ptr_list = NULL; caf_list = END_OF_STATIC_LIST; revertible_caf_list = END_OF_STATIC_LIST; @@ -1094,7 +1098,7 @@ calcNeeded (rtsBool force_major, memcount *blocks_needed) // because it knows how to work around the restrictions put in place // by SELinux. -void *allocateExec (W_ bytes, void **exec_ret) +AdjustorWritable allocateExec (W_ bytes, AdjustorExecutable *exec_ret) { void **ret, **exec; ACQUIRE_SM_LOCK; @@ -1107,18 +1111,65 @@ void *allocateExec (W_ bytes, void **exec_ret) } // freeExec gets passed the executable address, not the writable address. -void freeExec (void *addr) +void freeExec (AdjustorExecutable addr) { - void *writable; + AdjustorWritable writable; writable = *((void**)addr - 1); ACQUIRE_SM_LOCK; ffi_closure_free (writable); RELEASE_SM_LOCK } +#elif defined(ios_HOST_OS) + +static HashTable* allocatedExecs; + +AdjustorWritable allocateExec(W_ bytes, AdjustorExecutable *exec_ret) +{ + AdjustorWritable writ; + ffi_closure* cl; + if (bytes != sizeof(ffi_closure)) { + barf("allocateExec: for ffi_closure only"); + } + ACQUIRE_SM_LOCK; + cl = writ = ffi_closure_alloc((size_t)bytes, exec_ret); + if (cl != NULL) { + if (allocatedExecs == NULL) { + allocatedExecs = allocHashTable(); + } + insertHashTable(allocatedExecs, (StgWord)*exec_ret, writ); + } + RELEASE_SM_LOCK; + return writ; +} + +AdjustorWritable execToWritable(AdjustorExecutable exec) +{ + AdjustorWritable writ; + ACQUIRE_SM_LOCK; + if (allocatedExecs == NULL || + (writ = lookupHashTable(allocatedExecs, (StgWord)exec)) == NULL) { + RELEASE_SM_LOCK; + barf("execToWritable: not found"); + } + RELEASE_SM_LOCK; + return writ; +} + +void freeExec(AdjustorExecutable exec) +{ + AdjustorWritable writ; + ffi_closure* cl; + cl = writ = execToWritable(exec); + ACQUIRE_SM_LOCK; + removeHashTable(allocatedExecs, (StgWord)exec, writ); + ffi_closure_free(cl); + RELEASE_SM_LOCK +} + #else -void *allocateExec (W_ bytes, void **exec_ret) +AdjustorWritable allocateExec (W_ bytes, AdjustorExecutable *exec_ret) { void *ret; W_ n; diff --git a/rules/bindist.mk b/rules/bindist.mk index cf49c6930f..ee730535e4 100644 --- a/rules/bindist.mk +++ b/rules/bindist.mk @@ -25,7 +25,7 @@ bindist: bindist_$1 bindist_$1: $(foreach i,$2,\ $(call make-command,\ - for f in $i; do echo $(BIN_DIST_NAME)/$$$$f >> $(BIN_DIST_LIST); done \ + for f in $i; do echo $(BIN_DIST_NAME)/$$$$f >> bindist-list; done \ ) \ ) endef diff --git a/rules/build-dependencies.mk b/rules/build-dependencies.mk index bb047f62f0..2edb9c9511 100644 --- a/rules/build-dependencies.mk +++ b/rules/build-dependencies.mk @@ -31,7 +31,7 @@ ifneq "$$(NO_GENERATED_MAKEFILE_RULES)" "YES" # indirectly) include the generated includes files. $$($1_$2_depfile_haskell) : $$(includes_H_CONFIG) $$(includes_H_PLATFORM) -$$($1_$2_depfile_haskell) : $$($1_$2_HS_SRCS) $$($1_$2_HS_BOOT_SRCS) $$($1_$2_HC_MK_DEPEND_DEP) | $$$$(dir $$$$@)/. +$$($1_$2_depfile_haskell) : $$($1_$2_HS_SRCS) $$($1_$2_HS_BOOT_SRCS) $$$$($1_$2_HC_MK_DEPEND_DEP) | $$$$(dir $$$$@)/. $$(call removeFiles,$$@.tmp) ifneq "$$($1_$2_HS_SRCS)" "" "$$($1_$2_HC_MK_DEPEND)" -M \ @@ -49,6 +49,10 @@ endif # within the build tree. On Windows this causes a problem as they look # like bad rules, due to the two colons, so we filter them out. grep -v ' : [a-zA-Z]:/' $$@.tmp > $$@.tmp2 +# Insert the calls to hi-rule. Basically, we look for the +# Foo.dyn_o Foo.o : Foo.hs +# lines, and create corresponding hi-rule lines +# <dollar>(eval <dollar>(call hi-rule,Foo.dyn_hi Foo.hi : %hi: %o Foo.hs)) sed '/hs$$$$/ p ; \ /hs$$$$/ s/o /hi /g ; \ /hs$$$$/ s/:/ : %hi: %o / ; \ @@ -65,14 +69,14 @@ endif # includes files. $$($1_$2_depfile_c_asm) : $$(includes_H_CONFIG) $$(includes_H_PLATFORM) -$$($1_$2_depfile_c_asm) : $$($1_$2_C_FILES_DEPS) $$($1_$2_S_FILES) | $$$$(dir $$$$@)/. +$$($1_$2_depfile_c_asm) : $$($1_$2_C_FILES_DEPS) $$($1_$2_S_FILES) $$($1_$2_CMM_FILES) | $$$$(dir $$$$@)/. $$(call removeFiles,$$@.tmp) -ifneq "$$(strip $$($1_$2_C_FILES_DEPS)$$($1_$2_S_FILES))" "" +ifneq "$$(strip $$($1_$2_C_FILES_DEPS) $$($1_$2_S_FILES)) $$($1_$2_CMM_FILES))" "" # We ought to actually do this for each way in $$($1_$2_WAYS), but then # it takes a long time to make the C deps for the RTS (30 seconds rather # than 3), so instead we just pass the list of ways in and let addCFileDeps # copy the deps for each way on the assumption that they are the same - $$(foreach f,$$($1_$2_C_FILES_DEPS) $$($1_$2_S_FILES), \ + $$(foreach f,$$($1_$2_C_FILES_DEPS) $$($1_$2_S_FILES) $$($1_$2_CMM_FILES), \ $$(call addCFileDeps,$1,$2,$$($1_$2_depfile_c_asm),$$f,$$($1_$2_WAYS))) $$(call removeFiles,$$@.bit) endif @@ -135,9 +139,15 @@ endef # need to do the substitution case-insensitively on Windows. But # the s///i modifier isn't portable, so we set CASE_INSENSITIVE_SED # to "i" on Windows and "" on any other platform. + +# We use this not only for .c files, but also for .S and .cmm files. +# As gcc doesn't know what a .cmm file is, it treats it as a linker +# input and ignores it. We therefore tell gcc that all files are C +# files with "-x c" so that it actually processes them all. + define addCFileDeps - $(CPP) $($1_$2_MKDEPENDC_OPTS) $($1_$2_$(firstword $($1_$2_WAYS))_ALL_CC_OPTS) $($(basename $4)_CC_OPTS) -MM $4 -MF $3.bit + $(CPP) $($1_$2_MKDEPENDC_OPTS) $($1_$2_$(firstword $($1_$2_WAYS))_ALL_CC_OPTS) $($(basename $4)_CC_OPTS) -MM -x c $4 -MF $3.bit $(foreach w,$5,sed -e 's|\\|/|g' -e 's| /$$| \\|' -e "1s|\.o|\.$($w_osuf)|" -e "1s|^|$(dir $4)|" -e "1s|$1/|$1/$2/build/|" -e "1s|$2/build/$2/build|$2/build|g" -e "s|$(TOP)/||g$(CASE_INSENSITIVE_SED)" $3.bit >> $3.tmp &&) true endef diff --git a/rules/build-package-data.mk b/rules/build-package-data.mk index cf67baf33c..82a2535844 100644 --- a/rules/build-package-data.mk +++ b/rules/build-package-data.mk @@ -86,7 +86,7 @@ endif $1_$2_CONFIGURE_OPTS += --configure-option=--with-cc="$$(CC_STAGE$3)" $1_$2_CONFIGURE_OPTS += --with-ar="$$(AR_STAGE$3)" -$1_$2_CONFIGURE_OPTS += --with-ranlib="$$(RANLIB)" +$1_$2_CONFIGURE_OPTS += --with-ranlib="$$(REAL_RANLIB_CMD)" $1_$2_CONFIGURE_OPTS += $$(if $$(ALEX),--with-alex="$$(ALEX)") $1_$2_CONFIGURE_OPTS += $$(if $$(HAPPY),--with-happy="$$(HAPPY)") @@ -98,7 +98,7 @@ $1/$2/build/autogen/cabal_macros.h : $1/$2/package-data.mk # This rule configures the package, generates the package-data.mk file # for our build system, and registers the package for use in-place in # the build tree. -$1/$2/package-data.mk : $$$$(ghc-cabal_INPLACE) $$($1_$2_GHC_PKG_DEP) $1/$$($1_PACKAGE).cabal $$(wildcard $1/configure) $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_CONFIG_DEP) +$1/$2/package-data.mk : $$$$(ghc-cabal_INPLACE) $$($1_$2_GHC_PKG_DEP) $1/$$($1_PACKAGE).cabal $$(wildcard $1/configure) $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_CONFIG_DEP) # Checking packages built with the bootstrapping compiler would # generally be a waste of time. Either we will rebuild them with # stage1/stage2, or we don't really care about them. @@ -107,7 +107,7 @@ ifneq "$$($1_NO_CHECK)" "YES" "$$(ghc-cabal_INPLACE)" check $1 endif endif - "$$(ghc-cabal_INPLACE)" configure --with-ghc="$$($1_$2_HC_CONFIG)" --with-ghc-pkg="$$($1_$2_GHC_PKG)" $$($1_CONFIGURE_OPTS) $$($1_$2_CONFIGURE_OPTS) -- $2 $1 + "$$(ghc-cabal_INPLACE)" configure $1 $2 "$$($1_$2_dll0_MODULES)" --with-ghc="$$($1_$2_HC_CONFIG)" --with-ghc-pkg="$$($1_$2_GHC_PKG)" $$($1_CONFIGURE_OPTS) $$($1_$2_CONFIGURE_OPTS) ifeq "$$($1_$2_PROG)" "" ifneq "$$($1_$2_REGISTER_PACKAGE)" "NO" $$(call cmd,$1_$2_GHC_PKG) update --force $$($1_$2_GHC_PKG_OPTS) $1/$2/inplace-pkg-config diff --git a/rules/build-package-way.mk b/rules/build-package-way.mk index 9277b551b2..780b8b0f48 100644 --- a/rules/build-package-way.mk +++ b/rules/build-package-way.mk @@ -63,8 +63,8 @@ $$($1_$2_$3_LIB0) : $1/$2/dll-split.stamp endif endif -$1/$2/dll-split.stamp: $$($1_$2_depfile_haskell) inplace/bin/dll-split$$(exeext) - inplace/bin/dll-split $$< "$$($1_$2_dll0_START_MODULE)" "$$($1_$2_dll0_MODULES)" +$1/$2/dll-split.stamp: $$($1_$2_depfile_haskell) $$$$(dll-split_INPLACE) + $$(dll-split_INPLACE) $$< "$$($1_$2_dll0_START_MODULE)" "$$($1_$2_dll0_MODULES)" touch $$@ # Link a dynamic library @@ -91,6 +91,7 @@ $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS) $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) $$(addprefix -L,$$($1_$2_EXTRA_LIBDIRS)) \ -no-auto-link-packages \ -o $$@ + $(call relative-dynlib-references,$1,$2,$4) endif else # Build the ordinary .a library diff --git a/rules/build-prog.mk b/rules/build-prog.mk index 468fcafc45..8c49946f1c 100644 --- a/rules/build-prog.mk +++ b/rules/build-prog.mk @@ -33,7 +33,7 @@ endif ifneq "$$($1_$2_PROG)" "" $$(error $1_$2_PROG is set) endif -$1_$2_PROG = $$($1_$2_PROGNAME)$$(exeext) +$1_$2_PROG = $$($1_$2_PROGNAME)$$(exeext$3) endif ifeq "$$(findstring $3,0 1 2)" "" @@ -42,6 +42,8 @@ endif $(call clean-target,$1,$2,$1/$2) +$$(eval $$(call build-prog-vars,$1,$2,$3)) + ifneq "$$($1_$2_NOT_NEEDED)" "YES" $$(eval $$(call build-prog-helper,$1,$2,$3)) endif @@ -49,7 +51,7 @@ $(call profEnd, build-prog($1,$2,$3)) endef -define build-prog-helper +define build-prog-vars # $1 = dir # $2 = distdir # $3 = GHC stage to use (0 == bootstrapping compiler) @@ -80,8 +82,6 @@ else $1_$2_WANT_INSTALLED_WRAPPER = NO endif -$(call package-config,$1,$2,$3) - $1_$2_depfile_base = $1/$2/build/.depend ifeq "$$($1_$2_INSTALL_INPLACE)" "NO" @@ -109,6 +109,15 @@ $1_$2_INPLACE = $$($$($1_$2_PROGNAME)_INPLACE) endif endif +endef + +define build-prog-helper +# $1 = dir +# $2 = distdir +# $3 = GHC stage to use (0 == bootstrapping compiler) + +$(call package-config,$1,$2,$3) + ifeq "$$($1_$2_USES_CABAL)" "YES" $(call build-package-data,$1,$2,$3) ifneq "$$(NO_INCLUDE_PKGDATA)" "YES" @@ -123,14 +132,6 @@ endif $(call all-target,$1,all_$1_$2) $(call all-target,$1_$2,$1/$2/build/tmp/$$($1_$2_PROG)) -# INPLACE_BIN might be empty if we're distcleaning -ifeq "$(findstring clean,$(MAKECMDGOALS))" "" -ifeq "$$($1_$2_INSTALL_INPLACE)" "YES" -$$($1_$2_INPLACE) : $1/$2/build/tmp/$$($1_$2_PROG) | $$$$(dir $$$$@)/. - "$$(CP)" -p $$< $$@ -endif -endif - $(call shell-wrapper,$1,$2) ifeq "$$($1_$2_PROGRAM_WAY)" "" @@ -152,7 +153,7 @@ $(call c-sources,$1,$2) # --- IMPLICIT RULES -$(call distdir-opts,$1,$2,,$3) +$(call distdir-opts,$1,$2,$3) $(call distdir-way-opts,$1,$2,$$($1_$2_PROGRAM_WAY),$3) ifeq "$3" "0" @@ -195,9 +196,63 @@ $1/$2/build/tmp/$$($1_$2_PROG) $1/$2/build/tmp/$$($1_$2_PROG).dll : \ $$(error Bad build stage)))),\ $$$$($$(dep)_dist-$(if $(filter 0,$3),boot,install)_PROGRAM_DEP_LIB))) +$1_$2_PROG_NEEDS_C_WRAPPER = NO +$1_$2_PROG_INPLACE = $$($1_$2_PROG) ifeq "$$(Windows_Host) $$($1_$2_PROGRAM_WAY)" "YES dyn" -$1/$2/build/tmp/$$($1_$2_PROG) : $1/$2/build/tmp/$$($1_$2_PROG).c $1/$2/build/tmp/$$($1_$2_PROG).dll | $$$$(dir $$$$@)/. - $$(call cmd,$1_$2_HC) -no-hs-main -optc-g -optc-O0 $$< -o $$@ +ifneq "$$($1_$2_HS_SRCS)" "" +$1_$2_PROG_NEEDS_C_WRAPPER = YES +$1_$2_PROG_INPLACE = inplace-$$($1_$2_PROG) +endif +endif + +ifeq "$$($1_$2_PROG_NEEDS_C_WRAPPER)" "YES" + +$1_$2_RTS_OPTS_FLAG = $$(lastword $$(filter -rtsopts -rtsopts=all -rtsopts=some -rtsopts=none -no-rtsopts,$$($1_$2_$$($1_$2_PROGRAM_WAY)_ALL_HC_OPTS))) +ifeq "$$($1_$2_RTS_OPTS_FLAG)" "-rtsopts" +$1_$2_RTS_OPTS = RtsOptsAll +else ifeq "$$($1_$2_RTS_OPTS_FLAG)" "-rtsopts=all" +$1_$2_RTS_OPTS = RtsOptsAll +else ifeq "$$($1_$2_RTS_OPTS_FLAG)" "-rtsopts=some" +$1_$2_RTS_OPTS = RtsOptsSafeOnly +else ifeq "$$($1_$2_RTS_OPTS_FLAG)" "-rtsopts=none" +$1_$2_RTS_OPTS = RtsOptsNone +else ifeq "$$($1_$2_RTS_OPTS_FLAG)" "-no-rtsopts" +$1_$2_RTS_OPTS = RtsOptsNone +else +$1_$2_RTS_OPTS = RtsOptsSafeOnly +endif + +$1/$2/build/tmp/$$($1_$2_PROG)-inplace-wrapper.c: driver/utils/dynwrapper.c | $$$$(dir $$$$@)/. + $$(call removeFiles,$$@) + echo '#include <Windows.h>' >> $$@ + echo '#include "Rts.h"' >> $$@ + echo 'LPTSTR path_dirs[] = {' >> $$@ + $$(foreach d,$$($1_$2_DEP_LIB_REL_DIRS),$$(call make-command,echo ' TEXT("/../../$$d")$$(comma)' >> $$@)) + echo ' TEXT("/../../$1/$2/build/tmp/"),' >> $$@ + echo ' NULL};' >> $$@ + echo 'LPTSTR progDll = TEXT("../../$1/$2/build/tmp/$$($1_$2_PROG).dll");' >> $$@ + echo 'LPTSTR rtsDll = TEXT("$$($$(WINDOWS_DYN_PROG_RTS))");' >> $$@ + echo 'int rtsOpts = $$($1_$2_RTS_OPTS);' >> $$@ + cat driver/utils/dynwrapper.c >> $$@ + +$1/$2/build/tmp/$$($1_$2_PROG)-wrapper.c: driver/utils/dynwrapper.c | $$$$(dir $$$$@)/. + $$(call removeFiles,$$@) + echo '#include <Windows.h>' >> $$@ + echo '#include "Rts.h"' >> $$@ + echo 'LPTSTR path_dirs[] = {' >> $$@ + $$(foreach p,$$($1_$2_TRANSITIVE_DEPS),$$(call make-command,echo ' TEXT("/../lib/$$p")$$(comma)' >> $$@)) + echo ' TEXT("/../lib/"),' >> $$@ + echo ' NULL};' >> $$@ + echo 'LPTSTR progDll = TEXT("../lib/$$($1_$2_PROG).dll");' >> $$@ + echo 'LPTSTR rtsDll = TEXT("$$($$(WINDOWS_DYN_PROG_RTS))");' >> $$@ + echo 'int rtsOpts = $$($1_$2_RTS_OPTS);' >> $$@ + cat driver/utils/dynwrapper.c >> $$@ + +$1/$2/build/tmp/$$($1_$2_PROG_INPLACE) : $1/$2/build/tmp/$$($1_$2_PROG)-inplace-wrapper.c $1/$2/build/tmp/$$($1_$2_PROG).dll | $$$$(dir $$$$@)/. + $$(call cmd,$1_$2_HC) -no-hs-main -no-auto-link-packages -optc-g -optc-O0 -Iincludes $$< -o $$@ + +$1/$2/build/tmp/$$($1_$2_PROG) : $1/$2/build/tmp/$$($1_$2_PROG)-wrapper.c $1/$2/build/tmp/$$($1_$2_PROG).dll | $$$$(dir $$$$@)/. + $$(call cmd,$1_$2_HC) -no-hs-main -no-auto-link-packages -optc-g -optc-O0 -Iincludes $$< -o $$@ $1/$2/build/tmp/$$($1_$2_PROG).dll : $$($1_$2_$$($1_$2_PROGRAM_WAY)_HS_OBJS) $$($1_$2_$$($1_$2_PROGRAM_WAY)_C_OBJS) $$($1_$2_$$($1_$2_PROGRAM_WAY)_S_OBJS) $$($1_$2_OTHER_OBJS) | $$$$(dir $$$$@)/. $$(call build-dll,$1,$2,$$($1_$2_PROGRAM_WAY),,$$($1_$2_$$($1_$2_PROGRAM_WAY)_HS_OBJS) $$($1_$2_$$($1_$2_PROGRAM_WAY)_C_OBJS) $$($1_$2_$$($1_$2_PROGRAM_WAY)_S_OBJS) $$($1_$2_OTHER_OBJS),$$@) @@ -205,16 +260,9 @@ else ifeq "$$($1_$2_LINK_WITH_GCC)" "NO" $1/$2/build/tmp/$$($1_$2_PROG) : $$($1_$2_$$($1_$2_PROGRAM_WAY)_HS_OBJS) $$($1_$2_$$($1_$2_PROGRAM_WAY)_C_OBJS) $$($1_$2_$$($1_$2_PROGRAM_WAY)_S_OBJS) $$($1_$2_OTHER_OBJS) | $$$$(dir $$$$@)/. $$(call cmd,$1_$2_HC) -o $$@ $$($1_$2_$$($1_$2_PROGRAM_WAY)_ALL_HC_OPTS) $$(LD_OPTS) $$($1_$2_$$($1_$2_PROGRAM_WAY)_GHC_LD_OPTS) $$($1_$2_$$($1_$2_PROGRAM_WAY)_HS_OBJS) $$($1_$2_$$($1_$2_PROGRAM_WAY)_C_OBJS) $$($1_$2_$$($1_$2_PROGRAM_WAY)_S_OBJS) $$($1_$2_OTHER_OBJS) $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) -ifeq "$$(TargetOS_CPP)" "darwin" -ifneq "$3" "0" + ifeq "$$($1_$2_PROGRAM_WAY)" "dyn" -# Use relative paths for all the libraries - install_name_tool $$(foreach d,$$($1_$2_TRANSITIVE_DEP_NAMES), -change $$(TOP)/$$($$($$d_INSTALL_INFO)_dyn_LIB) @loader_path/../$$d-$$($$($$d_INSTALL_INFO)_VERSION)/$$($$($$d_INSTALL_INFO)_dyn_LIB_NAME)) $$@ -# Use relative paths for the RTS. Rather than try to work out which RTS -# way is being linked, we just change it for all ways - install_name_tool $$(foreach w,$$(rts_WAYS), -change $$(TOP)/$$(rts_$$w_LIB) @loader_path/../rts-$$(rts_VERSION)/$$(rts_$$w_LIB_NAME)) $$@ -endif -endif + $(call relative-dynlib-references,$1,$2,$3) endif else $1/$2/build/tmp/$$($1_$2_PROG) : $$($1_$2_$$($1_$2_PROGRAM_WAY)_HS_OBJS) $$($1_$2_$$($1_$2_PROGRAM_WAY)_C_OBJS) $$($1_$2_$$($1_$2_PROGRAM_WAY)_S_OBJS) $$($1_$2_OTHER_OBJS) | $$$$(dir $$$$@)/. @@ -232,18 +280,29 @@ ifneq "$$($1_$2_HS_SRCS)" "" ifeq "$$(strip $$(ALL_STAGE1_LIBS))" "" $$(error ordering failure in $1 ($2): ALL_STAGE1_LIBS is empty) endif -endif $1/$2/build/tmp/$$($1_$2_PROG) : $$(ALL_STAGE1_LIBS) $$(ALL_RTS_LIBS) $$(OTHER_LIBS) endif endif endif +endif ifneq "$$($1_$2_INSTALL_INPLACE)" "NO" $(call all-target,$1_$2,$$($1_$2_INPLACE)) endif $(call clean-target,$1,$2_inplace,$$($1_$2_INPLACE)) +# INPLACE_BIN might be empty if we're distcleaning +ifeq "$(findstring clean,$(MAKECMDGOALS))" "" +ifeq "$$($1_$2_INSTALL_INPLACE)" "YES" +$$($1_$2_INPLACE) : $1/$2/build/tmp/$$($1_$2_PROG_INPLACE) | $$$$(dir $$$$@)/. + "$$(CP)" -p $$< $$@ +endif +endif + ifeq "$$($1_$2_INSTALL)" "YES" +ifeq "$$($1_$2_PROG_NEEDS_C_WRAPPER)" "YES" +INSTALL_LIBS += $1/$2/build/tmp/$$($1_$2_PROG).dll +endif ifeq "$$($1_$2_WANT_INSTALLED_WRAPPER)" "YES" INSTALL_LIBEXECS += $1/$2/build/tmp/$$($1_$2_PROG) else ifeq "$$($1_$2_TOPDIR)" "YES" diff --git a/rules/c-sources.mk b/rules/c-sources.mk index 2f0eb9821d..309f9a0e88 100644 --- a/rules/c-sources.mk +++ b/rules/c-sources.mk @@ -11,6 +11,7 @@ # ----------------------------------------------------------------------------- define c-sources # args: $1 = dir, $2 = distdir -$1_$2_C_FILES = $$(patsubst %,$1/%,$$($1_$2_C_SRCS)) -$1_$2_S_FILES = $$(patsubst %,$1/%,$$($1_$2_S_SRCS)) +$1_$2_C_FILES = $$(patsubst %,$1/%,$$($1_$2_C_SRCS)) +$1_$2_S_FILES = $$(patsubst %,$1/%,$$($1_$2_S_SRCS)) +$1_$2_CMM_FILES = $$(patsubst %,$1/%,$$($1_$2_CMM_SRCS)) endef diff --git a/rules/c-suffix-rules.mk b/rules/c-suffix-rules.mk index 628546c077..9e71a7cfae 100644 --- a/rules/c-suffix-rules.mk +++ b/rules/c-suffix-rules.mk @@ -21,22 +21,22 @@ ifneq "$$(BINDIST)" "YES" ifeq "$4" "YES" -$1/$2/build/%.$$($3_osuf) : $1/%.c $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. +$1/$2/build/%.$$($3_osuf) : $1/%.c $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. $$(call cmd,$1_$2_HC) $$($1_$2_$3_GHC_CC_OPTS) -c $$< -o $$@ -$1/$2/build/%.$$($3_osuf) : $1/$2/build/%.c $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) +$1/$2/build/%.$$($3_osuf) : $1/$2/build/%.c $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) $$(call cmd,$1_$2_HC) $$($1_$2_$3_GHC_CC_OPTS) -c $$< -o $$@ -$1/$2/build/%.$$($3_osuf) : $1/$2/build/%.$$($3_way_)s $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) +$1/$2/build/%.$$($3_osuf) : $1/$2/build/%.$$($3_way_)s $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) $$(call cmd,$1_$2_HC) $$($1_$2_$3_GHC_CC_OPTS) -c $$< -o $$@ -$1/$2/build/%.$$($3_osuf) : $1/%.S $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. +$1/$2/build/%.$$($3_osuf) : $1/%.S $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. $$(call cmd,$1_$2_HC) $$($1_$2_$3_GHC_CC_OPTS) -c $$< -o $$@ -$1/$2/build/%.$$($3_way_)s : $1/$2/build/%.c $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) +$1/$2/build/%.$$($3_way_)s : $1/$2/build/%.c $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) $$(call cmd,$1_$2_HC) $$($1_$2_$3_GHC_CC_OPTS) -S $$< -o $$@ -$1/$2/build/%.$$($3_way_)s : $1/%.c $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) +$1/$2/build/%.$$($3_way_)s : $1/%.c $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) $$(call cmd,$1_$2_HC) $$($1_$2_$3_GHC_CC_OPTS) -S $$< -o $$@ else diff --git a/rules/cmm-suffix-rules.mk b/rules/cmm-suffix-rules.mk index 6546f86004..25efb4996a 100644 --- a/rules/cmm-suffix-rules.mk +++ b/rules/cmm-suffix-rules.mk @@ -20,16 +20,16 @@ define cmm-suffix-rules ifneq "$$(CLEANING)" "YES" -$1/$2/build/%.$$($3_way_)o : $1/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(includes_DERIVEDCONSTANTS) $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. +$1/$2/build/%.$$($3_way_)o : $1/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(includes_DERIVEDCONSTANTS) $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. $$(call cmd,$1_$2_HC) $$($1_$2_$3_MOST_HC_OPTS) -c $$< -o $$@ -$1/$2/build/%.$$($3_way_)o : $1/$2/build/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(includes_DERIVEDCONSTANTS) $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. +$1/$2/build/%.$$($3_way_)o : $1/$2/build/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(includes_DERIVEDCONSTANTS) $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. $$(call cmd,$1_$2_HC) $$($1_$2_$3_MOST_HC_OPTS) -c $$< -o $$@ -$1/$2/build/%.$$($3_way_)hc : $1/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(includes_DERIVEDCONSTANTS) $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. +$1/$2/build/%.$$($3_way_)hc : $1/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(includes_DERIVEDCONSTANTS) $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. $$(call cmd,$1_$2_HC) $$($1_$2_$3_MOST_HC_OPTS) -C $$< -o $$@ -$1/$2/build/%.$$($3_way_)hc : $1/$2/build/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(includes_DERIVEDCONSTANTS) $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. +$1/$2/build/%.$$($3_way_)hc : $1/$2/build/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(includes_DERIVEDCONSTANTS) $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. $$(call cmd,$1_$2_HC) $$($1_$2_$3_MOST_HC_OPTS) -C $$< -o $$@ # XXX @@ -40,10 +40,10 @@ $1/$2/build/%.$$($3_way_)hc : $1/$2/build/%.cmm $$(rts_H_FILES) $$(includes_H_FI # so for now they're commented out. They aren't needed, as we can always # go directly to .o files. # -# $1/$2/build/%.$$($3_way_)s : $1/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. +# $1/$2/build/%.$$($3_way_)s : $1/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. # $$(call cmd,$1_$2_HC) $$($1_$2_$3_MOST_HC_OPTS) -S $$< -o $$@ # -# $1/$2/build/%.$$($3_way_)s : $1/$2/build/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. +# $1/$2/build/%.$$($3_way_)s : $1/$2/build/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. # $$(call cmd,$1_$2_HC) $$($1_$2_$3_MOST_HC_OPTS) -S $$< -o $$@ endif diff --git a/rules/distdir-opts.mk b/rules/distdir-opts.mk index fd415b64db..b43eb1b2fa 100644 --- a/rules/distdir-opts.mk +++ b/rules/distdir-opts.mk @@ -15,6 +15,10 @@ define distdir-opts # args: $1 = dir, $2 = distdir, $3 = stage +ifeq "$3" "" +$$(error Stage not given for distdir-opts $1 $2) +endif + ifeq "$3" "0" # This is a bit of a hack. # If we are compiling something with the bootstrapping compiler on @@ -85,8 +89,6 @@ $1_$2_ALL_HSC2HS_OPTS = \ $$(SRC_HSC2HS_OPTS) \ $$(SRC_HSC2HS_OPTS_STAGE$3) \ --cflag=-D__GLASGOW_HASKELL__=$$(if $$(filter 0,$3),$$(GhcCanonVersion),$$(ProjectVersionInt)) \ - --cflag=-D$$(HostArch_CPP)_HOST_ARCH=1 \ - --cflag=-D$$(HostOS_CPP)_HOST_OS=1 \ $$($1_$2_HSC2HS_CC_OPTS) \ $$($1_$2_HSC2HS_LD_OPTS) \ --cflag=-I$1/$2/build/autogen \ diff --git a/rules/distdir-way-opts.mk b/rules/distdir-way-opts.mk index 872e52741e..ecd3aa1b71 100644 --- a/rules/distdir-way-opts.mk +++ b/rules/distdir-way-opts.mk @@ -124,11 +124,19 @@ $1_$2_$3_ALL_HC_OPTS = \ $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),$$(if $$(findstring v,$3),-dynamic-too)) ifeq "$3" "dyn" +ifeq "$$(HostOS_CPP)" "mingw32" +ifneq "$$($1_$2_dll0_MODULES)" "" +$1_$2_$3_ALL_HC_OPTS += -dll-split $1/$2/dll-split +endif +endif +endif + +ifeq "$3" "dyn" ifneq "$4" "0" -ifeq "$$(TargetOS_CPP)" "linux" +ifeq "$$(TargetElf)" "YES" $1_$2_$3_GHC_LD_OPTS += \ -fno-use-rpaths \ - $$(foreach d,$$($1_$2_TRANSITIVE_DEPS),-optl-Wl$$(comma)-rpath -optl-Wl$$(comma)'$$$$ORIGIN/../$$d') + $$(foreach d,$$($1_$2_TRANSITIVE_DEPS),-optl-Wl$$(comma)-rpath -optl-Wl$$(comma)'$$$$ORIGIN/../$$d') -optl-Wl,-z -optl-Wl,origin else ifeq "$$(TargetOS_CPP)" "darwin" $1_$2_$3_GHC_LD_OPTS += -optl-Wl,-headerpad_max_install_names endif @@ -140,6 +148,7 @@ $1_$2_$3_ALL_CC_OPTS = \ $$($1_$2_DIST_GCC_CC_OPTS) \ $$($1_$2_$3_CC_OPTS) \ $$($$(basename $$<)_CC_OPTS) \ + $$($1_$2_EXTRA_CC_OPTS) \ $$(EXTRA_CC_OPTS) $1_$2_$3_GHC_CC_OPTS = \ @@ -148,6 +157,7 @@ $1_$2_$3_GHC_CC_OPTS = \ $$($1_$2_DIST_CC_OPTS) \ $$($1_$2_$3_CC_OPTS) \ $$($$(basename $$<)_CC_OPTS) \ + $$($1_$2_EXTRA_CC_OPTS) \ $$(EXTRA_CC_OPTS)) \ $$($1_$2_$3_MOST_HC_OPTS) diff --git a/rules/haddock.mk b/rules/haddock.mk index 7efb29aa7d..78f4ea6e18 100644 --- a/rules/haddock.mk +++ b/rules/haddock.mk @@ -43,9 +43,9 @@ ifneq "$$(BINDIST)" "YES" # We need the quadruple dollars for the dependencies, as it isn't # guaranteed that we are processing the packages in dependency order, # so we don't want to expand it yet. -$$($$($1_PACKAGE)-$$($1_$2_VERSION)_HADDOCK_FILE) : $$(INPLACE_BIN)/haddock$$(exeext) $$$$(ghc-cabal_INPLACE) $$($1_$2_HS_SRCS) $$$$($$($1_PACKAGE)-$$($1_$2_VERSION)_HADDOCK_DEPS) | $$$$(dir $$$$@)/. +$$($$($1_PACKAGE)-$$($1_$2_VERSION)_HADDOCK_FILE) : $$$$(haddock_INPLACE) $$$$(ghc-cabal_INPLACE) $$($1_$2_HS_SRCS) $$$$($$($1_PACKAGE)-$$($1_$2_VERSION)_HADDOCK_DEPS) | $$$$(dir $$$$@)/. ifeq "$$(HSCOLOUR_SRCS)" "YES" - "$$(ghc-cabal_INPLACE)" hscolour $2 $1 + "$$(ghc-cabal_INPLACE)" hscolour $1 $2 endif "$$(TOP)/$$(INPLACE_BIN)/haddock" \ --odir="$1/$2/doc/html/$$($1_PACKAGE)" \ diff --git a/rules/hs-suffix-way-rules-srcdir.mk b/rules/hs-suffix-way-rules-srcdir.mk index eff49543f3..661f8957e2 100644 --- a/rules/hs-suffix-way-rules-srcdir.mk +++ b/rules/hs-suffix-way-rules-srcdir.mk @@ -18,18 +18,18 @@ ifneq "$$(BINDIST)" "YES" # Compiling Haskell source -$1/$2/build/%.$$($3_osuf) : $1/$4/%.hs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) +$1/$2/build/%.$$($3_osuf) : $1/$4/%.hs $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),-dyno $$(addsuffix .$$(dyn_osuf),$$(basename $$@))) $$(call ohi-sanity-check,$1,$2,$3,$1/$2/build/$$*) -$1/$2/build/%.$$($3_osuf) : $1/$4/%.lhs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) +$1/$2/build/%.$$($3_osuf) : $1/$4/%.lhs $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),-dyno $$(addsuffix .$$(dyn_osuf),$$(basename $$@))) $$(call ohi-sanity-check,$1,$2,$3,$1/$2/build/$$*) -$1/$2/build/%.$$($3_hcsuf) : $1/$4/%.hs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) +$1/$2/build/%.$$($3_hcsuf) : $1/$4/%.hs $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -C $$< -o $$@ -$1/$2/build/%.$$($3_hcsuf) : $1/$4/%.lhs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) +$1/$2/build/%.$$($3_hcsuf) : $1/$4/%.lhs $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -C $$< -o $$@ # XXX: for some reason these get used in preference to the direct @@ -52,10 +52,10 @@ $1/$2/build/%.$$($3_osuf) : $1/$2/build/%.hc includes/ghcautoconf.h includes/ghc # Now the rules for hs-boot files. -$1/$2/build/%.$$($3_way_)o-boot : $1/$4/%.hs-boot $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) +$1/$2/build/%.$$($3_way_)o-boot : $1/$4/%.hs-boot $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),-dyno $$(addsuffix .$$(dyn_osuf)-boot,$$(basename $$@))) -$1/$2/build/%.$$($3_way_)o-boot : $1/$4/%.lhs-boot $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) +$1/$2/build/%.$$($3_way_)o-boot : $1/$4/%.lhs-boot $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) $$($1_$2_PKGDATA_DEP) $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),-dyno $$(addsuffix .$$(dyn_osuf)-boot,$$(basename $$@))) # stubs are automatically generated and compiled by GHC diff --git a/rules/hs-suffix-way-rules.mk b/rules/hs-suffix-way-rules.mk index e53821554a..fd8dbe21a5 100644 --- a/rules/hs-suffix-way-rules.mk +++ b/rules/hs-suffix-way-rules.mk @@ -31,16 +31,16 @@ else ifneq "$$(BINDIST)" "YES" -$1/$2/build/%.$$($3_hcsuf) : $1/$2/build/%.hs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) +$1/$2/build/%.$$($3_hcsuf) : $1/$2/build/%.hs $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -C $$< -o $$@ -$1/$2/build/%.$$($3_osuf) : $1/$2/build/%.hs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) +$1/$2/build/%.$$($3_osuf) : $1/$2/build/%.hs $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),-dyno $$(addsuffix .$$(dyn_osuf),$$(basename $$@))) -$1/$2/build/%.$$($3_hcsuf) : $1/$2/build/autogen/%.hs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) +$1/$2/build/%.$$($3_hcsuf) : $1/$2/build/autogen/%.hs $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -C $$< -o $$@ -$1/$2/build/%.$$($3_osuf) : $1/$2/build/autogen/%.hs $$(LAX_DEPS_FOLLOW) $$($1_$2_HC_DEP) +$1/$2/build/%.$$($3_osuf) : $1/$2/build/autogen/%.hs $$(LAX_DEPS_FOLLOW) $$$$($1_$2_HC_DEP) $$(call cmd,$1_$2_HC) $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ $$(if $$(findstring YES,$$($1_$2_DYNAMIC_TOO)),-dyno $$(addsuffix .$$(dyn_osuf),$$(basename $$@))) endif diff --git a/rules/manual-package-config.mk b/rules/manual-package-config.mk index da6b3b61d9..08a1076fc4 100644 --- a/rules/manual-package-config.mk +++ b/rules/manual-package-config.mk @@ -15,7 +15,7 @@ define manual-package-config # args: $1 = dir $(call trace, manual-package-config($1)) $(call profStart, manual-package-config($1)) -$1/package.conf.inplace : $1/package.conf.in $$$$(ghc-pkg_INPLACE) +$1/dist/package.conf.inplace : $1/package.conf.in $$$$(ghc-pkg_INPLACE) | $$$$(dir $$$$@)/. $$(CPP) $$(RAWCPP_FLAGS) -P \ -DTOP='"$$(TOP)"' \ $$($1_PACKAGE_CPP_OPTS) \ @@ -27,8 +27,8 @@ $1/package.conf.inplace : $1/package.conf.in $$$$(ghc-pkg_INPLACE) # This is actually a real file, but we need to recreate it on every # "make install", so we declare it as phony -.PHONY: $1/package.conf.install -$1/package.conf.install: +.PHONY: $1/dist/package.conf.install +$1/dist/package.conf.install: | $$$$(dir $$$$@)/. $$(CPP) $$(RAWCPP_FLAGS) -P \ -DINSTALLING \ -DLIB_DIR='"$$(if $$(filter YES,$$(RelocatableBuild)),$$$$topdir,$$(ghclibdir))"' \ @@ -38,10 +38,5 @@ $1/package.conf.install: grep -v '^#pragma GCC' $$@.raw | \ sed -e 's/""//g' -e 's/:[ ]*,/: /g' >$$@ -distclean : clean_$1_package.conf -.PHONY: clean_$1_package.conf -clean_$1_package.conf : - $$(call removeFiles,$1/package.conf.install $1/package.conf.inplace) - $(call profEnd, manual-package-config($1)) endef diff --git a/rules/relative-dynlib-references.mk b/rules/relative-dynlib-references.mk new file mode 100644 index 0000000000..03dabc1453 --- /dev/null +++ b/rules/relative-dynlib-references.mk @@ -0,0 +1,35 @@ +# ----------------------------------------------------------------------------- +# +# (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 +# +# ----------------------------------------------------------------------------- + + +# Make dynlib references use relative paths, so that everything works +# without the build tree. + +define relative-dynlib-references +# $1 = dir +# $2 = distdir +# $3 = GHC stage to use (0 == bootstrapping compiler) + +ifeq "$$(TargetOS_CPP)" "darwin" +ifneq "$3" "0" +# Use relative paths for all the libraries +ifneq "$$($1_$2_TRANSITIVE_DEP_NAMES)" "" + install_name_tool $$(foreach d,$$($1_$2_TRANSITIVE_DEP_NAMES), -change $$(TOP)/$$($$($$d_INSTALL_INFO)_dyn_LIB) @loader_path/../$$d-$$($$($$d_INSTALL_INFO)_VERSION)/$$($$($$d_INSTALL_INFO)_dyn_LIB_NAME)) $$@ +endif +# Use relative paths for the RTS. Rather than try to work out which RTS +# way is being linked, we just change it for all ways + install_name_tool $$(foreach w,$$(rts_WAYS), -change $$(TOP)/$$(rts_$$w_LIB) @loader_path/../rts-$$(rts_VERSION)/$$(rts_$$w_LIB_NAME)) $$@ + install_name_tool -change $$(TOP)/$$(wildcard libffi/build/inst/lib/libffi.*.dylib) @loader_path/../rts-$$(rts_VERSION)/libffi.dylib $$@ +endif +endif + +endef diff --git a/rules/shell-wrapper.mk b/rules/shell-wrapper.mk index 4f6795d159..b23e385035 100644 --- a/rules/shell-wrapper.mk +++ b/rules/shell-wrapper.mk @@ -89,6 +89,7 @@ install_$1_$2_wrapper: endif ifeq "$$($1_$2_WANT_BINDIST_WRAPPER)" "YES" +ifneq "$$(TargetOS_CPP)" "mingw32" $1_$2_BINDIST_WRAPPER = $1/$2/build/tmp/$$($1_$2_PROGNAME)-bindist @@ -106,6 +107,7 @@ endif $$(EXECUTABLE_FILE) $$@ endif +endif $(call profEnd, shell-wrapper($1,$2)) endef @@ -2,6 +2,7 @@ use strict; use Cwd; +use English; $| = 1; # autoflush stdout after each print, to avoid output after die @@ -18,76 +19,20 @@ my $bare_flag = ""; # NOT the opposite of checked_out_flag (describes local repo my %tags; -# Figure out where to get the other repositories from. -sub getrepo { - my $repo; +sub inDir { + my $dir = shift; + my $code = shift; - if (defined($defaultrepo)) { - $repo = $defaultrepo; - chomp $repo; - } else { - # Figure out where to get the other repositories from, - # based on where this GHC repo came from. - my $git_dir = $bare_flag ? "--git-dir=ghc.git" : ""; - my $branch = `git $git_dir branch | grep "\* " | sed "s/^\* //"`; chomp $branch; - my $remote = `git $git_dir config branch.$branch.remote`; chomp $remote; - if ($remote eq "") { - # remotes are not mandatory for branches (e.g. not recorded by default for bare repos) - $remote = "origin"; - } - $repo = `git $git_dir config remote.$remote.url`; chomp $repo; + if ($dir ne '.') { + chdir($dir); } - my $repo_base; - my $checked_out_tree; - - if ($repo =~ /^...*:/) { - # HTTP or SSH - # Above regex says "at least two chars before the :", to avoid - # catching Win32 drives ("C:\"). - $repo_base = $repo; - - # --checked-out is needed if you want to use a checked-out repo - # over SSH or HTTP - if ($checked_out_flag) { - $checked_out_tree = 1; - } else { - $checked_out_tree = 0; - } + my $result = &$code(); - # Don't drop the last part of the path if specified with -r, as - # it expects repos of the form: - # - # http://darcs.haskell.org - # - # rather than - # - # http://darcs.haskell.org/ghc - # - if (!$defaultrepo) { - $repo_base =~ s#/[^/]+/?$##; - } - } - elsif ($repo =~ /^\/|\.\.\/|.:(\/|\\)/) { - # Local filesystem, either absolute (C:/ or /) or relative (../) path - $repo_base = $repo; - if (-f "$repo/HEAD") { - # assume a local mirror: - $checked_out_tree = 0; - $repo_base =~ s#/[^/]+/?$##; - } elsif (-d "$repo/ghc.git") { - # assume a local mirror: - $checked_out_tree = 0; - } else { - # assume a checked-out tree: - $checked_out_tree = 1; - } - } - else { - die "Couldn't work out repo"; + if ($dir ne '.') { + chdir($initial_working_directory); } - - return $repo_base, $checked_out_tree; + return $result; } sub parsePackages { @@ -111,6 +56,8 @@ sub parsePackages { $line{"tag"} = $2; $line{"remotepath"} = $3; push @packages, \%line; + + $tags{$2} = 0; } elsif (! /^(#.*)?$/) { die "Bad content on line $lineNum of packages file: $_"; @@ -161,42 +108,121 @@ sub gitNewWorkdir { } } +sub git { + my $dir = shift; + my @args = @_; + + &inDir($dir, sub { + my $prefix = $dir eq '.' ? "" : "$dir: "; + message "== ${prefix}running git @args"; + + system ("git", @args) == 0 + or $ignore_failure + or die "git failed: $?"; + }); +} + +sub readgit { + my $dir = shift; + my @args = @_; + + &inDir($dir, sub { + open my $fh, '-|', 'git', @args + or die "Executing git @args failed: $!"; + my $line = <$fh>; + $line = "" unless defined($line); + chomp $line; + close $fh; + return $line; + }); +} + sub configure_repository { my $localpath = shift; &git($localpath, "config", "--local", "core.ignorecase", "true"); - chdir($localpath); - open my $git_autocrlf, '-|', 'git', 'config', '--get', 'core.autocrlf' - or die "Executing git config failed: $!"; - my $autocrlf = <$git_autocrlf>; - $autocrlf = "" unless defined($autocrlf); - chomp $autocrlf; - close($git_autocrlf); - chdir($initial_working_directory); + my $autocrlf = &readgit($localpath, 'config', '--get', 'core.autocrlf'); if ($autocrlf eq "true") { &git($localpath, "config", "--local", "core.autocrlf", "false"); &git($localpath, "reset", "--hard"); } } -sub git { - my $dir = shift; +# Figure out where to get the other repositories from. +sub getrepo { + my $repo; - if ($dir eq '.') { - message "== running git @_"; + if (defined($defaultrepo)) { + $repo = $defaultrepo; + chomp $repo; } else { - message "== $dir: running git @_"; - chdir($dir); + # Figure out where to get the other repositories from, + # based on where this GHC repo came from. + my $git_dir = $bare_flag ? "ghc.git" : "."; + my $branch = &readgit($git_dir, "rev-parse", "--abbrev-ref", "HEAD"); + die "Bad branch: $branch" + unless $branch =~ /^[a-zA-Z][a-zA-Z0-9.-]*$/; + my $remote = &readgit($git_dir, "config", "branch.$branch.remote"); + if ($remote eq "") { + # remotes are not mandatory for branches (e.g. not recorded by default for bare repos) + $remote = "origin"; + } + die "Bad remote: $remote" + unless $remote =~ /^[a-zA-Z][a-zA-Z0-9.-]*$/; + $repo = &readgit($git_dir, "config", "remote.$remote.url"); } - system ("git", @_) == 0 - or $ignore_failure - or die "git failed: $?"; + my $repo_base; + my $checked_out_tree; - if ($dir ne '.') { - chdir($initial_working_directory); + if ($repo =~ /^...*:/) { + # HTTP or SSH + # Above regex says "at least two chars before the :", to avoid + # catching Win32 drives ("C:\"). + $repo_base = $repo; + + # --checked-out is needed if you want to use a checked-out repo + # over SSH or HTTP + if ($checked_out_flag) { + $checked_out_tree = 1; + } else { + $checked_out_tree = 0; + } + + # Don't drop the last part of the path if specified with -r, as + # it expects repos of the form: + # + # http://git.haskell.org + # + # rather than + # + # http://git.haskell.org/ghc + # + if (!$defaultrepo) { + $repo_base =~ s#/[^/]+/?$##; + } } + elsif ($repo =~ /^\/|\.\.\/|.:(\/|\\)/) { + # Local filesystem, either absolute (C:/ or /) or relative (../) path + $repo_base = $repo; + if (-f "$repo/HEAD") { + # assume a local mirror: + $checked_out_tree = 0; + $repo_base =~ s#/[^/]+/?$##; + } elsif (-d "$repo/ghc.git") { + # assume a local mirror: + $checked_out_tree = 0; + } else { + # assume a checked-out tree: + $checked_out_tree = 1; + } + } + else { + die "Couldn't work out repo"; + } + + return $repo_base, $checked_out_tree; } sub gitall { @@ -221,8 +247,6 @@ sub gitall { my $is_github_repo = $repo_base =~ m/(git@|git:\/\/|https:\/\/)github.com/; - parsePackages; - @args = (); if ($command =~ /^remote$/) { @@ -292,6 +316,10 @@ sub gitall { } } + # Some extra packages like 'async' may be external URLs, + # e.g. git://... or http://... + my $is_external_url = $remotepath =~ m/^(git:\/\/|https:\/\/|http:\/\/)/; + open RESUME, "> resume.tmp"; print RESUME "$localpath\n"; print RESUME "$doing\n"; @@ -300,12 +328,12 @@ sub gitall { # We can't create directories on GitHub, so we translate # "packages/foo" into "package-foo". - if ($is_github_repo) { + if ($is_github_repo && !defined($is_external_url)) { $remotepath =~ s/\//-/; } # Construct the path for this package in the repo we pulled from - $path = "$repo_base/$remotepath"; + $path = $is_external_url ? $remotepath : "$repo_base/$remotepath"; if ($command eq "get") { next if $remotepath eq "-"; # "git submodule init/update" will get this later @@ -375,13 +403,7 @@ sub gitall { } close($lsremote); - open my $revparse, '-|', 'git', 'rev-parse', '--verify', 'HEAD' - or die "Executing rev-parse failed: $!"; - my $myhead; - $myhead = <$revparse>; - # or die "Failed to read from rev-parse: $!"; - chomp $myhead; - close($revparse); + my $myhead = &readgit('.', 'rev-parse', '--verify', 'HEAD'); if (not defined($remote_heads{$myhead})) { die "Sub module $localpath needs to be pushed; see http://hackage.haskell.org/trac/ghc/wiki/Repositories/Upstream"; @@ -437,7 +459,16 @@ sub gitall { my $rpath; $ignore_failure = 1; if ($remotepath eq '-') { - $rpath = "$repo_base/$localpath"; + $rpath = "$localpath.git"; # N.B.: $localpath lacks the .git suffix + if ($localpath =~ /^libraries\//) { + # FIXME: This is just a simple heuristic to + # infer the remotepath for Git submodules. A + # proper solution would require to parse the + # .gitmodules file to obtain the actual + # localpath<->remotepath mapping. + $rpath =~ s/^libraries\//packages\//; + } + $rpath = "$repo_base/$rpath"; } else { $rpath = $path; } @@ -489,6 +520,42 @@ sub gitall { elsif ($command eq "tag") { &git($localpath, "tag", @args); } + elsif ($command eq "compare") { + # Don't compare the subrepos; it doesn't work properly as + # they aren't on a branch. + next if $remotepath eq "-"; + + my $compareto; + if ($#args eq -1) { + $compareto = $path; + } + elsif ($#args eq 0) { + $compareto = "$args[0]/$localpath"; + } + elsif ($#args eq 1 && $args[0] eq "-b") { + $compareto = "$args[1]/$remotepath"; + } + else { + die "Bad args for compare"; + } + print "$localpath"; + print (' ' x (40 - length($localpath))); + my $branch = &readgit($localpath, "rev-parse", "--abbrev-ref", "HEAD"); + die "Bad branch: $branch" + unless $branch =~ /^[a-zA-Z][a-zA-Z0-9.-]*$/; + my $us = &readgit(".", "ls-remote", $localpath, "refs/heads/$branch"); + my $them = &readgit(".", "ls-remote", $compareto, "refs/heads/$branch"); + $us =~ s/[[:space:]].*//; + $them =~ s/[[:space:]].*//; + die "Bad commit of mine: $us" unless (length($us) eq 40); + die "Bad commit of theirs: $them" unless (length($them) eq 40); + if ($us eq $them) { + print "same\n"; + } + else { + print "DIFFERENT\n"; + } + } else { die "Unknown command: $command"; } @@ -497,24 +564,40 @@ sub gitall { unlink "resume"; } +sub checkCurrentBranchIsMaster { + my $branch = `git symbolic-ref HEAD`; + $branch =~ s/refs\/heads\///; + $branch =~ s/\n//; + + if ($branch !~ /master/) { + print "\nWarning: You trying to 'pull' while on branch '$branch'.\n" + . "Updates to this script will happen on the master branch which\n" + . "means the version on this branch may be out of date.\n\n"; + } +} + sub help { my $exit = shift; + my $tags = join ' ', sort (grep !/^-$/, keys %tags); + # Get the built in help my $help = <<END; Usage: ./sync-all [-q] [-s] [--ignore-failure] [-r repo] [--checked-out] [--bare] - [--nofib] [--extra] [--testsuite] [--no-dph] [--resume] + [--<tag>] [--no-<tag>] [--resume] cmd [git flags] + where <tag> is one of: $tags + Applies the command "cmd" to each repository in the tree. A full repository tree is obtained by first cloning the ghc repository, then getting the subrepositories with "sync-all get": - \$ git clone http://darcs.haskell.org/ghc.git + \$ git clone http://git.haskell.org/ghc.git \$ cd ghc \$ ./sync-all get @@ -554,13 +637,24 @@ remote set-url [--push] <remote-name> repository location in each case appropriately. For example, to add a new remote pointing to the upstream repositories: - ./sync-all -r http://darcs.haskell.org/ remote add upstream + ./sync-all -r http://git.haskell.org remote add upstream The -r flag points to the root of the repository tree (see "which repos to use" below). For a repository on the local filesystem it would point to the ghc repository, and for a remote repository it points to the directory containing "ghc.git". +compare +compare reporoot +compare -b reporoot + + Compare the git HEADs of the repos to the origin repos, or the + repos under reporoot (which is assumde to be a checked-out tree + unless the -b flag is used). + + 1 line is printed for each repo, indicating whether the repo is + at the "same" or a "DIFFERENT" commit. + These commands just run the equivalent git command on each repository, passing any extra arguments to git: @@ -621,7 +715,7 @@ Flags given *after* the command are passed to git. --extra also clone some extra library packages - --no-dph avoids cloning the dph pacakges + --no-dph avoids cloning the dph packages ------------ Checking out a branch ------------- @@ -651,7 +745,7 @@ otherwise sync-all works on repos of form: <repo_base>/<remote-path> This logic lets you say - both sync-all -r http://darcs.haskell.org/ghc-6.12 remote add ghc-6.12 + both sync-all -r http://example.org/ghc-6.12 remote add ghc-6.12 and sync-all -r ../working remote add working The latter is called a "checked-out tree". @@ -688,8 +782,13 @@ END sub main { + &parsePackages(); + $tags{"-"} = 1; $tags{"dph"} = 1; + if ($OSNAME =~ /^(MSWin32|Cygwin)$/) { + $tags{"windows"} = 1; + } while ($#_ ne -1) { my $arg = shift; @@ -728,12 +827,15 @@ sub main { } # --<tag> says we grab the libs tagged 'tag' with # 'get'. It has no effect on the other commands. - elsif ($arg =~ m/^--no-(.*)$/) { + elsif ($arg =~ m/^--no-(.*)$/ && defined($tags{$1})) { $tags{$1} = 0; } - elsif ($arg =~ m/^--(.*)$/) { + elsif ($arg =~ m/^--(.*)$/ && defined($tags{$1})) { $tags{$1} = 1; } + elsif ($arg =~ m/^-/) { + die "Unrecognised flag: $arg"; + } else { unshift @_, $arg; if (grep /^-q$/, @_) { @@ -750,7 +852,7 @@ sub main { if ($bare_flag && ! $bare_found && ! $defaultrepo) { die "error: bare repository ghc.git not found.\n" . " Either clone a bare ghc repo first or specify the repo location. E.g.:\n" - . " ./sync-all --bare [--testsuite --nofib --extra] -r http://darcs.haskell.org/ get\n" + . " ./sync-all --bare [--testsuite --nofib --extra] -r http://git.haskell.org get\n" } elsif ($bare_found) { $bare_flag = "--bare"; @@ -812,6 +914,10 @@ sub main { } BEGIN { + my %argvHash = map { $_, 1 } @ARGV; + if ($argvHash {"pull"}) { + checkCurrentBranchIsMaster(); + } $initial_working_directory = getcwd(); } diff --git a/utils/deriveConstants/DeriveConstants.hs b/utils/deriveConstants/DeriveConstants.hs index 78233a5b98..48990061cc 100644 --- a/utils/deriveConstants/DeriveConstants.hs +++ b/utils/deriveConstants/DeriveConstants.hs @@ -346,6 +346,7 @@ wanteds = concat ,structSize C "generation" ,structField C "generation" "n_new_large_words" + ,structField C "generation" "weak_ptr_list" ,structSize Both "CostCentreStack" ,structField C "CostCentreStack" "ccsID" @@ -469,10 +470,14 @@ wanteds = concat ,closureField C "StgWeak" "key" ,closureField C "StgWeak" "value" ,closureField C "StgWeak" "finalizer" - ,closureField C "StgWeak" "cfinalizer" + ,closureField C "StgWeak" "cfinalizers" - ,closureSize C "StgDeadWeak" - ,closureField C "StgDeadWeak" "link" + ,closureSize C "StgCFinalizerList" + ,closureField C "StgCFinalizerList" "link" + ,closureField C "StgCFinalizerList" "fptr" + ,closureField C "StgCFinalizerList" "ptr" + ,closureField C "StgCFinalizerList" "eptr" + ,closureField C "StgCFinalizerList" "flag" ,closureSize C "StgMVar" ,closureField C "StgMVar" "head" @@ -571,11 +576,11 @@ wanteds = concat ,constantWord Haskell "MAX_Float_REG" "MAX_FLOAT_REG" ,constantWord Haskell "MAX_Double_REG" "MAX_DOUBLE_REG" ,constantWord Haskell "MAX_Long_REG" "MAX_LONG_REG" - ,constantWord Haskell "MAX_SSE_REG" "MAX_SSE_REG" + ,constantWord Haskell "MAX_XMM_REG" "MAX_XMM_REG" ,constantWord Haskell "MAX_Real_Vanilla_REG" "MAX_REAL_VANILLA_REG" ,constantWord Haskell "MAX_Real_Float_REG" "MAX_REAL_FLOAT_REG" ,constantWord Haskell "MAX_Real_Double_REG" "MAX_REAL_DOUBLE_REG" - ,constantWord Haskell "MAX_Real_SSE_REG" "MAX_REAL_SSE_REG" + ,constantWord Haskell "MAX_Real_XMM_REG" "MAX_REAL_XMM_REG" ,constantWord Haskell "MAX_Real_Long_REG" "MAX_REAL_LONG_REG" -- This tells the native code generator the size of the spill diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index 4230cd8696..8729d4c73c 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -138,8 +138,6 @@ gen_hs_source (Info defaults entries) = ++ unlines (map (("\t" ++) . hdr) entries) ++ ") where\n" ++ "\n" - ++ "import GHC.Types\n" - ++ "\n" ++ "{-\n" ++ unlines (map opt defaults) ++ "-}\n" @@ -507,7 +505,6 @@ gen_wrappers (Info _ entries) -- don't need the Prelude here so we add NoImplicitPrelude. ++ "module GHC.PrimopWrappers where\n" ++ "import qualified GHC.Prim\n" - ++ "import GHC.Types (Bool)\n" ++ "import GHC.Tuple ()\n" ++ "import GHC.Prim (" ++ concat (intersperse ", " othertycons) ++ ")\n" ++ "#if defined (__GLASGOW_HASKELL_LLVM__)\n" diff --git a/utils/genprimopcode/Syntax.hs b/utils/genprimopcode/Syntax.hs index b2e983d48c..9d13f91e96 100644 --- a/utils/genprimopcode/Syntax.hs +++ b/utils/genprimopcode/Syntax.hs @@ -114,7 +114,7 @@ sanityPrimOp def_names p sane_ty :: Category -> Ty -> Bool sane_ty Compare (TyF t1 (TyF t2 td)) - | t1 == t2 && td == TyApp "Bool" [] = True + | t1 == t2 && td == TyApp "Int#" [] = True sane_ty Monadic (TyF t1 td) | t1 == td = True sane_ty Dyadic (TyF t1 (TyF t2 td)) diff --git a/utils/ghc-cabal/Main.hs b/utils/ghc-cabal/Main.hs index 991b2b80b6..9a76d6b93d 100644 --- a/utils/ghc-cabal/Main.hs +++ b/utils/ghc-cabal/Main.hs @@ -34,26 +34,24 @@ main :: IO () main = do hSetBuffering stdout LineBuffering args <- getArgs case args of - "hscolour" : distDir : dir : args' -> - runHsColour distDir dir args' + "hscolour" : dir : distDir : args' -> + runHsColour dir distDir args' "check" : dir : [] -> doCheck dir - "copy" : strip : directory : distDir - : myDestDir : myPrefix : myLibdir : myDocdir + "copy" : dir : distDir + : strip : myDestDir : myPrefix : myLibdir : myDocdir : args' -> - doCopy strip directory distDir - myDestDir myPrefix myLibdir myDocdir + doCopy dir distDir + strip myDestDir myPrefix myLibdir myDocdir args' - "register" : ghc : ghcpkg : topdir : directory : distDir + "register" : dir : distDir : ghc : ghcpkg : topdir : myDestDir : myPrefix : myLibdir : myDocdir : relocatableBuild : args' -> - doRegister ghc ghcpkg topdir directory distDir + doRegister dir distDir ghc ghcpkg topdir myDestDir myPrefix myLibdir myDocdir relocatableBuild args' - "configure" : args' -> case break (== "--") args' of - (config_args, "--" : distdir : directories) -> - mapM_ (generate config_args distdir) directories - _ -> die syntax_error + "configure" : dir : distDir : dll0Modules : config_args -> + generate dir distDir dll0Modules config_args "sdist" : dir : distDir : [] -> doSdist dir distDir ["--version"] -> @@ -124,7 +122,7 @@ doCheck directory isFailure _ = True runHsColour :: FilePath -> FilePath -> [String] -> IO () -runHsColour distdir directory args +runHsColour directory distdir args = withCurrentDirectory directory $ defaultMainArgs ("hscolour" : "--builddir" : distdir : args) @@ -132,9 +130,9 @@ doCopy :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> [String] -> IO () -doCopy strip directory distDir - myDestDir myPrefix myLibdir myDocdir - args +doCopy directory distDir + strip myDestDir myPrefix myLibdir myDocdir + args = withCurrentDirectory directory $ do let copyArgs = ["copy", "--builddir", distDir] ++ (if null myDestDir @@ -182,7 +180,7 @@ doRegister :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> String -> [String] -> IO () -doRegister ghc ghcpkg topdir directory distDir +doRegister directory distDir ghc ghcpkg topdir myDestDir myPrefix myLibdir myDocdir relocatableBuildStr args = withCurrentDirectory directory $ do @@ -300,8 +298,8 @@ mangleLbi "compiler" "stage2" lbi _ -> False mangleLbi _ _ lbi = lbi -generate :: [String] -> FilePath -> FilePath -> IO () -generate config_args distdir directory +generate :: FilePath -> FilePath -> String -> [String] -> IO () +generate directory distdir dll0Modules config_args = withCurrentDirectory directory $ do let verbosity = normal -- XXX We shouldn't just configure with the default flags @@ -405,9 +403,12 @@ generate config_args distdir directory wrappedLibraryDirs <- wrap libraryDirs let variablePrefix = directory ++ '_':distdir + mods = map display modules + otherMods = map display (otherModules bi) + allMods = mods ++ otherMods let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)), - variablePrefix ++ "_MODULES = " ++ unwords (map display modules), - variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords (map display (otherModules bi)), + variablePrefix ++ "_MODULES = " ++ unwords mods, + variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords otherMods, variablePrefix ++ "_SYNOPSIS =" ++ synopsis pd, variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi), variablePrefix ++ "_DEPS = " ++ unwords deps, @@ -437,6 +438,7 @@ generate config_args distdir directory variablePrefix ++ "_DEP_CC_OPTS = " ++ unwords (forDeps Installed.ccOptions), variablePrefix ++ "_DEP_LIB_DIRS_SINGLE_QUOTED = " ++ unwords wrappedLibraryDirs, variablePrefix ++ "_DEP_LIB_DIRS_SEARCHPATH = " ++ mkSearchPath libraryDirs, + variablePrefix ++ "_DEP_LIB_REL_DIRS = " ++ unwords libraryRelDirs, variablePrefix ++ "_DEP_LIB_REL_DIRS_SEARCHPATH = " ++ mkSearchPath libraryRelDirs, variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries), variablePrefix ++ "_DEP_LD_OPTS = " ++ unwords (forDeps Installed.ldOptions), @@ -450,6 +452,11 @@ generate config_args distdir directory writeFile (distdir ++ "/haddock-prologue.txt") $ if null (description pd) then synopsis pd else description pd + unless (null dll0Modules) $ + do let dll0Mods = words dll0Modules + dllMods = allMods \\ dll0Mods + dllModSets = map unwords [dll0Mods, dllMods] + writeFile (distdir ++ "/dll-split") $ unlines dllModSets where escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) [] wrap = mapM wrap1 diff --git a/utils/ghc-cabal/ghc.mk b/utils/ghc-cabal/ghc.mk index bb0a35ecd6..bafc47b261 100644 --- a/utils/ghc-cabal/ghc.mk +++ b/utils/ghc-cabal/ghc.mk @@ -18,17 +18,19 @@ CABAL_DOTTED_VERSION := $(shell grep "^version:" libraries/Cabal/Cabal/Cabal.cab CABAL_VERSION := $(subst .,$(comma),$(CABAL_DOTTED_VERSION)) CABAL_CONSTRAINT := --constraint="Cabal == $(CABAL_DOTTED_VERSION)" -ghc-cabal_INPLACE = inplace/bin/ghc-cabal$(exeext) +ghc-cabal_DIST_BINARY_NAME = ghc-cabal$(exeext0) +ghc-cabal_DIST_BINARY = utils/ghc-cabal/dist/build/tmp/$(ghc-cabal_DIST_BINARY_NAME) +ghc-cabal_INPLACE = inplace/bin/$(ghc-cabal_DIST_BINARY_NAME) ifneq "$(BINDIST)" "YES" -$(ghc-cabal_INPLACE) : utils/ghc-cabal/dist/build/tmp/ghc-cabal$(exeext) | $$(dir $$@)/. +$(ghc-cabal_INPLACE) : $(ghc-cabal_DIST_BINARY) | $$(dir $$@)/. "$(CP)" $< $@ -utils/ghc-cabal/dist/build/tmp/ghc-cabal$(exeext): $(wildcard libraries/Cabal/Cabal/Distribution/*/*/*.hs) -utils/ghc-cabal/dist/build/tmp/ghc-cabal$(exeext): $(wildcard libraries/Cabal/Cabal/Distribution/*/*.hs) -utils/ghc-cabal/dist/build/tmp/ghc-cabal$(exeext): $(wildcard libraries/Cabal/Cabal/Distribution/*.hs) +$(ghc-cabal_DIST_BINARY): $(wildcard libraries/Cabal/Cabal/Distribution/*/*/*.hs) +$(ghc-cabal_DIST_BINARY): $(wildcard libraries/Cabal/Cabal/Distribution/*/*.hs) +$(ghc-cabal_DIST_BINARY): $(wildcard libraries/Cabal/Cabal/Distribution/*.hs) -utils/ghc-cabal/dist/build/tmp/ghc-cabal$(exeext): utils/ghc-cabal/Main.hs $(TOUCH_DEP) | $$(dir $$@)/. bootstrapping/. +$(ghc-cabal_DIST_BINARY): utils/ghc-cabal/Main.hs $(TOUCH_DEP) | $$(dir $$@)/. bootstrapping/. "$(GHC)" $(SRC_HC_OPTS) --make utils/ghc-cabal/Main.hs -o $@ \ -no-user-$(GHC_PACKAGE_DB_FLAG) \ -Wall -fno-warn-unused-imports -fno-warn-warnings-deprecations \ diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 2e7bab6cc4..e2f497f36c 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -612,7 +612,7 @@ readParseDatabase verbosity mb_user_conf use_cache path pkgs <- parseMultiPackageConf verbosity path mkPackageDB pkgs Right fs - | not use_cache -> ignore_cache + | not use_cache -> ignore_cache (const $ return ()) | otherwise -> do let cache = path </> cachefilename tdir <- getModificationTime path @@ -621,24 +621,42 @@ readParseDatabase verbosity mb_user_conf use_cache path Left ex -> do when (verbosity > Normal) $ warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex) - ignore_cache - Right tcache - | tcache >= tdir -> do - when (verbosity > Normal) $ - infoLn ("using cache: " ++ cache) - pkgs <- myReadBinPackageDB cache - let pkgs' = map convertPackageInfoIn pkgs - mkPackageDB pkgs' - | otherwise -> do - when (verbosity >= Normal) $ do - warn ("WARNING: cache is out of date: " ++ cache) - warn " use 'ghc-pkg recache' to fix." - ignore_cache + ignore_cache (const $ return ()) + Right tcache -> do + let compareTimestampToCache file = + when (verbosity >= Verbose) $ do + tFile <- getModificationTime file + compareTimestampToCache' file tFile + compareTimestampToCache' file tFile = do + let rel = case tcache `compare` tFile of + LT -> " (NEWER than cache)" + GT -> " (older than cache)" + EQ -> " (same as cache)" + warn ("Timestamp " ++ show tFile + ++ " for " ++ file ++ rel) + when (verbosity >= Verbose) $ do + warn ("Timestamp " ++ show tcache ++ " for " ++ cache) + compareTimestampToCache' path tdir + if tcache >= tdir + then do + when (verbosity > Normal) $ + infoLn ("using cache: " ++ cache) + pkgs <- myReadBinPackageDB cache + let pkgs' = map convertPackageInfoIn pkgs + mkPackageDB pkgs' + else do + when (verbosity >= Normal) $ do + warn ("WARNING: cache is out of date: " + ++ cache) + warn "Use 'ghc-pkg recache' to fix." + ignore_cache compareTimestampToCache where - ignore_cache = do + ignore_cache :: (FilePath -> IO ()) -> IO PackageDB + ignore_cache checkTime = do let confs = filter (".conf" `isSuffixOf`) fs - pkgs <- mapM (parseSingletonPackageConf verbosity) $ - map (path </>) confs + doFile f = do checkTime f + parseSingletonPackageConf verbosity f + pkgs <- mapM doFile $ map (path </>) confs mkPackageDB pkgs where mkPackageDB pkgs = do @@ -883,6 +901,10 @@ updateDBCache verbosity db = do if isPermissionError e then die (filename ++ ": you don't have permission to modify this file") else ioError e +#ifndef mingw32_HOST_OS + status <- getFileStatus filename + setFileTimes (location db) (accessTime status) (modificationTime status) +#endif -- ----------------------------------------------------------------------------- -- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar @@ -1153,35 +1175,17 @@ describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO () describeField verbosity my_flags pkgarg fields expand_pkgroot = do (_, _, flag_db_stack) <- getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags - fns <- toFields fields + fns <- mapM toField fields ps <- findPackages flag_db_stack pkgarg mapM_ (selectFields fns) ps - where toFields [] = return [] - toFields (f:fs) = case toField f of - Nothing -> die ("unknown field: " ++ f) - Just fn -> do fns <- toFields fs - return (fn:fns) + where showFun = if FlagSimpleOutput `elem` my_flags + then showSimpleInstalledPackageInfoField + else showInstalledPackageInfoField + toField f = case showFun f of + Nothing -> die ("unknown field: " ++ f) + Just fn -> return fn selectFields fns pinfo = mapM_ (\fn->putStrLn (fn pinfo)) fns -toField :: String -> Maybe (InstalledPackageInfo -> String) --- backwards compatibility: -toField "import_dirs" = Just $ strList . importDirs -toField "source_dirs" = Just $ strList . importDirs -toField "library_dirs" = Just $ strList . libraryDirs -toField "hs_libraries" = Just $ strList . hsLibraries -toField "extra_libraries" = Just $ strList . extraLibraries -toField "include_dirs" = Just $ strList . includeDirs -toField "c_includes" = Just $ strList . includes -toField "package_deps" = Just $ strList . map display. depends -toField "extra_cc_opts" = Just $ strList . ccOptions -toField "extra_ld_opts" = Just $ strList . ldOptions -toField "framework_dirs" = Just $ strList . frameworkDirs -toField "extra_frameworks"= Just $ strList . frameworks -toField s = showInstalledPackageInfoField s - -strList :: [String] -> String -strList = show - -- ----------------------------------------------------------------------------- -- Check: Check consistency of installed packages diff --git a/utils/hp2ps/Error.c b/utils/hp2ps/Error.c index 346e267eb1..57325f34e5 100644 --- a/utils/hp2ps/Error.c +++ b/utils/hp2ps/Error.c @@ -53,7 +53,7 @@ Usage(const char *str) printf(" -s use small title box\n"); printf(" -tf ignore trace bands which sum below f%% (default 1%%, max 5%%)\n"); printf(" -y traditional\n"); - printf(" -c colour ouput\n"); + printf(" -c colour output\n"); exit(0); } diff --git a/utils/runghc/ghc.mk b/utils/runghc/ghc.mk index cde8102312..5a56af5a49 100644 --- a/utils/runghc/ghc.mk +++ b/utils/runghc/ghc.mk @@ -32,7 +32,7 @@ install: install_runhaskell .PHONY: install_runhaskell ifeq "$(Windows_Host)" "YES" install_runhaskell: install_bins - "$(CP)" $(DESTDIR)$(bindir)/runghc$(exeext) $(DESTDIR)$(bindir)/runhaskell$(exeext) + "$(CP)" $(DESTDIR)$(bindir)/runghc$(exeext1) $(DESTDIR)$(bindir)/runhaskell$(exeext1) else install_runhaskell: $(call removeFiles,"$(DESTDIR)$(bindir)/runhaskell") @@ -49,6 +49,17 @@ do shift done +check_packages () { + echo "== Start $1 package check" + if [ "$bindistdir" = "" ] + then + inplace/bin/ghc-pkg check -v + else + "$bindistdir"/bin/ghc-pkg check -v + fi + echo "== End $1 package check" +} + if ! [ -d testsuite ] then echo 'You need the testsuite to validate' >&2 @@ -97,6 +108,8 @@ echo "ValidateHpc=$hpc" >> mk/are-validating.mk $make -j$threads # For a "debug make", add "--debug=b --debug=m" +check_packages post-build + # ----------------------------------------------------------------------------- # Build and test a binary distribution (not --fast) @@ -112,7 +125,11 @@ if [ $speed != "FAST" ]; then # bindistdir="bindisttest/install dir" + check_packages post-install + $make validate_build_xhtml BINDIST_PREFIX="$thisdir/$bindistdir" + + check_packages post-xhtml fi fi # testsuite-only @@ -147,6 +164,8 @@ esac $make $MAKE_TEST_TARGET stage=2 $BINDIST THREADS=$threads 2>&1 | tee testlog +check_packages post-testsuite + if [ "$hpc" = YES ] then utils/hpc/hpc markup --hpcdir=. --srcdir=compiler --srcdir=testsuite/hpc_output --destdir=testsuite/hpc_output testsuite/hpc_output/ghc.tix |