diff options
| author | Gabor Greif <ggreif@gmail.com> | 2014-08-08 18:01:19 +0200 |
|---|---|---|
| committer | Gabor Greif <ggreif@gmail.com> | 2014-08-08 18:01:19 +0200 |
| commit | 5f003d228340c3ce8e500f9053f353c58dc1dc94 (patch) | |
| tree | a855b0f173ff635b48354e1136ef6cbb2a1214a4 | |
| parent | ff9c5570395bcacf8963149b3a8475f5644ce694 (diff) | |
| parent | dff0623d5ab13222c06b3ff6b32793e05b417970 (diff) | |
| download | haskell-wip/generics-propeq.tar.gz | |
Merge branch 'master' into wip/generics-propeqwip/generics-propeq
Conflicts:
compiler/typecheck/TcGenGenerics.lhs
740 files changed, 18033 insertions, 11423 deletions
@@ -14,18 +14,63 @@ }, "text": { "type": "text", - "exclude": [ "(\\.xml$)" ], + "exclude": [ "(\\.xml)", "(Makefile)", "(\\.mk)" ], "severity": { "5": "disabled" } }, "text-xml": { "type": "text", - "include": "(\\.xml$)", + "include": "(\\.xml)", "severity": { "5": "disabled", "3": "disabled" } + }, + "makefiles": { + "type": "text", + "include": [ "(Makefile)", "(\\.mk)" ], + "severity": { + "2": "disabled" + } } - } + }, + + "exclude": + [ "(^libffi-tarballs)", + "(^libraries/binary)", + "(^libraries/bytestring)", + "(^libraries/Cabal)", + "(^libraries/containers)", + "(^libraries/haskeline)", + "(^libraries/pretty)", + "(^libraries/terminfo)", + "(^libraries/transformers)", + "(^libraries/xhtml)", + "(^libraries/Win32)", + "(^libraries/primitive)", + "(^libraries/vector)", + "(^libraries/time)", + "(^libraries/random)", + "(^libraries/array)", + "(^libraries/deepseq)", + "(^libraries/directory)", + "(^libraries/filepath)", + "(^libraries/haskell98)", + "(^libraries/haskell2010)", + "(^libraries/hoopl)", + "(^libraries/hpc)", + "(^libraries/old-locale)", + "(^libraries/old-time)", + "(^libraries/process)", + "(^libraries/unix)", + "(^libraries/parallel)", + "(^libraries/stm)", + "(^libraries/dph)", + "(^utils/haddock)", + "(^nofib)", + "(^utils/hsc2hs)", + "(^libffi-tarballs)", + "(^ghc-tarballs)" + ] } diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000000..57153b661b --- /dev/null +++ b/.travis.yml @@ -0,0 +1,36 @@ +git: + submodules: false + +notifications: + email: + - mail@joachim-breitner.de + - ghc-builds@haskell.org + +env: + - DEBUG_STAGE2=YES + - DEBUG_STAGE2=NO + +before_install: + - git config --global url."git://github.com/ghc/packages-".insteadOf git://github.com/ghc/packages/ + - git config --global url."http://github.com/ghc/packages-".insteadOf http://github.com/ghc/packages/ + - git config --global url."https://github.com/ghc/packages-".insteadOf https://github.com/ghc/packages/ + - git config --global url."ssh://git@github.com/ghc/packages-".insteadOf ssh://git@github.com/ghc/packages/ + - git config --global url."git@github.com:/ghc/packages-".insteadOf git@github.com:/ghc/packages/ + - git submodule update --init --recursive +install: + - sudo apt-get update + - sudo apt-get install haskell-platform autoconf libtool make ncurses-dev g++ dblatex docbook-xsl docbook-utils + - cabal update + - cabal install happy alex +script: + - echo 'V = 0' >> mk/validate.mk # otherwise we hit log file limits on travis. + # do not build docs + - echo 'HADDOCK_DOCS = NO' >> mk/validate.mk + - echo 'BUILD_DOCBOOK_HTML = NO' >> mk/validate.mk + - echo 'BUILD_DOCBOOK_PS = NO' >> mk/validate.mk + - echo 'BUILD_DOCBOOK_PDF = NO' >> mk/validate.mk + # do not build dynamic libraries + - echo 'DYNAMIC_GHC_PROGRAMS = NO' >> mk/validate.mk + - echo 'GhcLibWays = v' >> mk/validate.mk + - if [ "$DEBUG_STAGE" = "YES" ]; then echo 'GhcStage2HcOpts += -DDEBUG' >> mk/validate.mk; fi + - CPUS=2 SKIP_PERF_TESTS=YES PATH=~/.cabal/bin:$PATH ./validate --fast --no-dph @@ -1,6 +1,8 @@ The Glasgow Haskell Compiler ============================ +[](http://travis-ci.org/ghc/ghc) + This is the source tree for [GHC][1], a compiler and interactive environment for the Haskell functional programming language. diff --git a/Vagrantfile b/Vagrantfile index 9c116011a8..9f6f1a0ab6 100644 --- a/Vagrantfile +++ b/Vagrantfile @@ -4,27 +4,27 @@ MACHINES = { "ubuntu1204-i386" => { :box => "chef/ubuntu-12.04-i386", - :provision => "vagrant/bootstrap-deb.sh" + :provision => "utils/vagrant/bootstrap-deb.sh" }, "ubuntu1204-amd64" => { :box => "chef/ubuntu-12.04", - :provision => "vagrant/bootstrap-deb.sh" + :provision => "utils/vagrant/bootstrap-deb.sh" }, "centos65-i386" => { :box => "chef/centos-6.5-i386", - :provision => "vagrant/bootstrap-rhel.sh" + :provision => "utils/vagrant/bootstrap-rhel.sh" }, "centos65-amd64" => { :box => "chef/centos-6.5", - :provision => "vagrant/bootstrap-rhel.sh" + :provision => "utils/vagrant/bootstrap-rhel.sh" }, "debian74-i386" => { :box => "chef/debian-7.4-i386", - :provision => "vagrant/bootstrap-deb.sh" + :provision => "utils/vagrant/bootstrap-deb.sh" }, "debian74-amd64" => { :box => "chef/debian-7.4", - :provision => "vagrant/bootstrap-deb.sh" + :provision => "utils/vagrant/bootstrap-deb.sh" } } diff --git a/aclocal.m4 b/aclocal.m4 index 5923e9716b..fbd82d9a67 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -454,6 +454,8 @@ AC_DEFUN([FP_SETTINGS], then mingw_bin_prefix=mingw/bin/ SettingsCCompilerCommand="\$topdir/../${mingw_bin_prefix}gcc.exe" + SettingsHaskellCPPCommand="\$topdir/../${mingw_bin_prefix}gcc.exe" + SettingsHaskellCPPFlags="$HaskellCPPArgs" SettingsLdCommand="\$topdir/../${mingw_bin_prefix}ld.exe" SettingsArCommand="\$topdir/../${mingw_bin_prefix}ar.exe" SettingsPerlCommand='$topdir/../perl/perl.exe' @@ -462,6 +464,8 @@ AC_DEFUN([FP_SETTINGS], SettingsTouchCommand='$topdir/touchy.exe' else SettingsCCompilerCommand="$WhatGccIsCalled" + SettingsHaskellCPPCommand="$HaskellCPPCmd" + SettingsHaskellCPPFlags="$HaskellCPPArgs" SettingsLdCommand="$LdCmd" SettingsArCommand="$ArCmd" SettingsPerlCommand="$PerlCmd" @@ -486,6 +490,8 @@ AC_DEFUN([FP_SETTINGS], SettingsCCompilerLinkFlags="$CONF_GCC_LINKER_OPTS_STAGE2" SettingsLdFlags="$CONF_LD_LINKER_OPTS_STAGE2" AC_SUBST(SettingsCCompilerCommand) + AC_SUBST(SettingsHaskellCPPCommand) + AC_SUBST(SettingsHaskellCPPFlags) AC_SUBST(SettingsCCompilerFlags) AC_SUBST(SettingsCCompilerLinkFlags) AC_SUBST(SettingsLdCommand) @@ -520,6 +526,12 @@ AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS], esac case $$1 in + i386-unknown-mingw32) + $2="$$2 -march=i686" + ;; + i386-portbld-freebsd*) + $2="$$2 -march=i686" + ;; i386-apple-darwin) $2="$$2 -m32" $3="$$3 -m32" @@ -532,6 +544,12 @@ AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS], $4="$$4 -arch x86_64" $5="$$5 -m64" ;; + x86_64-unknown-solaris2) + $2="$$2 -m64" + $3="$$3 -m64" + $4="$$4 -m64" + $5="$$5 -m64" + ;; alpha-*) # For now, to suppress the gcc warning "call-clobbered # register used for global register variable", we simply @@ -706,6 +724,8 @@ AC_ARG_WITH($2, ) ]) # FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL + + # FP_PROG_CONTEXT_DIFF # -------------------- # Figure out how to do context diffs. Sets the output variable ContextDiffCmd. @@ -2049,7 +2069,11 @@ AC_DEFUN([FIND_LLVM_PROG],[ IFS=":;" 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 "$windows" = YES; then + $1=`${FindCmd} "${p}" -type f -maxdepth 1 -regex '.*/$3-[[0-9]]\.[[0-9]]' -or -type l -maxdepth 1 -regex '.*/$3-[[0-9]]\.[[0-9]]' | ${SortCmd} -n | tail -1` + else + $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` + fi if test -n "$$1"; then break fi @@ -2080,7 +2104,7 @@ AC_DEFUN([FIND_GCC],[ $1="$CC" else FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL([$1], [$2], [$3]) - # From Xcode 5 on, OS X command line tools do not include gcc + # From Xcode 5 on/, OS X command line tools do not include gcc # anymore. Use clang. if test -z "$$1" then @@ -2101,4 +2125,6 @@ AC_DEFUN([MAYBE_OVERRIDE_STAGE0],[ fi ]) + + # LocalWords: fi diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 9a92b003bc..2f86db7796 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -41,7 +41,8 @@ module BasicTypes( TopLevelFlag(..), isTopLevel, isNotTopLevel, - OverlapFlag(..), + OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, + hasOverlappingFlag, hasOverlappableFlag, Boxity(..), isBoxed, @@ -447,39 +448,92 @@ instance Outputable Origin where -- | 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 - -- more specific one that matches the constraint - -- you are trying to resolve - -- - -- Example: constraint (Foo [Int]) - -- instances (Foo [Int]) - -- (Foo [a]) OverlapOk - -- Since the second instance has the OverlapOk flag, - -- the first instance will be chosen (otherwise - -- its ambiguous which to choose) - | OverlapOk { isSafeOverlap :: Bool } - - -- | Silently ignore this instance if you find any other that matches the - -- constraing you are trying to resolve, including when checking if there are - -- instances that do not match, but unify. - -- - -- Example: constraint (Foo [b]) - -- instances (Foo [Int]) Incoherent - -- (Foo [a]) - -- Without the Incoherent flag, we'd complain that - -- instantiating 'b' would change which instance - -- was chosen. See also note [Incoherent instances] - | Incoherent { isSafeOverlap :: Bool } +data OverlapFlag = OverlapFlag + { overlapMode :: OverlapMode + , isSafeOverlap :: Bool + } deriving (Eq, Data, Typeable) + +setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag +setOverlapModeMaybe f Nothing = f +setOverlapModeMaybe f (Just m) = f { overlapMode = m } + +hasOverlappableFlag :: OverlapMode -> Bool +hasOverlappableFlag mode = + case mode of + Overlappable -> True + Overlaps -> True + Incoherent -> True + _ -> False + +hasOverlappingFlag :: OverlapMode -> Bool +hasOverlappingFlag mode = + case mode of + Overlapping -> True + Overlaps -> True + Incoherent -> True + _ -> False + +data OverlapMode -- See Note [Rules for instance lookup] in InstEnv + = NoOverlap + -- ^ This instance must not overlap another `NoOverlap` instance. + -- However, it may be overlapped by `Overlapping` instances, + -- and it may overlap `Overlappable` instances. + + + | Overlappable + -- ^ Silently ignore this instance if you find a + -- more specific one that matches the constraint + -- you are trying to resolve + -- + -- Example: constraint (Foo [Int]) + -- instance Foo [Int] + -- instance {-# OVERLAPPABLE #-} Foo [a] + -- + -- Since the second instance has the Overlappable flag, + -- the first instance will be chosen (otherwise + -- its ambiguous which to choose) + + + | Overlapping + -- ^ Silently ignore any more general instances that may be + -- used to solve the constraint. + -- + -- Example: constraint (Foo [Int]) + -- instance {-# OVERLAPPING #-} Foo [Int] + -- instance Foo [a] + -- + -- Since the first instance has the Overlapping flag, + -- the second---more general---instance will be ignored (otherwise + -- it is ambiguous which to choose) + + + | Overlaps + -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. + + | Incoherent + -- ^ Behave like Overlappable and Overlapping, and in addition pick + -- an an arbitrary one if there are multiple matching candidates, and + -- don't worry about later instantiation + -- + -- Example: constraint (Foo [b]) + -- instance {-# INCOHERENT -} Foo [Int] + -- instance Foo [a] + -- Without the Incoherent flag, we'd complain that + -- instantiating 'b' would change which instance + -- was chosen. See also note [Incoherent instances] in InstEnv + deriving (Eq, Data, Typeable) + instance Outputable OverlapFlag where - ppr (NoOverlap b) = empty <+> pprSafeOverlap b - ppr (OverlapOk b) = ptext (sLit "[overlap ok]") <+> pprSafeOverlap b - ppr (Incoherent b) = ptext (sLit "[incoherent]") <+> pprSafeOverlap b + ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) + +instance Outputable OverlapMode where + ppr NoOverlap = empty + ppr Overlappable = ptext (sLit "[overlappable]") + ppr Overlapping = ptext (sLit "[overlapping]") + ppr Overlaps = ptext (sLit "[overlap ok]") + ppr Incoherent = ptext (sLit "[incoherent]") pprSafeOverlap :: Bool -> SDoc pprSafeOverlap True = ptext $ sLit "[safe]" @@ -761,7 +815,7 @@ data InlinePragma -- Note [InlinePragma] , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? } deriving( Eq, Data, Typeable ) -data InlineSpec -- What the user's INLINE pragama looked like +data InlineSpec -- What the user's INLINE pragma looked like = Inline | Inlinable | NoInline diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 0dcf98f6c5..771aa303a1 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -942,7 +942,7 @@ dataConRepArgTys (MkData { dcRep = rep -- to its info table and used by the GHCi debugger and the heap profiler dataConIdentity :: DataCon -> [Word8] -- We want this string to be UTF-8, so we get the bytes directly from the FastStrings. -dataConIdentity dc = bytesFS (packageIdFS (modulePackageId mod)) ++ +dataConIdentity dc = bytesFS (packageKeyFS (modulePackageKey mod)) ++ fromIntegral (ord ':') : bytesFS (moduleNameFS (moduleName mod)) ++ fromIntegral (ord '.') : bytesFS (occNameFS (nameOccName name)) where name = dataConName dc diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index f3615bca64..ed055b5808 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -66,7 +66,7 @@ import BasicTypes import Binary import Maybes ( orElse ) -import Type ( Type ) +import Type ( Type, isUnLiftedType ) import TyCon ( isNewTyCon, isClassTyCon ) import DataCon ( splitDataProductType_maybe ) import FastString @@ -1201,13 +1201,18 @@ type DeferAndUse -- Describes how to degrade a result type type DeferAndUseM = Maybe DeferAndUse -- Nothing <=> absent-ify the result type; it will never be used -toCleanDmd :: Demand -> (CleanDemand, DeferAndUseM) --- See Note [Analyzing with lazy demand and lambdas] -toCleanDmd (JD { strd = s, absd = u }) +toCleanDmd :: Demand -> Type -> (CleanDemand, DeferAndUseM) +toCleanDmd (JD { strd = s, absd = u }) expr_ty = case (s,u) of - (Str s', Use c u') -> (CD { sd = s', ud = u' }, Just (False, c)) - (Lazy, Use c u') -> (CD { sd = HeadStr, ud = u' }, Just (True, c)) - (_, Abs) -> (CD { sd = HeadStr, ud = Used }, Nothing) + (Str s', Use c u') -> -- The normal case + (CD { sd = s', ud = u' }, Just (False, c)) + + (Lazy, Use c u') -> -- See Note [Analyzing with lazy demand and lambdas] + (CD { sd = HeadStr, ud = u' }, Just (True, c)) + + (_, Abs) -- See Note [Analysing with absent demand] + | isUnLiftedType expr_ty -> (CD { sd = HeadStr, ud = Used }, Just (False, One)) + | otherwise -> (CD { sd = HeadStr, ud = Used }, Nothing) -- This is used in dmdAnalStar when post-processing -- a function's argument demand. So we only care about what @@ -1382,13 +1387,13 @@ cardinality analysis of the following example: {-# NOINLINE build #-} build g = (g (:) [], g (:) []) -h c z = build (\x -> - let z1 = z ++ z +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))>. +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 @@ -1397,6 +1402,46 @@ 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. +Note [Analysing with absent demand] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we analyse an expression with demand <L,A>. The "A" means +"absent", so this expression will never be needed. What should happen? +There are several wrinkles: + +* We *do* want to analyse the expression regardless. + Reason: Note [Always analyse in virgin pass] + + But we can post-process the results to ignore all the usage + demands coming back. This is done by postProcessDmdTypeM. + +* But in the case of an *unlifted type* we must be extra careful, + because unlifted values are evaluated even if they are not used. + Example (see Trac #9254): + f :: (() -> (# Int#, () #)) -> () + -- Strictness signature is + -- <C(S(LS)), 1*C1(U(A,1*U()))> + -- I.e. calls k, but discards first component of result + f k = case k () of (# _, r #) -> r + + g :: Int -> () + g y = f (\n -> (# case y of I# y2 -> y2, n #)) + + Here f's strictness signature says (correctly) that it calls its + argument function and ignores the first component of its result. + This is correct in the sense that it'd be fine to (say) modify the + function so that always returned 0# in the first component. + + But in function g, we *will* evaluate the 'case y of ...', because + it has type Int#. So 'y' will be evaluated. So we must record this + usage of 'y', else 'g' will say 'y' is absent, and will w/w so that + 'y' is bound to an aBSENT_ERROR thunk. + + An alternative would be to replace the 'case y of ...' with (say) 0#, + but I have not tried that. It's not a common situation, but it is + not theoretical: unsafePerformIO's implementation is very very like + 'f' above. + + %************************************************************************ %* * Demand signatures diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index 080ae47ac9..8f21d66bc1 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -23,30 +23,31 @@ module Module mkModuleNameFS, stableModuleNameCmp, - -- * The PackageId type - PackageId, - fsToPackageId, - packageIdFS, - stringToPackageId, - packageIdString, - stablePackageIdCmp, - - -- * Wired-in PackageIds + -- * The PackageKey type + PackageKey, + fsToPackageKey, + packageKeyFS, + stringToPackageKey, + packageKeyString, + stablePackageKeyCmp, + + -- * Wired-in PackageKeys -- $wired_in_packages - primPackageId, - integerPackageId, - basePackageId, - rtsPackageId, - thPackageId, - dphSeqPackageId, - dphParPackageId, - mainPackageId, - thisGhcPackageId, - interactivePackageId, isInteractiveModule, + primPackageKey, + integerPackageKey, + basePackageKey, + rtsPackageKey, + thPackageKey, + dphSeqPackageKey, + dphParPackageKey, + mainPackageKey, + thisGhcPackageKey, + interactivePackageKey, isInteractiveModule, + wiredInPackageKeys, -- * The Module type Module, - modulePackageId, moduleName, + modulePackageKey, moduleName, pprModule, mkModule, stableModuleCmp, @@ -82,6 +83,7 @@ import UniqFM import FastString import Binary import Util +import {-# SOURCE #-} Packages import Data.Data import Data.Map (Map) @@ -228,15 +230,15 @@ moduleNameColons = dots_to_colons . moduleNameString %************************************************************************ \begin{code} --- | A Module is a pair of a 'PackageId' and a 'ModuleName'. +-- | A Module is a pair of a 'PackageKey' and a 'ModuleName'. data Module = Module { - modulePackageId :: !PackageId, -- pkg-1.0 + modulePackageKey :: !PackageKey, -- pkg-1.0 moduleName :: !ModuleName -- A.B.C } deriving (Eq, Ord, Typeable) instance Uniquable Module where - getUnique (Module p n) = getUnique (packageIdFS p `appendFS` moduleNameFS n) + getUnique (Module p n) = getUnique (packageKeyFS p `appendFS` moduleNameFS n) instance Outputable Module where ppr = pprModule @@ -256,25 +258,25 @@ instance Data Module where -- not be stable from run to run of the compiler. stableModuleCmp :: Module -> Module -> Ordering stableModuleCmp (Module p1 n1) (Module p2 n2) - = (p1 `stablePackageIdCmp` p2) `thenCmp` + = (p1 `stablePackageKeyCmp` p2) `thenCmp` (n1 `stableModuleNameCmp` n2) -mkModule :: PackageId -> ModuleName -> Module +mkModule :: PackageKey -> ModuleName -> Module mkModule = Module pprModule :: Module -> SDoc pprModule mod@(Module p n) = pprPackagePrefix p mod <> pprModuleName n -pprPackagePrefix :: PackageId -> Module -> SDoc +pprPackagePrefix :: PackageKey -> Module -> SDoc pprPackagePrefix p mod = getPprStyle doc where doc sty | codeStyle sty = - if p == mainPackageId + if p == mainPackageKey then empty -- never qualify the main package in code - else ztext (zEncodeFS (packageIdFS p)) <> char '_' - | qualModule sty mod = ftext (packageIdFS (modulePackageId mod)) <> char ':' + else ztext (zEncodeFS (packageKeyFS p)) <> char '_' + | qualModule sty mod = ppr (modulePackageKey mod) <> char ':' -- the PrintUnqualified tells us which modules have to -- be qualified with package names | otherwise = empty @@ -288,51 +290,59 @@ class HasModule m where %************************************************************************ %* * -\subsection{PackageId} +\subsection{PackageKey} %* * %************************************************************************ \begin{code} --- | Essentially just a string identifying a package, including the version: e.g. parsec-1.0 -newtype PackageId = PId FastString deriving( Eq, Typeable ) +-- | A string which uniquely identifies a package. For wired-in packages, +-- it is just the package name, but for user compiled packages, it is a hash. +-- ToDo: when the key is a hash, we can do more clever things than store +-- the hex representation and hash-cons those strings. +newtype PackageKey = PId FastString deriving( Eq, Typeable ) -- here to avoid module loops with PackageConfig -instance Uniquable PackageId where - getUnique pid = getUnique (packageIdFS pid) +instance Uniquable PackageKey where + getUnique pid = getUnique (packageKeyFS pid) -- Note: *not* a stable lexicographic ordering, a faster unique-based -- ordering. -instance Ord PackageId where +instance Ord PackageKey where nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2 -instance Data PackageId where +instance Data PackageKey where -- don't traverse? - toConstr _ = abstractConstr "PackageId" + toConstr _ = abstractConstr "PackageKey" gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "PackageId" + dataTypeOf _ = mkNoRepType "PackageKey" -stablePackageIdCmp :: PackageId -> PackageId -> Ordering +stablePackageKeyCmp :: PackageKey -> PackageKey -> Ordering -- ^ Compares package ids lexically, rather than by their 'Unique's -stablePackageIdCmp p1 p2 = packageIdFS p1 `compare` packageIdFS p2 +stablePackageKeyCmp p1 p2 = packageKeyFS p1 `compare` packageKeyFS p2 -instance Outputable PackageId where - ppr pid = text (packageIdString pid) +instance Outputable PackageKey where + ppr pk = getPprStyle $ \sty -> sdocWithDynFlags $ \dflags -> + text (packageKeyPackageIdString dflags pk) + -- Don't bother qualifying if it's wired in! + <> (if qualPackage sty pk && not (pk `elem` wiredInPackageKeys) + then char '@' <> ftext (packageKeyFS pk) + else empty) -instance Binary PackageId where - put_ bh pid = put_ bh (packageIdFS pid) - get bh = do { fs <- get bh; return (fsToPackageId fs) } +instance Binary PackageKey where + put_ bh pid = put_ bh (packageKeyFS pid) + get bh = do { fs <- get bh; return (fsToPackageKey fs) } -fsToPackageId :: FastString -> PackageId -fsToPackageId = PId +fsToPackageKey :: FastString -> PackageKey +fsToPackageKey = PId -packageIdFS :: PackageId -> FastString -packageIdFS (PId fs) = fs +packageKeyFS :: PackageKey -> FastString +packageKeyFS (PId fs) = fs -stringToPackageId :: String -> PackageId -stringToPackageId = fsToPackageId . mkFastString +stringToPackageKey :: String -> PackageKey +stringToPackageKey = fsToPackageKey . mkFastString -packageIdString :: PackageId -> String -packageIdString = unpackFS . packageIdFS +packageKeyString :: PackageKey -> String +packageKeyString = unpackFS . packageKeyFS -- ----------------------------------------------------------------------------- @@ -348,7 +358,7 @@ packageIdString = unpackFS . packageIdFS -- versions of them installed. However, for each invocation of GHC, -- only a single instance of each wired-in package will be recognised -- (the desired one is selected via @-package@\/@-hide-package@), and GHC --- will use the unversioned 'PackageId' below when referring to it, +-- will use the unversioned 'PackageKey' below when referring to it, -- including in .hi files and object file symbols. Unselected -- versions of wired-in packages will be ignored, as will any other -- package that depends directly or indirectly on it (much as if you @@ -356,27 +366,37 @@ packageIdString = unpackFS . packageIdFS -- Make sure you change 'Packages.findWiredInPackages' if you add an entry here -integerPackageId, primPackageId, - basePackageId, rtsPackageId, - thPackageId, dphSeqPackageId, dphParPackageId, - mainPackageId, thisGhcPackageId, interactivePackageId :: PackageId -primPackageId = fsToPackageId (fsLit "ghc-prim") -integerPackageId = fsToPackageId (fsLit cIntegerLibrary) -basePackageId = fsToPackageId (fsLit "base") -rtsPackageId = fsToPackageId (fsLit "rts") -thPackageId = fsToPackageId (fsLit "template-haskell") -dphSeqPackageId = fsToPackageId (fsLit "dph-seq") -dphParPackageId = fsToPackageId (fsLit "dph-par") -thisGhcPackageId = fsToPackageId (fsLit ("ghc-" ++ cProjectVersion)) -interactivePackageId = fsToPackageId (fsLit "interactive") +integerPackageKey, primPackageKey, + basePackageKey, rtsPackageKey, + thPackageKey, dphSeqPackageKey, dphParPackageKey, + mainPackageKey, thisGhcPackageKey, interactivePackageKey :: PackageKey +primPackageKey = fsToPackageKey (fsLit "ghc-prim") +integerPackageKey = fsToPackageKey (fsLit cIntegerLibrary) +basePackageKey = fsToPackageKey (fsLit "base") +rtsPackageKey = fsToPackageKey (fsLit "rts") +thPackageKey = fsToPackageKey (fsLit "template-haskell") +dphSeqPackageKey = fsToPackageKey (fsLit "dph-seq") +dphParPackageKey = fsToPackageKey (fsLit "dph-par") +thisGhcPackageKey = fsToPackageKey (fsLit "ghc") +interactivePackageKey = fsToPackageKey (fsLit "interactive") -- | This is the package Id for the current program. It is the default -- package Id if you don't specify a package name. We don't add this prefix -- to symbol names, since there can be only one main package per program. -mainPackageId = fsToPackageId (fsLit "main") +mainPackageKey = fsToPackageKey (fsLit "main") isInteractiveModule :: Module -> Bool -isInteractiveModule mod = modulePackageId mod == interactivePackageId +isInteractiveModule mod = modulePackageKey mod == interactivePackageKey + +wiredInPackageKeys :: [PackageKey] +wiredInPackageKeys = [ primPackageKey, + integerPackageKey, + basePackageKey, + rtsPackageKey, + thPackageKey, + thisGhcPackageKey, + dphSeqPackageKey, + dphParPackageKey ] \end{code} %************************************************************************ diff --git a/compiler/basicTypes/Module.lhs-boot b/compiler/basicTypes/Module.lhs-boot index 63839b55bc..6d194d6a2a 100644 --- a/compiler/basicTypes/Module.lhs-boot +++ b/compiler/basicTypes/Module.lhs-boot @@ -3,8 +3,8 @@ module Module where data Module data ModuleName -data PackageId +data PackageKey moduleName :: Module -> ModuleName -modulePackageId :: Module -> PackageId -packageIdString :: PackageId -> String +modulePackageKey :: Module -> PackageKey +packageKeyString :: PackageKey -> String \end{code} diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index c2e7aeabdc..7651c7c749 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -503,7 +503,7 @@ pprModulePrefix sty mod occ = sdocWithDynFlags $ \dflags -> case qualName sty mod occ of -- See Outputable.QualifyName: NameQual modname -> ppr modname <> dot -- Name is in scope NameNotInScope1 -> ppr mod <> dot -- Not in scope - NameNotInScope2 -> ppr (modulePackageId mod) <> colon -- Module not in + NameNotInScope2 -> ppr (modulePackageKey mod) <> colon -- Module not in <> ppr (moduleName mod) <> dot -- scope either _otherwise -> empty diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index ebfb71aa65..d4afaf10fc 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -817,7 +817,7 @@ data ImpDeclSpec -- the defining module for this thing! -- TODO: either should be Module, or there - -- should be a Maybe PackageId here too. + -- should be a Maybe PackageKey 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 diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 407002f1c7..02ad026249 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -158,14 +158,14 @@ data CLabel -- | A label from a .cmm file that is not associated with a .hs level Id. | CmmLabel - PackageId -- what package the label belongs to. + PackageKey -- what package the label belongs to. FastString -- identifier giving the prefix of the label CmmLabelInfo -- encodes the suffix of the label -- | A label with a baked-in \/ algorithmically generated name that definitely -- comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so -- If it doesn't have an algorithmically generated name then use a CmmLabel - -- instead and give it an appropriate PackageId argument. + -- instead and give it an appropriate PackageKey argument. | RtsLabel RtsLabelInfo @@ -237,7 +237,7 @@ data CLabel data ForeignLabelSource -- | Label is in a named package - = ForeignLabelInPackage PackageId + = ForeignLabelInPackage PackageKey -- | Label is in some external, system package that doesn't also -- contain compiled Haskell code, and is not associated with any .hi files. @@ -411,27 +411,27 @@ mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel, mkArrWords_infoLabel, mkSMAP_FROZEN_infoLabel, mkSMAP_FROZEN0_infoLabel, mkSMAP_DIRTY_infoLabel :: CLabel mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction -mkSplitMarkerLabel = CmmLabel rtsPackageId (fsLit "__stg_split_marker") 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 -mkMainCapabilityLabel = CmmLabel rtsPackageId (fsLit "MainCapability") CmmData -mkMAP_FROZEN_infoLabel = CmmLabel rtsPackageId (fsLit "stg_MUT_ARR_PTRS_FROZEN") CmmInfo -mkMAP_FROZEN0_infoLabel = CmmLabel rtsPackageId (fsLit "stg_MUT_ARR_PTRS_FROZEN0") CmmInfo -mkMAP_DIRTY_infoLabel = CmmLabel rtsPackageId (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo -mkEMPTY_MVAR_infoLabel = CmmLabel rtsPackageId (fsLit "stg_EMPTY_MVAR") CmmInfo -mkTopTickyCtrLabel = CmmLabel rtsPackageId (fsLit "top_ct") CmmData -mkCAFBlackHoleInfoTableLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmInfo -mkCAFBlackHoleEntryLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmEntry -mkArrWords_infoLabel = CmmLabel rtsPackageId (fsLit "stg_ARR_WORDS") CmmInfo -mkSMAP_FROZEN_infoLabel = CmmLabel rtsPackageId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN") CmmInfo -mkSMAP_FROZEN0_infoLabel = CmmLabel rtsPackageId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN0") CmmInfo -mkSMAP_DIRTY_infoLabel = CmmLabel rtsPackageId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo +mkSplitMarkerLabel = CmmLabel rtsPackageKey (fsLit "__stg_split_marker") CmmCode +mkUpdInfoLabel = CmmLabel rtsPackageKey (fsLit "stg_upd_frame") CmmInfo +mkBHUpdInfoLabel = CmmLabel rtsPackageKey (fsLit "stg_bh_upd_frame" ) CmmInfo +mkIndStaticInfoLabel = CmmLabel rtsPackageKey (fsLit "stg_IND_STATIC") CmmInfo +mkMainCapabilityLabel = CmmLabel rtsPackageKey (fsLit "MainCapability") CmmData +mkMAP_FROZEN_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_MUT_ARR_PTRS_FROZEN") CmmInfo +mkMAP_FROZEN0_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_MUT_ARR_PTRS_FROZEN0") CmmInfo +mkMAP_DIRTY_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo +mkEMPTY_MVAR_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_EMPTY_MVAR") CmmInfo +mkTopTickyCtrLabel = CmmLabel rtsPackageKey (fsLit "top_ct") CmmData +mkCAFBlackHoleInfoTableLabel = CmmLabel rtsPackageKey (fsLit "stg_CAF_BLACKHOLE") CmmInfo +mkCAFBlackHoleEntryLabel = CmmLabel rtsPackageKey (fsLit "stg_CAF_BLACKHOLE") CmmEntry +mkArrWords_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_ARR_WORDS") CmmInfo +mkSMAP_FROZEN_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN") CmmInfo +mkSMAP_FROZEN0_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN0") CmmInfo +mkSMAP_DIRTY_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo ----- mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel, mkCmmCodeLabel, mkCmmDataLabel, mkCmmClosureLabel - :: PackageId -> FastString -> CLabel + :: PackageKey -> FastString -> CLabel mkCmmInfoLabel pkg str = CmmLabel pkg str CmmInfo mkCmmEntryLabel pkg str = CmmLabel pkg str CmmEntry @@ -639,7 +639,7 @@ needsCDecl (RtsLabel _) = False needsCDecl (CmmLabel pkgId _ _) -- Prototypes for labels defined in the runtime system are imported -- into HC files via includes/Stg.h. - | pkgId == rtsPackageId = False + | pkgId == rtsPackageKey = False -- For other labels we inline one into the HC file directly. | otherwise = True @@ -849,11 +849,11 @@ idInfoLabelType info = -- @labelDynamic@ returns @True@ if the label is located -- in a DLL, be it a data reference or not. -labelDynamic :: DynFlags -> PackageId -> Module -> CLabel -> Bool +labelDynamic :: DynFlags -> PackageKey -> 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) + RtsLabel _ -> not (gopt Opt_Static dflags) && (this_pkg /= rtsPackageKey) IdLabel n _ _ -> isDllName dflags this_pkg this_mod n @@ -886,7 +886,9 @@ labelDynamic dflags this_pkg this_mod lbl = -- libraries True - PlainModuleInitLabel m -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageId m) + PlainModuleInitLabel m -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageKey m) + + HpcTicksLabel m -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageKey m) -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves. _ -> False diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index e21efc13af..9e9bae93c6 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -80,10 +80,7 @@ data GenCmmDecl d h g -- registers will be correct in generated C-- code, but -- not in hand-written C-- code. However, -- splitAtProcPoints calculates correct liveness - -- information for CmmProc's. Right now only the LLVM - -- back-end relies on correct liveness information and - -- for that back-end we always call splitAtProcPoints, so - -- all is good. + -- information for CmmProcs. g -- Control-flow graph for the procedure's code | CmmData -- Static data diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index e10716a2ac..6521a84006 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -286,7 +286,7 @@ bundle :: Map CLabel CAFSet -> (CAFEnv, CmmDecl) -> (CAFSet, Maybe CLabel) -> (BlockEnv CAFSet, CmmDecl) -bundle flatmap (env, decl@(CmmProc infos lbl _ g)) (closure_cafs, mb_lbl) +bundle flatmap (env, decl@(CmmProc infos _lbl _ g)) (closure_cafs, mb_lbl) = ( mapMapWithKey get_cafs (info_tbls infos), decl ) where entry = g_entry g @@ -297,9 +297,13 @@ bundle flatmap (env, decl@(CmmProc infos lbl _ g)) (closure_cafs, mb_lbl) get_cafs l _ | l == entry = entry_cafs - | otherwise = if not (mapMember l env) - then pprPanic "bundle" (ppr l <+> ppr lbl <+> ppr (info_tbls infos) $$ ppr env $$ ppr decl) - else flatten flatmap $ expectJust "bundle" $ mapLookup l env + | Just info <- mapLookup l env = flatten flatmap info + | otherwise = Set.empty + -- the label might not be in the env if the code corresponding to + -- this info table was optimised away (perhaps because it was + -- unreachable). In this case it doesn't matter what SRT we + -- infer, since the info table will not appear in the generated + -- code. See #9329. bundle _flatmap (_, decl) _ = ( mapEmpty, decl ) diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index aae3ea1c71..3bfc728ac0 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -1,11 +1,4 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module CmmInfo ( mkEmptyContInfoTable, cmmToRawCmm, @@ -62,7 +55,7 @@ import Data.Word -- When we split at proc points, we need an empty info table. mkEmptyContInfoTable :: CLabel -> CmmInfoTable -mkEmptyContInfoTable info_lbl +mkEmptyContInfoTable info_lbl = CmmInfoTable { cit_lbl = info_lbl , cit_rep = mkStackRep [] , cit_prof = NoProfilingInfo @@ -84,31 +77,31 @@ cmmToRawCmm dflags cmms -- represented by a label+offset expression). -- -- With tablesNextToCode, the layout is --- <reversed variable part> --- <normal forward StgInfoTable, but without --- an entry point at the front> --- <code> +-- <reversed variable part> +-- <normal forward StgInfoTable, but without +-- an entry point at the front> +-- <code> -- -- Without tablesNextToCode, the layout of an info table is --- <entry label> --- <normal forward rest of StgInfoTable> --- <forward variable part> +-- <entry label> +-- <normal forward rest of StgInfoTable> +-- <forward variable part> -- --- See includes/rts/storage/InfoTables.h +-- See includes/rts/storage/InfoTables.h -- -- For return-points these are as follows -- -- Tables next to code: -- --- <srt slot> --- <standard info table> --- ret-addr --> <entry code (if any)> +-- <srt slot> +-- <standard info table> +-- ret-addr --> <entry code (if any)> -- -- Not tables-next-to-code: -- --- ret-addr --> <ptr to entry code> --- <standard info table> --- <srt slot> +-- ret-addr --> <ptr to entry code> +-- <standard info table> +-- <srt slot> -- -- * The SRT slot is only there if there is SRT info to record @@ -168,21 +161,21 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) reverse rel_extra_bits ++ rel_std_info)) ----------------------------------------------------- -type InfoTableContents = ( [CmmLit] -- The standard part - , [CmmLit] ) -- The "extra bits" +type InfoTableContents = ( [CmmLit] -- The standard part + , [CmmLit] ) -- The "extra bits" -- These Lits have *not* had mkRelativeTo applied to them mkInfoTableContents :: DynFlags -> CmmInfoTable -> Maybe Int -- Override default RTS type tag? -> UniqSM ([RawCmmDecl], -- Auxiliary top decls - InfoTableContents) -- Info tbl + extra bits + InfoTableContents) -- Info tbl + extra bits mkInfoTableContents dflags info@(CmmInfoTable { cit_lbl = info_lbl , cit_rep = smrep , cit_prof = prof - , cit_srt = srt }) + , cit_srt = srt }) mb_rts_tag | RTSRep rts_tag rep <- smrep = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag) @@ -216,9 +209,9 @@ mkInfoTableContents dflags where mk_pieces :: ClosureTypeInfo -> [CmmLit] -> UniqSM ( Maybe StgHalfWord -- Override the SRT field with this - , Maybe CmmLit -- Override the layout field with this - , [CmmLit] -- "Extra bits" for info table - , [RawCmmDecl]) -- Auxiliary data decls + , Maybe CmmLit -- Override the layout field with this + , [CmmLit] -- "Extra bits" for info table + , [RawCmmDecl]) -- Auxiliary data decls mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor = do { (descr_lit, decl) <- newStringLit con_descr ; return ( Just (toStgHalfWord dflags (fromIntegral con_tag)) @@ -231,7 +224,7 @@ mkInfoTableContents dflags = return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags (fromIntegral offset)), [], []) -- Layout known (one free var); we use the layout field for offset - mk_pieces (Fun arity (ArgSpec fun_type)) srt_label + mk_pieces (Fun arity (ArgSpec fun_type)) srt_label = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label ; return (Nothing, Nothing, extra_bits, []) } @@ -281,7 +274,7 @@ mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap) ------------------------------------------------------------------------- -- --- Position independent code +-- Position independent code -- ------------------------------------------------------------------------- -- In order to support position independent code, we mustn't put absolute @@ -293,7 +286,7 @@ mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap) -- as we want to keep binary compatibility between PIC and non-PIC. makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit - + makeRelativeRefTo dflags info_lbl (CmmLabel lbl) | tablesNextToCode dflags = CmmLabelDiffOff lbl info_lbl 0 @@ -305,16 +298,16 @@ makeRelativeRefTo _ _ lit = lit ------------------------------------------------------------------------- -- --- Build a liveness mask for the stack layout +-- Build a liveness mask for the stack layout -- ------------------------------------------------------------------------- -- There are four kinds of things on the stack: -- --- - pointer variables (bound in the environment) --- - non-pointer variables (bound in the environment) --- - free slots (recorded in the stack free list) --- - non-pointer data slots (recorded in the stack free list) +-- - pointer variables (bound in the environment) +-- - non-pointer variables (bound in the environment) +-- - free slots (recorded in the stack free list) +-- - non-pointer data slots (recorded in the stack free list) -- -- The first two are represented with a 'Just' of a 'LocalReg'. -- The last two with one or more 'Nothing' constructors. @@ -332,7 +325,7 @@ mkLivenessBits dflags liveness | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word = do { uniq <- getUniqueUs ; let bitmap_lbl = mkBitmapLabel uniq - ; return (CmmLabel bitmap_lbl, + ; return (CmmLabel bitmap_lbl, [mkRODataLits bitmap_lbl lits]) } | otherwise -- Fits in one word @@ -343,10 +336,10 @@ mkLivenessBits dflags liveness bitmap :: Bitmap bitmap = mkBitmap dflags liveness - small_bitmap = case bitmap of + small_bitmap = case bitmap of [] -> toStgWord dflags 0 [b] -> b - _ -> panic "mkLiveness" + _ -> panic "mkLiveness" bitmap_word = toStgWord dflags (fromIntegral n_bits) .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags) @@ -357,7 +350,7 @@ mkLivenessBits dflags liveness ------------------------------------------------------------------------- -- --- Generating a standard info table +-- Generating a standard info table -- ------------------------------------------------------------------------- @@ -370,23 +363,23 @@ mkLivenessBits dflags liveness mkStdInfoTable :: DynFlags - -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling) + -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling) -> Int -- Closure RTS tag -> StgHalfWord -- SRT length - -> CmmLit -- layout field + -> CmmLit -- layout field -> [CmmLit] mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit - = -- Parallel revertible-black hole field + = -- Parallel revertible-black hole field prof_info - -- Ticky info (none at present) - -- Debug info (none at present) + -- Ticky info (none at present) + -- Debug info (none at present) ++ [layout_lit, type_lit] - where - prof_info - | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr] - | otherwise = [] + where + prof_info + | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr] + | otherwise = [] type_lit = packHalfWordsCLit dflags (toStgHalfWord dflags (fromIntegral cl_type)) srt_len @@ -417,7 +410,7 @@ srtEscape dflags = toStgHalfWord dflags (-1) ------------------------------------------------------------------------- -- --- Accessing fields of an info table +-- Accessing fields of an info table -- ------------------------------------------------------------------------- @@ -492,7 +485,7 @@ funInfoTable dflags info_ptr = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags) | otherwise = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags) - -- Past the entry code pointer + -- Past the entry code pointer -- Takes the info pointer of a function, returns the function's arity funInfoArity :: DynFlags -> CmmExpr -> CmmExpr @@ -515,7 +508,7 @@ funInfoArity dflags iptr -- Info table sizes & offsets -- ----------------------------------------------------------------------------- - + stdInfoTableSizeW :: DynFlags -> WordOff -- The size of a standard info table varies with profiling/ticky etc, -- so we can't get it from Constants @@ -547,15 +540,14 @@ stdInfoTableSizeB :: DynFlags -> ByteOff stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags stdSrtBitmapOffset :: DynFlags -> ByteOff --- Byte offset of the SRT bitmap half-word which is +-- Byte offset of the SRT bitmap half-word which is -- in the *higher-addressed* part of the type_lit stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags stdClosureTypeOffset :: DynFlags -> ByteOff --- Byte offset of the closure type half-word +-- Byte offset of the closure type half-word stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags - diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index db22deb639..c582b783f2 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -870,7 +870,7 @@ areaToSp _ _ _ _ other = other -- really the job of the stack layout algorithm, hence we do it now. optStackCheck :: CmmNode O C -> CmmNode O C -optStackCheck n = -- Note [null stack check] +optStackCheck n = -- Note [Always false stack check] case n of CmmCondBranch (CmmLit (CmmInt 0 _)) _true false -> CmmBranch false other -> other diff --git a/compiler/cmm/CmmLex.x b/compiler/cmm/CmmLex.x index bb5b4e3ae5..f56db7bd4c 100644 --- a/compiler/cmm/CmmLex.x +++ b/compiler/cmm/CmmLex.x @@ -44,7 +44,7 @@ $white_no_nl = $whitechar # \n $ascdigit = 0-9 $unidigit = \x01 -- Trick Alex into handling Unicode. See alexGetChar. $digit = [$ascdigit $unidigit] -$octit = 0-7 +$octit = 0-7 $hexit = [$digit A-F a-f] $unilarge = \x03 -- Trick Alex into handling Unicode. See alexGetChar. @@ -70,56 +70,56 @@ $namechar = [$namebegin $digit] cmm :- -$white_no_nl+ ; +$white_no_nl+ ; ^\# pragma .* \n ; -- Apple GCC 3.3 CPP generates pragmas in its output -^\# (line)? { begin line_prag } +^\# (line)? { begin line_prag } -- single-line line pragmas, of the form -- # <line> "<file>" <extra-stuff> \n -<line_prag> $digit+ { setLine line_prag1 } -<line_prag1> \" [^\"]* \" { setFile line_prag2 } -<line_prag2> .* { pop } +<line_prag> $digit+ { setLine line_prag1 } +<line_prag1> \" [^\"]* \" { setFile line_prag2 } +<line_prag2> .* { pop } <0> { - \n ; - - [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!] { special_char } - - ".." { kw CmmT_DotDot } - "::" { kw CmmT_DoubleColon } - ">>" { kw CmmT_Shr } - "<<" { kw CmmT_Shl } - ">=" { kw CmmT_Ge } - "<=" { kw CmmT_Le } - "==" { kw CmmT_Eq } - "!=" { kw CmmT_Ne } - "&&" { kw CmmT_BoolAnd } - "||" { kw CmmT_BoolOr } - - P@decimal { global_regN (\n -> VanillaReg n VGcPtr) } - R@decimal { global_regN (\n -> VanillaReg n VNonGcPtr) } - F@decimal { global_regN FloatReg } - D@decimal { global_regN DoubleReg } - L@decimal { global_regN LongReg } - Sp { global_reg Sp } - SpLim { global_reg SpLim } - Hp { global_reg Hp } - HpLim { global_reg HpLim } + \n ; + + [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!] { special_char } + + ".." { kw CmmT_DotDot } + "::" { kw CmmT_DoubleColon } + ">>" { kw CmmT_Shr } + "<<" { kw CmmT_Shl } + ">=" { kw CmmT_Ge } + "<=" { kw CmmT_Le } + "==" { kw CmmT_Eq } + "!=" { kw CmmT_Ne } + "&&" { kw CmmT_BoolAnd } + "||" { kw CmmT_BoolOr } + + P@decimal { global_regN (\n -> VanillaReg n VGcPtr) } + R@decimal { global_regN (\n -> VanillaReg n VNonGcPtr) } + F@decimal { global_regN FloatReg } + D@decimal { global_regN DoubleReg } + L@decimal { global_regN LongReg } + Sp { global_reg Sp } + SpLim { global_reg SpLim } + Hp { global_reg Hp } + HpLim { global_reg HpLim } CCCS { global_reg CCCS } CurrentTSO { global_reg CurrentTSO } CurrentNursery { global_reg CurrentNursery } - HpAlloc { global_reg HpAlloc } - BaseReg { global_reg BaseReg } - - $namebegin $namechar* { name } - - 0 @octal { tok_octal } - @decimal { tok_decimal } - 0[xX] @hexadecimal { tok_hexadecimal } - @floating_point { strtoken tok_float } - - \" @strchar* \" { strtoken tok_string } + HpAlloc { global_reg HpAlloc } + BaseReg { global_reg BaseReg } + + $namebegin $namechar* { name } + + 0 @octal { tok_octal } + @decimal { tok_decimal } + 0[xX] @hexadecimal { tok_hexadecimal } + @floating_point { strtoken tok_float } + + \" @strchar* \" { strtoken tok_string } } { @@ -171,9 +171,9 @@ data CmmToken | CmmT_float64 | CmmT_gcptr | CmmT_GlobalReg GlobalReg - | CmmT_Name FastString - | CmmT_String String - | CmmT_Int Integer + | CmmT_Name FastString + | CmmT_String String + | CmmT_Int Integer | CmmT_Float Rational | CmmT_EOF deriving (Show) @@ -196,88 +196,88 @@ kw :: CmmToken -> Action kw tok span buf len = return (L span tok) global_regN :: (Int -> GlobalReg) -> Action -global_regN con span buf len +global_regN con span buf len = return (L span (CmmT_GlobalReg (con (fromIntegral n)))) where buf' = stepOn buf - n = parseUnsignedInteger buf' (len-1) 10 octDecDigit + n = parseUnsignedInteger buf' (len-1) 10 octDecDigit global_reg :: GlobalReg -> Action global_reg r span buf len = return (L span (CmmT_GlobalReg r)) strtoken :: (String -> CmmToken) -> Action -strtoken f span buf len = +strtoken f span buf len = return (L span $! (f $! lexemeToString buf len)) name :: Action -name span buf len = +name span buf len = case lookupUFM reservedWordsFM fs of - Just tok -> return (L span tok) - Nothing -> return (L span (CmmT_Name fs)) + Just tok -> return (L span tok) + Nothing -> return (L span (CmmT_Name fs)) where - fs = lexemeToFastString buf len + fs = lexemeToFastString buf len reservedWordsFM = listToUFM $ - map (\(x, y) -> (mkFastString x, y)) [ - ( "CLOSURE", CmmT_CLOSURE ), - ( "INFO_TABLE", CmmT_INFO_TABLE ), - ( "INFO_TABLE_RET", CmmT_INFO_TABLE_RET ), - ( "INFO_TABLE_FUN", CmmT_INFO_TABLE_FUN ), - ( "INFO_TABLE_CONSTR", CmmT_INFO_TABLE_CONSTR ), - ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ), - ( "else", CmmT_else ), - ( "export", CmmT_export ), - ( "section", CmmT_section ), - ( "align", CmmT_align ), - ( "goto", CmmT_goto ), - ( "if", CmmT_if ), + map (\(x, y) -> (mkFastString x, y)) [ + ( "CLOSURE", CmmT_CLOSURE ), + ( "INFO_TABLE", CmmT_INFO_TABLE ), + ( "INFO_TABLE_RET", CmmT_INFO_TABLE_RET ), + ( "INFO_TABLE_FUN", CmmT_INFO_TABLE_FUN ), + ( "INFO_TABLE_CONSTR", CmmT_INFO_TABLE_CONSTR ), + ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ), + ( "else", CmmT_else ), + ( "export", CmmT_export ), + ( "section", CmmT_section ), + ( "align", CmmT_align ), + ( "goto", CmmT_goto ), + ( "if", CmmT_if ), ( "call", CmmT_call ), ( "jump", CmmT_jump ), ( "foreign", CmmT_foreign ), - ( "never", CmmT_never ), - ( "prim", CmmT_prim ), + ( "never", CmmT_never ), + ( "prim", CmmT_prim ), ( "reserve", CmmT_reserve ), ( "return", CmmT_return ), - ( "returns", CmmT_returns ), - ( "import", CmmT_import ), - ( "switch", CmmT_switch ), - ( "case", CmmT_case ), + ( "returns", CmmT_returns ), + ( "import", CmmT_import ), + ( "switch", CmmT_switch ), + ( "case", CmmT_case ), ( "default", CmmT_default ), ( "push", CmmT_push ), ( "bits8", CmmT_bits8 ), - ( "bits16", CmmT_bits16 ), - ( "bits32", CmmT_bits32 ), - ( "bits64", CmmT_bits64 ), - ( "bits128", CmmT_bits128 ), - ( "bits256", CmmT_bits256 ), - ( "bits512", CmmT_bits512 ), - ( "float32", CmmT_float32 ), - ( "float64", CmmT_float64 ), + ( "bits16", CmmT_bits16 ), + ( "bits32", CmmT_bits32 ), + ( "bits64", CmmT_bits64 ), + ( "bits128", CmmT_bits128 ), + ( "bits256", CmmT_bits256 ), + ( "bits512", CmmT_bits512 ), + ( "float32", CmmT_float32 ), + ( "float64", CmmT_float64 ), -- New forms - ( "b8", CmmT_bits8 ), - ( "b16", CmmT_bits16 ), - ( "b32", CmmT_bits32 ), - ( "b64", CmmT_bits64 ), - ( "b128", CmmT_bits128 ), - ( "b256", CmmT_bits256 ), - ( "b512", CmmT_bits512 ), - ( "f32", CmmT_float32 ), - ( "f64", CmmT_float64 ), - ( "gcptr", CmmT_gcptr ) - ] - -tok_decimal span buf len + ( "b8", CmmT_bits8 ), + ( "b16", CmmT_bits16 ), + ( "b32", CmmT_bits32 ), + ( "b64", CmmT_bits64 ), + ( "b128", CmmT_bits128 ), + ( "b256", CmmT_bits256 ), + ( "b512", CmmT_bits512 ), + ( "f32", CmmT_float32 ), + ( "f64", CmmT_float64 ), + ( "gcptr", CmmT_gcptr ) + ] + +tok_decimal span buf len = return (L span (CmmT_Int $! parseUnsignedInteger buf len 10 octDecDigit)) -tok_octal span buf len +tok_octal span buf len = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit)) -tok_hexadecimal span buf len +tok_hexadecimal span buf len = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit)) tok_float str = CmmT_Float $! readRational str tok_string str = CmmT_String (read str) - -- urk, not quite right, but it'll do for now + -- urk, not quite right, but it'll do for now -- ----------------------------------------------------------------------------- -- Line pragmas @@ -286,7 +286,7 @@ setLine :: Int -> Action setLine code span buf len = do let line = parseUnsignedInteger buf len 10 octDecDigit setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) - -- subtract one: the line number refers to the *following* line + -- subtract one: the line number refers to the *following* line -- trace ("setLine " ++ show line) $ do popLexState pushLexState code @@ -316,17 +316,17 @@ lexToken = do sc <- getLexState case alexScan inp sc of AlexEOF -> do let span = mkRealSrcSpan loc1 loc1 - setLastToken span 0 - return (L span CmmT_EOF) + setLastToken span 0 + return (L span CmmT_EOF) AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error" AlexSkip inp2 _ -> do - setInput inp2 - lexToken + setInput inp2 + lexToken AlexToken inp2@(end,buf2) len t -> do - setInput inp2 - let span = mkRealSrcSpan loc1 end - span `seq` setLastToken span len - t span buf len + setInput inp2 + let span = mkRealSrcSpan loc1 end + span `seq` setLastToken span len + t span buf len -- ----------------------------------------------------------------------------- -- Monad stuff @@ -351,7 +351,7 @@ alexGetByte (loc,s) where c = currentChar s b = fromIntegral $ ord $ c loc' = advanceSrcLoc loc c - s' = stepOn s + s' = stepOn s getInput :: P AlexInput getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (l,b) diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index c4ec393ad6..d8ce492de1 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -19,6 +19,9 @@ module CmmMachOp -- CallishMachOp , CallishMachOp(..), callishMachOpHints , pprCallishMachOp + + -- Atomic read-modify-write + , AtomicMachOp(..) ) where @@ -547,8 +550,24 @@ data CallishMachOp | MO_PopCnt Width | MO_BSwap Width + + -- Atomic read-modify-write. + | MO_AtomicRMW Width AtomicMachOp + | MO_AtomicRead Width + | MO_AtomicWrite Width + | MO_Cmpxchg Width deriving (Eq, Show) +-- | The operation to perform atomically. +data AtomicMachOp = + AMO_Add + | AMO_Sub + | AMO_And + | AMO_Nand + | AMO_Or + | AMO_Xor + deriving (Eq, Show) + pprCallishMachOp :: CallishMachOp -> SDoc pprCallishMachOp mo = text (show mo) diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 49143170c3..803333001c 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -573,7 +573,7 @@ importName -- A label imported with an explicit packageId. | STRING NAME - { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) } + { ($2, mkCmmCodeLabel (fsToPackageKey (mkFastString $1)) $2) } names :: { [FastString] } @@ -1101,7 +1101,7 @@ profilingInfo dflags desc_str ty_str else ProfilingInfo (stringToWord8s desc_str) (stringToWord8s ty_str) -staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> CmmParse () +staticClosure :: PackageKey -> FastString -> FastString -> [CmmLit] -> CmmParse () staticClosure pkg cl_label info payload = do dflags <- getDynFlags let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 4314695201..af4f62a4a8 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -326,10 +326,9 @@ _GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via. {- Note [unreachable blocks] The control-flow optimiser sometimes leaves unreachable blocks behind -containing junk code. If these blocks make it into the native code -generator then they trigger a register allocator panic because they -refer to undefined LocalRegs, so we must eliminate any unreachable -blocks before passing the code onwards. +containing junk code. These aren't necessarily a problem, but +removing them is good because it might save time in the native code +generator later. -} diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs index 4c025425ab..4dced9afd2 100644 --- a/compiler/cmm/CmmSink.hs +++ b/compiler/cmm/CmmSink.hs @@ -650,6 +650,10 @@ data AbsMem -- perhaps we ought to have a special annotation for calls that can -- modify heap/stack memory. For now we just use the conservative -- definition here. +-- +-- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and +-- therefore we should never float any memory operations across one of +-- these calls. bothMems :: AbsMem -> AbsMem -> AbsMem diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 47b247e278..455c79ba02 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -753,6 +753,10 @@ pprCallishMachOp_for_C mop MO_Memmove -> ptext (sLit "memmove") (MO_BSwap w) -> ptext (sLit $ bSwapLabel w) (MO_PopCnt w) -> ptext (sLit $ popCntLabel w) + (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop) + (MO_Cmpxchg w) -> ptext (sLit $ cmpxchgLabel w) + (MO_AtomicRead w) -> ptext (sLit $ atomicReadLabel w) + (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w) (MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w) MO_S_QuotRem {} -> unsupported diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index b5beb07ae9..cc3124028a 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -138,6 +138,9 @@ pprCmmGraph g $$ nest 2 (vcat $ map ppr blocks) $$ text "}" where blocks = postorderDfs g + -- postorderDfs has the side-effect of discarding unreachable code, + -- so pretty-printed Cmm will omit any unreachable blocks. This can + -- sometimes be confusing. --------------------------------------------- -- Outputting CmmNode and types which it contains diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 1a69927b5c..edd064848f 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -190,7 +190,7 @@ buildDynCon' dflags platform binder _ _cc con [arg] , StgLitArg (MachInt val) <- arg , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer! , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto... - = do { let intlike_lbl = mkCmmClosureLabel rtsPackageId (fsLit "stg_INTLIKE") + = do { let intlike_lbl = mkCmmClosureLabel rtsPackageKey (fsLit "stg_INTLIKE") val_int = fromIntegral val :: Int offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1) -- INTLIKE closures consist of a header and one word payload @@ -205,7 +205,7 @@ buildDynCon' dflags platform binder _ _cc con [arg] , let val_int = ord val :: Int , val_int <= mAX_CHARLIKE dflags , val_int >= mIN_CHARLIKE dflags - = do { let charlike_lbl = mkCmmClosureLabel rtsPackageId (fsLit "stg_CHARLIKE") + = do { let charlike_lbl = mkCmmClosureLabel rtsPackageKey (fsLit "stg_CHARLIKE") offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1) -- CHARLIKE closures consist of a header and one word payload charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs index df1733978f..5f412b3cf8 100644 --- a/compiler/codeGen/StgCmmExtCode.hs +++ b/compiler/codeGen/StgCmmExtCode.hs @@ -57,7 +57,7 @@ data Named = VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type, -- eg, RtsLabel, ForeignLabel, CmmLabel etc. - | FunN PackageId -- ^ A function name from this package + | FunN PackageKey -- ^ A function name from this package | LabelN BlockId -- ^ A blockid of some code or data. -- | An environment of named things. @@ -153,7 +153,7 @@ newBlockId = code F.newLabelC -- | Add add a local function to the environment. newFunctionName :: FastString -- ^ name of the function - -> PackageId -- ^ package of the current module + -> PackageKey -- ^ package of the current module -> ExtCode newFunctionName name pkg = addDecl name (FunN pkg) @@ -193,7 +193,7 @@ lookupName name = do case lookupUFM env name of Just (VarN e) -> e Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name)) - _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name)) + _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey name)) -- | Lift an FCode computation into the CmmParse monad diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index d00dc6ec84..7ac2c7a0bd 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -516,7 +516,7 @@ generic_gc = mkGcLabel "stg_gc_noregs" -- | Create a CLabel for calling a garbage collector entry point mkGcLabel :: String -> CmmExpr -mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit s))) +mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit s))) ------------------------------- heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 99e926c987..d62101f27e 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -359,10 +359,10 @@ slowArgs dflags args -- careful: reps contains voids (V), but args does not (arg_pat, n) = slowCallPattern (map fst args) (call_args, rest_args) = splitAt n args - stg_ap_pat = mkCmmRetInfoLabel rtsPackageId arg_pat + stg_ap_pat = mkCmmRetInfoLabel rtsPackageKey arg_pat this_pat = (N, Just (mkLblExpr stg_ap_pat)) : call_args save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just curCCS)] - save_cccs_lbl = mkCmmRetInfoLabel rtsPackageId (fsLit "stg_restore_cccs") + save_cccs_lbl = mkCmmRetInfoLabel rtsPackageKey (fsLit "stg_restore_cccs") ------------------------------------------------------------------------- ---- Laying out objects on the heap and stack diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index cad261bcfb..22c89d7e05 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -494,7 +494,7 @@ withSelfLoop self_loop code = do instance HasDynFlags FCode where getDynFlags = liftM cgd_dflags getInfoDown -getThisPackage :: FCode PackageId +getThisPackage :: FCode PackageKey getThisPackage = liftM thisPackage getDynFlags withInfoDown :: FCode a -> CgInfoDownwards -> FCode a diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 40a5e3649b..e4c682bf02 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -769,6 +769,25 @@ emitPrimOp _ res PrefetchByteArrayOp0 args = doPrefetchByteArrayOp 0 res emitPrimOp _ res PrefetchMutableByteArrayOp0 args = doPrefetchByteArrayOp 0 res args emitPrimOp _ res PrefetchAddrOp0 args = doPrefetchAddrOp 0 res args +-- Atomic read-modify-write +emitPrimOp dflags [res] FetchAddByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Add mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchSubByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Sub mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchAndByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_And mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchNandByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Nand mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchOrByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Or mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchXorByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Xor mba ix (bWord dflags) n +emitPrimOp dflags [res] AtomicReadByteArrayOp_Int [mba, ix] = + doAtomicReadByteArray res mba ix (bWord dflags) +emitPrimOp dflags [] AtomicWriteByteArrayOp_Int [mba, ix, val] = + doAtomicWriteByteArray mba ix (bWord dflags) val +emitPrimOp dflags [res] CasByteArrayOp_Int [mba, ix, old, new] = + doCasByteArray res mba ix (bWord dflags) old new -- The rest just translate straightforwardly emitPrimOp dflags [res] op [arg] @@ -1933,6 +1952,81 @@ doWriteSmallPtrArrayOp addr idx val = do emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) ------------------------------------------------------------------------------ +-- Atomic read-modify-write + +-- | Emit an atomic modification to a byte array element. The result +-- reg contains that previous value of the element. Implies a full +-- memory barrier. +doAtomicRMW :: LocalReg -- ^ Result reg + -> AtomicMachOp -- ^ Atomic op (e.g. add) + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Op argument (e.g. amount to add) + -> FCode () +doAtomicRMW res amop mba idx idx_ty n = do + dflags <- getDynFlags + let width = typeWidth idx_ty + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ res ] + (MO_AtomicRMW width amop) + [ addr, n ] + +-- | Emit an atomic read to a byte array that acts as a memory barrier. +doAtomicReadByteArray + :: LocalReg -- ^ Result reg + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> FCode () +doAtomicReadByteArray res mba idx idx_ty = do + dflags <- getDynFlags + let width = typeWidth idx_ty + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ res ] + (MO_AtomicRead width) + [ addr ] + +-- | Emit an atomic write to a byte array that acts as a memory barrier. +doAtomicWriteByteArray + :: CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Value to write + -> FCode () +doAtomicWriteByteArray mba idx idx_ty val = do + dflags <- getDynFlags + let width = typeWidth idx_ty + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ {- no results -} ] + (MO_AtomicWrite width) + [ addr, val ] + +doCasByteArray + :: LocalReg -- ^ Result reg + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Old value + -> CmmExpr -- ^ New value + -> FCode () +doCasByteArray res mba idx idx_ty old new = do + dflags <- getDynFlags + let width = (typeWidth idx_ty) + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ res ] + (MO_Cmpxchg width) + [ addr, old, new ] + +------------------------------------------------------------------------------ -- Helpers for emitting function calls -- | Emit a call to @memcpy@. diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index 1aa08a1e58..7249477c9f 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -183,7 +183,7 @@ enterCostCentreFun ccs closure = ifProfiling $ do if isCurrentCCS ccs then do dflags <- getDynFlags - emitRtsCall rtsPackageId (fsLit "enterFunCCS") + emitRtsCall rtsPackageKey (fsLit "enterFunCCS") [(CmmReg (CmmGlobal BaseReg), AddrHint), (costCentreFrom dflags closure, AddrHint)] False else return () -- top-level function, nothing to do @@ -285,7 +285,7 @@ emitSetCCC cc tick push pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc = emitRtsCallWithResult result AddrHint - rtsPackageId + rtsPackageKey (fsLit "pushCostCentre") [(ccs,AddrHint), (CmmLit (mkCCostCentre cc), AddrHint)] False @@ -356,7 +356,7 @@ ldvEnter cl_ptr = do loadEra :: DynFlags -> CmmExpr loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags)) - [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) + [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageKey (fsLit "era"))) (cInt dflags)] ldvWord :: DynFlags -> CmmExpr -> CmmExpr diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index 6913c9ec15..3652a79979 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -327,7 +327,7 @@ registerTickyCtr ctr_lbl = do , mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_registeredp dflags))) (mkIntExpr dflags 1) ] - ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) + ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageKey (fsLit "ticky_entry_ctrs")) emit =<< mkCmmIfThen test (catAGraphs register_stmts) tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode () @@ -472,12 +472,12 @@ tickyAllocHeap genuine hp bytes, -- Bump the global allocation total ALLOC_HEAP_tot addToMemLbl (cLong dflags) - (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_tot")) + (mkCmmDataLabel rtsPackageKey (fsLit "ALLOC_HEAP_tot")) bytes, -- Bump the global allocation counter ALLOC_HEAP_ctr if not genuine then mkNop else addToMemLbl (cLong dflags) - (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_ctr")) + (mkCmmDataLabel rtsPackageKey (fsLit "ALLOC_HEAP_ctr")) 1 ]} @@ -541,13 +541,13 @@ ifTickyDynThunk :: FCode () -> FCode () ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code bumpTickyCounter :: FastString -> FCode () -bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsPackageId lbl) +bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsPackageKey lbl) bumpTickyCounterBy :: FastString -> Int -> FCode () -bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsPackageId lbl) +bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsPackageKey lbl) bumpTickyCounterByE :: FastString -> CmmExpr -> FCode () -bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsPackageId lbl) +bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsPackageKey lbl) bumpTickyEntryCount :: CLabel -> FCode () bumpTickyEntryCount lbl = do diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index bc1a15fe3c..985c6db900 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -175,10 +175,10 @@ tagToClosure dflags tycon tag -- ------------------------------------------------------------------------- -emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () +emitRtsCall :: PackageKey -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe -emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString +emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageKey -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCallWithResult res hint pkg fun args safe = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index a5868108d9..f4607823a8 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -207,7 +207,8 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) ; binder_ty <- applySubstTy binder_ty ; checkTys binder_ty ty (mkRhsMsg binder (ptext (sLit "RHS")) ty) - -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples) + -- Check the let/app invariant + -- See Note [CoreSyn let/app invariant] in CoreSyn ; checkL (not (isUnLiftedType binder_ty) || (isNonRec rec_flag && exprOkForSpeculation rhs)) (mkRhsPrimMsg binder rhs) @@ -220,6 +221,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) -- 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) @@ -451,6 +453,8 @@ lintCoreArg fun_ty (Type arg_ty) lintCoreArg fun_ty arg = do { arg_ty <- lintCoreExpr arg + ; checkL (not (isUnLiftedType arg_ty) || exprOkForSpeculation arg) + (mkLetAppMsg arg) ; lintValApp arg fun_ty arg_ty } ----------------- @@ -1391,6 +1395,11 @@ mkRhsMsg binder what ty hsep [ptext (sLit "Binder's type:"), ppr (idType binder)], hsep [ptext (sLit "Rhs type:"), ppr ty]] +mkLetAppMsg :: CoreExpr -> MsgDoc +mkLetAppMsg e + = hang (ptext (sLit "This argument does not satisfy the let/app invariant:")) + 2 (ppr e) + mkRhsPrimMsg :: Id -> CoreExpr -> MsgDoc mkRhsPrimMsg binder _rhs = vcat [hsep [ptext (sLit "The type of this binder is primitive:"), diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index c754aae4e7..bbf104b127 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -1115,9 +1115,9 @@ data CorePrepEnv = CPE { lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id lookupMkIntegerName dflags hsc_env - = if thisPackage dflags == primPackageId + = if thisPackage dflags == primPackageKey then return $ panic "Can't use Integer in ghc-prim" - else if thisPackage dflags == integerPackageId + else if thisPackage dflags == integerPackageKey then return $ panic "Can't use Integer in integer" else liftM tyThingId $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName) diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index b36cb6d8a6..12a60daddd 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -180,25 +180,8 @@ These data types are the heart of the compiler -- /must/ be of lifted type (see "Type#type_classification" for -- the meaning of /lifted/ vs. /unlifted/). -- --- #let_app_invariant# --- The right hand side of of a non-recursive 'Let' --- _and_ the argument of an 'App', --- /may/ be of unlifted type, but only if the expression --- is ok-for-speculation. This means that the let can be floated --- around without difficulty. For example, this is OK: --- --- > y::Int# = x +# 1# --- --- But this is not, as it may affect termination if the --- expression is floated out: --- --- > y::Int# = fac 4# --- --- In this situation you should use @case@ rather than a @let@. The function --- 'CoreUtils.needsCaseBinding' can help you determine which to generate, or --- alternatively use 'MkCore.mkCoreLet' rather than this constructor directly, --- which will generate a @case@ if necessary --- +-- See Note [CoreSyn let/app invariant] +-- -- #type_let# -- We allow a /non-recursive/ let to bind a type variable, thus: -- @@ -359,9 +342,28 @@ See #letrec_invariant# Note [CoreSyn let/app invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #let_app_invariant# +The let/app invariant + the right hand side of of a non-recursive 'Let', and + the argument of an 'App', + /may/ be of unlifted type, but only if + the expression is ok-for-speculation. + +This means that the let can be floated around +without difficulty. For example, this is OK: + + y::Int# = x +# 1# + +But this is not, as it may affect termination if the +expression is floated out: + + y::Int# = fac 4# + +In this situation you should use @case@ rather than a @let@. The function +'CoreUtils.needsCaseBinding' can help you determine which to generate, or +alternatively use 'MkCore.mkCoreLet' rather than this constructor directly, +which will generate a @case@ if necessary -This is intially enforced by DsUtils.mkCoreLet and mkCoreApp +Th let/app invariant is initially enforced by DsUtils.mkCoreLet and mkCoreApp Note [CoreSyn case invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1215,8 +1217,9 @@ mkDoubleLitDouble :: Double -> Expr b mkDoubleLit d = Lit (mkMachDouble d) mkDoubleLitDouble d = Lit (mkMachDouble (toRational d)) --- | Bind all supplied binding groups over an expression in a nested let expression. Prefer to --- use 'MkCore.mkCoreLets' if possible +-- | Bind all supplied binding groups over an expression in a nested let expression. Assumes +-- that the rhs satisfies the let/app invariant. Prefer to use 'MkCore.mkCoreLets' if +-- possible, which does guarantee the invariant mkLets :: [Bind b] -> Expr b -> Expr b -- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to -- use 'MkCore.mkCoreLams' if possible diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 3bf07febf3..baf7e4fa80 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -908,13 +908,22 @@ it's applied only to dictionaries. -- Note [exprOkForSpeculation: case expressions] below -- -- Precisely, it returns @True@ iff: +-- a) The expression guarantees to terminate, +-- b) soon, +-- c) without causing a write side effect (e.g. writing a mutable variable) +-- d) without throwing a Haskell exception +-- e) without risking an unchecked runtime exception (array out of bounds, +-- divide by zero) -- --- * The expression guarantees to terminate, --- * soon, --- * without raising an exception, --- * without causing a side effect (e.g. writing a mutable variable) +-- For @exprOkForSideEffects@ the list is the same, but omitting (e). +-- +-- Note that +-- exprIsHNF implies exprOkForSpeculation +-- exprOkForSpeculation implies exprOkForSideEffects +-- +-- See Note [PrimOp can_fail and has_side_effects] in PrimOp +-- and Note [Implementation: how can_fail/has_side_effects affect transformations] -- --- Note that if @exprIsHNF e@, then @exprOkForSpecuation e@. -- As an example of the considerations in this test, consider: -- -- > let x = case y# +# 1# of { r# -> I# r# } @@ -964,7 +973,7 @@ app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool app_ok primop_ok fun args = case idDetails fun of DFunId _ new_type -> not new_type - -- DFuns terminate, unless the dict is implemented + -- DFuns terminate, unless the dict is implemented -- with a newtype in which case they may not DataConWorkId {} -> True @@ -983,14 +992,12 @@ app_ok primop_ok fun args -> True | otherwise - -> primop_ok op -- A bit conservative: we don't really need - && all (expr_ok primop_ok) args - - -- to care about lazy arguments, but this is easy + -> primop_ok op -- A bit conservative: we don't really need + && all (expr_ok primop_ok) args -- to care about lazy arguments, but this is easy _other -> isUnLiftedType (idType fun) -- c.f. the Var case of exprIsHNF || idArity fun > n_val_args -- Partial apps - || (n_val_args == 0 && + || (n_val_args == 0 && isEvaldUnfolding (idUnfolding fun)) -- Let-bound values where n_val_args = valArgCount args diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index 721dc968fc..3ba8b1d6ee 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -304,9 +304,9 @@ mkStringExprFS str mkEqBox :: Coercion -> CoreExpr mkEqBox co = ASSERT2( typeKind ty2 `eqKind` k, ppr co $$ ppr ty1 $$ ppr ty2 $$ ppr (typeKind ty1) $$ ppr (typeKind ty2) ) Var (dataConWorkId datacon) `mkTyApps` [k, ty1, ty2] `App` Coercion co - where Pair ty1 ty2 = coercionKind co + where (Pair ty1 ty2, role) = coercionKindRole co k = typeKind ty1 - datacon = case coercionRole co of + datacon = case role of Nominal -> eqBoxDataCon Representational -> coercibleDataCon Phantom -> pprPanic "mkEqBox does not support boxing phantom coercions" @@ -415,12 +415,17 @@ mkBigCoreTupTy = mkChunkified mkBoxedTupleTy %************************************************************************ \begin{code} -data FloatBind +data FloatBind = FloatLet CoreBind - | FloatCase CoreExpr Id AltCon [Var] + | FloatCase CoreExpr Id AltCon [Var] -- case e of y { C ys -> ... } -- See Note [Floating cases] in SetLevels +instance Outputable FloatBind where + ppr (FloatLet b) = ptext (sLit "LET") <+> ppr b + ppr (FloatCase e b c bs) = hang (ptext (sLit "CASE") <+> ppr e <+> ptext (sLit "of") <+> ppr b) + 2 (ppr c <+> ppr bs) + wrapFloat :: FloatBind -> CoreExpr -> CoreExpr wrapFloat (FloatLet defns) body = Let defns body wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)] diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index e646667651..fae5f36426 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -154,8 +154,8 @@ writeMixEntries dflags mod count entries filename mod_name = moduleNameString (moduleName mod) hpc_mod_dir - | modulePackageId mod == mainPackageId = hpc_dir - | otherwise = hpc_dir ++ "/" ++ packageIdString (modulePackageId mod) + | modulePackageKey mod == mainPackageKey = hpc_dir + | otherwise = hpc_dir ++ "/" ++ packageKeyString (modulePackageKey mod) tabStop = 8 -- <tab> counts as a normal char in GHC's location ranges. @@ -1233,9 +1233,9 @@ hpcInitCode this_mod (HpcInfo tickCount hashNo) module_name = hcat (map (text.charToC) $ bytesFS (moduleNameFS (Module.moduleName this_mod))) package_name = hcat (map (text.charToC) $ - bytesFS (packageIdFS (modulePackageId this_mod))) + bytesFS (packageKeyFS (modulePackageKey this_mod))) full_name_str - | modulePackageId this_mod == mainPackageId + | modulePackageKey this_mod == mainPackageKey = module_name | otherwise = package_name <> char '/' <> module_name diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 1bbcc05e40..35a2477fd5 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -466,8 +466,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd) left_con <- dsLookupDataCon leftDataConName right_con <- dsLookupDataCon rightDataConName - let mk_left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e] - mk_right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e] + let mk_left_expr ty1 ty2 e = mkCoreConApps left_con [Type ty1, Type ty2, e] + mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1, Type ty2, e] in_ty = envStackType env_ids stack_ty then_ty = envStackType then_ids stack_ty diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 9691b99975..172d19b9ac 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -35,6 +35,7 @@ import HsSyn -- lots of things import CoreSyn -- lots of things import Literal ( Literal(MachStr) ) import CoreSubst +import OccurAnal ( occurAnalyseExpr ) import MkCore import CoreUtils import CoreArity ( etaExpand ) @@ -454,7 +455,10 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) ; (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 { + ; -- pprTrace "dsRule" (vcat [ ptext (sLit "Id:") <+> ppr poly_id + -- , ptext (sLit "spec_co:") <+> ppr spec_co + -- , ptext (sLit "ds_rhs:") <+> ppr ds_lhs ]) $ + case decomposeRuleLhs bndrs ds_lhs of { Left msg -> do { warnDs msg; return Nothing } ; Right (rule_bndrs, _fn, args) -> do @@ -578,7 +582,7 @@ SPEC f :: ty [n] INLINE [k] decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr]) -- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE, -- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs --- may add some extra dictionary binders (see Note [Constant rule dicts]) +-- may add some extra dictionary binders (see Note [Free dictionaries]) -- -- Returns Nothing if the LHS isn't of the expected shape -- Note [Decomposing the left-hand side of a RULE] @@ -589,7 +593,13 @@ decomposeRuleLhs orig_bndrs orig_lhs | Var fn_var <- fun , not (fn_var `elemVarSet` orig_bndr_set) - = Right (bndrs1, fn_var, args) + = -- pprTrace "decmposeRuleLhs" (vcat [ ptext (sLit "orig_bndrs:") <+> ppr orig_bndrs + -- , ptext (sLit "orig_lhs:") <+> ppr orig_lhs + -- , ptext (sLit "lhs1:") <+> ppr lhs1 + -- , ptext (sLit "bndrs1:") <+> ppr bndrs1 + -- , ptext (sLit "fn_var:") <+> ppr fn_var + -- , ptext (sLit "args:") <+> ppr args]) $ + Right (bndrs1, fn_var, args) | Case scrut bndr ty [(DEFAULT, _, body)] <- fun , isDeadBinder bndr -- Note [Matching seqId] @@ -608,7 +618,7 @@ decomposeRuleLhs orig_bndrs orig_lhs orig_bndr_set = mkVarSet orig_bndrs - -- Add extra dict binders: Note [Constant rule dicts] + -- Add extra dict binders: Note [Free dictionaries] extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d) | d <- varSetElems (lhs_fvs `delVarSetList` orig_bndrs) , isDictId d ] @@ -618,19 +628,41 @@ decomposeRuleLhs orig_bndrs orig_lhs , text "Orig lhs:" <+> ppr orig_lhs]) dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr , ptext (sLit "is not bound in RULE lhs")]) - 2 (ppr lhs2) + 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs + , text "Orig lhs:" <+> ppr orig_lhs + , text "optimised lhs:" <+> ppr lhs2 ]) pp_bndr bndr | isTyVar bndr = ptext (sLit "type variable") <+> quotes (ppr bndr) | Just pred <- evVarPred_maybe bndr = ptext (sLit "constraint") <+> quotes (ppr pred) | otherwise = ptext (sLit "variable") <+> quotes (ppr bndr) drop_dicts :: CoreExpr -> CoreExpr - drop_dicts (Let (NonRec d rhs) body) - | isDictId d - , not (exprFreeVars rhs `intersectsVarSet` orig_bndr_set) - = drop_dicts body - drop_dicts (Let bnd body) = Let bnd (drop_dicts body) - drop_dicts body = body + drop_dicts e + = wrap_lets needed bnds body + where + needed = orig_bndr_set `minusVarSet` exprFreeVars body + (bnds, body) = split_lets (occurAnalyseExpr e) + -- The occurAnalyseExpr drops dead bindings which is + -- crucial to ensure that every binding is used later; + -- which in turn makes wrap_lets work right + + split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr) + split_lets e + | Let (NonRec d r) body <- e + , isDictId d + , (bs, body') <- split_lets body + = ((d,r):bs, body') + | otherwise + = ([], e) + + wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr + wrap_lets _ [] body = body + wrap_lets needed ((d, r) : bs) body + | rhs_fvs `intersectsVarSet` needed = Let (NonRec d r) (wrap_lets needed' bs body) + | otherwise = wrap_lets needed bs body + where + rhs_fvs = exprFreeVars r + needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d \end{code} Note [Decomposing the left-hand side of a RULE] @@ -638,7 +670,7 @@ Note [Decomposing the left-hand side of a RULE] There are several things going on here. * drop_dicts: see Note [Drop dictionary bindings on rule LHS] * simpleOptExpr: see Note [Simplify rule LHS] -* extra_dict_bndrs: see Note [Free rule dicts] +* extra_dict_bndrs: see Note [Free dictionaries] Note [Drop dictionary bindings on rule LHS] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -666,9 +698,36 @@ drop_dicts drops dictionary bindings on the LHS where possible. will be simple NonRec bindings. We don't handle recursive dictionaries! + NB3: In the common case of a non-overloaded, but perhpas-polymorphic + specialisation, we don't need to bind *any* dictionaries for use + in the RHS. For example (Trac #8331) + {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-} + useAbstractMonad :: MonadAbstractIOST m => m Int + Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code + but the RHS uses no dictionaries, so we want to end up with + RULE forall s (d :: MonadBstractIOST (ReaderT s)). + useAbstractMonad (ReaderT s) d = $suseAbstractMonad s + Trac #8848 is a good example of where there are some intersting dictionary bindings to discard. +The drop_dicts algorithm is based on these observations: + + * Given (let d = rhs in e) where d is a DictId, + matching 'e' will bind e's free variables. + + * So we want to keep the binding if one of the needed variables (for + which we need a binding) is in fv(rhs) but not already in fv(e). + + * The "needed variables" are simply the orig_bndrs. Consider + f :: (Eq a, Show b) => a -> b -> String + {-# SPECIALISE f :: (Show b) => Int -> b -> String + Then orig_bndrs includes the *quantified* dictionaries of the type + namely (dsb::Show b), but not the one for Eq Int + +So we work inside out, applying the above criterion at each step. + + Note [Simplify rule LHS] ~~~~~~~~~~~~~~~~~~~~~~~~ simplOptExpr occurrence-analyses and simplifies the LHS: diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index 217a4ce7c9..a47b9ea4dd 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -238,9 +238,9 @@ boxResult result_ty _ -> [] return_result state anss - = mkConApp (tupleCon UnboxedTuple (2 + length extra_result_tys)) - (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys) - ++ (state : anss)) + = mkCoreConApps (tupleCon UnboxedTuple (2 + length extra_result_tys)) + (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys) + ++ (state : anss)) ; (ccall_res_ty, the_alt) <- mk_alt return_result res diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 4eadef69b8..2a2d733995 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -292,9 +292,9 @@ dsExpr (ExplicitTuple tup_args boxity) ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args) -- The reverse is because foldM goes left-to-right - ; return $ mkCoreLams lam_vars $ - mkConApp (tupleCon (boxityNormalTupleSort boxity) (length tup_args)) - (map (Type . exprType) args ++ args) } + ; return $ mkCoreLams lam_vars $ + mkCoreConApps (tupleCon (boxityNormalTupleSort boxity) (length tup_args)) + (map (Type . exprType) args ++ args) } dsExpr (HsSCC cc expr@(L loc _)) = do mod_name <- getModule @@ -435,7 +435,7 @@ dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do then mapM unlabelled_bottom arg_tys else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels) - return (mkApps con_expr' con_args) + return (mkCoreApps con_expr' con_args) \end{code} Record update is a little harder. Suppose we have the decl: diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 0654ebc983..c60e9146bc 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -224,9 +224,9 @@ dsFCall fn_id co fcall mDeclHeader = do dflags <- getDynFlags (fcall', cDoc) <- case fcall of - CCall (CCallSpec (StaticTarget cName mPackageId isFun) CApiConv safety) -> + CCall (CCallSpec (StaticTarget cName mPackageKey isFun) CApiConv safety) -> do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName) - let fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId True) CApiConv safety) + let fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageKey True) CApiConv safety) c = includes $$ fun_proto <+> braces (cRet <> semi) includes = vcat [ text "#include <" <> ftext h <> text ">" diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 435f5c73a2..28e6feffec 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -396,10 +396,10 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) ; repTySynInst tc eqn1 } repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ) -repTyFamEqn (L loc (TyFamInstEqn { tfie_pats = HsWB { hswb_cts = tys - , hswb_kvs = kv_names - , hswb_tvs = tv_names } - , tfie_rhs = rhs })) +repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys + , hswb_kvs = kv_names + , hswb_tvs = tv_names } + , tfe_rhs = rhs })) = do { let hs_tvs = HsQTvs { hsq_kvs = kv_names , hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk ; addTyClTyVarBinds hs_tvs $ \ _ -> @@ -1416,7 +1416,7 @@ globalVar name where mod = ASSERT( isExternalName name) nameModule name name_mod = moduleNameString (moduleName mod) - name_pkg = packageIdString (modulePackageId mod) + name_pkg = packageKeyString (modulePackageKey mod) name_occ = nameOccName name mk_varg | OccName.isDataOcc name_occ = mkNameG_dName | OccName.isVarOcc name_occ = mkNameG_vName @@ -1476,7 +1476,7 @@ rep2 n xs = do { id <- dsLookupGlobalId n dataCon' :: Name -> [CoreExpr] -> DsM (Core a) dataCon' n args = do { id <- dsLookupDataCon n - ; return $ MkC $ mkConApp id args } + ; return $ MkC $ mkCoreConApps id args } dataCon :: Name -> DsM (Core a) dataCon n = dataCon' n [] @@ -2117,7 +2117,7 @@ thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib") qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote") mkTHModule :: FastString -> Module -mkTHModule m = mkModule thPackageId (mkModuleNameFS m) +mkTHModule m = mkModule thPackageKey (mkModuleNameFS m) libFun, libTc, thFun, thTc, thCon, qqFun :: FastString -> Unique -> Name libFun = mk_known_key_name OccName.varName thLib diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 350ed22d69..71a5e10636 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -92,7 +92,7 @@ dsLit (HsInt i) = do dflags <- getDynFlags dsLit (HsRat r ty) = do num <- mkIntegerExpr (numerator (fl_value r)) denom <- mkIntegerExpr (denominator (fl_value r)) - return (mkConApp ratio_data_con [Type integer_ty, num, denom]) + return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) where (ratio_data_con, integer_ty) = case tcSplitTyConApp ty of diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index e6f86c97d9..d449adac67 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -104,6 +104,13 @@ Library Include-Dirs: . parser utils + if impl( ghc >= 7.9 ) + -- We need to set the package key to ghc (without a version number) + -- as it's magic. But we can't set it for old versions of GHC (e.g. + -- when bootstrapping) because those versions of GHC don't understand + -- that GHC is wired-in. + GHC-Options: -this-package-key ghc + if flag(stage1) Include-Dirs: stage1 else diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 4977e28769..d23d1fe5b6 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -99,8 +99,6 @@ endif @echo 'cGhcEnableTablesNextToCode = "$(GhcEnableTablesNextToCode)"' >> $@ @echo 'cLeadingUnderscore :: String' >> $@ @echo 'cLeadingUnderscore = "$(LeadingUnderscore)"' >> $@ - @echo 'cRAWCPP_FLAGS :: String' >> $@ - @echo 'cRAWCPP_FLAGS = "$(RAWCPP_FLAGS)"' >> $@ @echo 'cGHC_UNLIT_PGM :: String' >> $@ @echo 'cGHC_UNLIT_PGM = "$(utils/unlit_dist_PROG)"' >> $@ @echo 'cGHC_SPLIT_PGM :: String' >> $@ @@ -439,8 +437,14 @@ ifeq "$(compiler_stage1_VERSION_MUNGED)" "YES" compiler_stage1_MUNGED_VERSION = $(subst .$(ProjectPatchLevel),,$(ProjectVersion)) define compiler_PACKAGE_MAGIC compiler_stage1_VERSION = $(compiler_stage1_MUNGED_VERSION) +compiler_stage1_PACKAGE_KEY = $(subst .$(ProjectPatchLevel),,$(compiler_stage1_PACKAGE_KEY)) endef +# NB: the PACKAGE_KEY munging has no effect for new-style package keys +# (which indeed, have nothing version like in them, but are important for +# old-style package keys which do.) The subst operation is idempotent, so +# as long as we do it at least once we should be good. + # Don't register the non-munged package compiler_stage1_REGISTER_PACKAGE = NO @@ -667,9 +671,9 @@ compiler_stage2_CONFIGURE_OPTS += --disable-library-for-ghci compiler_stage3_CONFIGURE_OPTS += --disable-library-for-ghci # after build-package, because that sets compiler_stage1_HC_OPTS: -compiler_stage1_HC_OPTS += $(GhcStage1HcOpts) -compiler_stage2_HC_OPTS += $(GhcStage2HcOpts) -compiler_stage3_HC_OPTS += $(GhcStage3HcOpts) +compiler_stage1_HC_OPTS += $(GhcHcOpts) $(GhcStage1HcOpts) +compiler_stage2_HC_OPTS += $(GhcHcOpts) $(GhcStage2HcOpts) +compiler_stage3_HC_OPTS += $(GhcHcOpts) $(GhcStage3HcOpts) ifneq "$(BINDIST)" "YES" diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index d4a58044f5..645a0d8118 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -6,13 +6,6 @@ ByteCodeGen: Generate bytecode from Core \begin{code} {-# LANGUAGE CPP, MagicHash #-} -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where #include "HsVersions.h" @@ -278,7 +271,7 @@ collect :: AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet) collect (_, e) = go [] e where go xs e | Just e' <- bcView e = go xs e' - go xs (AnnLam x (_,e)) + go xs (AnnLam x (_,e)) | UbxTupleRep _ <- repType (idType x) = unboxedTupleException | otherwise @@ -820,8 +813,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple MASSERT(isAlgCase) rhs_code <- schemeE (d_alts + size) s p' rhs return (my_discr alt, unitOL (UNPACK (trunc16 size)) `appOL` rhs_code) - where - real_bndrs = filterOut isTyVar bndrs + where + real_bndrs = filterOut isTyVar bndrs my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-} my_discr (DataAlt dc, _, _) @@ -1253,8 +1246,8 @@ pushAtom d p e | Just e' <- bcView e = pushAtom d p e' -pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things, - = return (nilOL, 0) -- treated just like a variable V +pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things, + = return (nilOL, 0) -- treated just like a variable V pushAtom d p (AnnVar v) | UnaryRep rep_ty <- repType (idType v) @@ -1564,12 +1557,12 @@ isVAtom :: AnnExpr' Var ann -> Bool isVAtom e | Just e' <- bcView e = isVAtom e' isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v) isVAtom (AnnCoercion {}) = True -isVAtom _ = False +isVAtom _ = False atomPrimRep :: AnnExpr' Id ann -> PrimRep atomPrimRep e | Just e' <- bcView e = atomPrimRep e' -atomPrimRep (AnnVar v) = bcIdPrimRep v -atomPrimRep (AnnLit l) = typePrimRep (literalType l) +atomPrimRep (AnnVar v) = bcIdPrimRep v +atomPrimRep (AnnLit l) = typePrimRep (literalType l) atomPrimRep (AnnCoercion {}) = VoidRep atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other))) diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs index 548c29f514..5535d58453 100644 --- a/compiler/ghci/ByteCodeInstr.lhs +++ b/compiler/ghci/ByteCodeInstr.lhs @@ -5,23 +5,15 @@ ByteCodeInstrs: Bytecode instruction definitions \begin{code} {-# LANGUAGE CPP, MagicHash #-} -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - {-# OPTIONS_GHC -funbox-strict-fields #-} - -module ByteCodeInstr ( - BCInstr(..), ProtoBCO(..), bciStackUse, BreakInfo (..) +module ByteCodeInstr ( + BCInstr(..), ProtoBCO(..), bciStackUse, BreakInfo (..) ) where #include "HsVersions.h" #include "../includes/MachDeps.h" -import ByteCodeItbls ( ItblPtr ) +import ByteCodeItbls ( ItblPtr ) import StgCmmLayout ( ArgRep(..) ) import PprCore @@ -44,17 +36,17 @@ import Data.Word -- ---------------------------------------------------------------------------- -- Bytecode instructions -data ProtoBCO a - = ProtoBCO { - protoBCOName :: a, -- name, in some sense - protoBCOInstrs :: [BCInstr], -- instrs - -- arity and GC info - protoBCOBitmap :: [StgWord], - protoBCOBitmapSize :: Word16, - protoBCOArity :: Int, - -- what the BCO came from - protoBCOExpr :: Either [AnnAlt Id VarSet] (AnnExpr Id VarSet), - -- malloc'd pointers +data ProtoBCO a + = ProtoBCO { + protoBCOName :: a, -- name, in some sense + protoBCOInstrs :: [BCInstr], -- instrs + -- arity and GC info + protoBCOBitmap :: [StgWord], + protoBCOBitmapSize :: Word16, + protoBCOArity :: Int, + -- what the BCO came from + protoBCOExpr :: Either [AnnAlt Id VarSet] (AnnExpr Id VarSet), + -- malloc'd pointers protoBCOPtrs :: [Either ItblPtr (Ptr ())] } @@ -80,14 +72,14 @@ data BCInstr -- Pushing literals | PUSH_UBX (Either Literal (Ptr ())) Word16 - -- push this int/float/double/addr, on the stack. Word16 - -- is # of words to copy from literal pool. Eitherness reflects - -- the difficulty of dealing with MachAddr here, mostly due to - -- the excessive (and unnecessary) restrictions imposed by the - -- designers of the new Foreign library. In particular it is - -- quite impossible to convert an Addr to any other integral - -- type, and it appears impossible to get hold of the bits of - -- an addr, even though we need to assemble BCOs. + -- push this int/float/double/addr, on the stack. Word16 + -- is # of words to copy from literal pool. Eitherness reflects + -- the difficulty of dealing with MachAddr here, mostly due to + -- the excessive (and unnecessary) restrictions imposed by the + -- designers of the new Foreign library. In particular it is + -- quite impossible to convert an Addr to any other integral + -- type, and it appears impossible to get hold of the bits of + -- an addr, even though we need to assemble BCOs. -- various kinds of application | PUSH_APPLY_N @@ -112,8 +104,8 @@ data BCInstr | MKPAP !Word16{-ptr to PAP is this far down stack-} !Word16{-number of words-} | UNPACK !Word16 -- unpack N words from t.o.s Constr | PACK DataCon !Word16 - -- after assembly, the DataCon is an index into the - -- itbl array + -- after assembly, the DataCon is an index into the + -- itbl array -- For doing case trees | LABEL LocalLabel | TESTLT_I Int LocalLabel @@ -147,13 +139,13 @@ data BCInstr -- To Infinity And Beyond | ENTER - | RETURN -- return a lifted value + | RETURN -- return a lifted value | RETURN_UBX ArgRep -- return an unlifted value, here's its rep - -- Breakpoints + -- Breakpoints | BRK_FUN (MutableByteArray# RealWorld) Word16 BreakInfo -data BreakInfo +data BreakInfo = BreakInfo { breakInfo_module :: Module , breakInfo_number :: {-# UNPACK #-} !Int @@ -173,8 +165,8 @@ instance Outputable BreakInfo where instance Outputable a => Outputable (ProtoBCO a) where ppr (ProtoBCO name instrs bitmap bsize arity origin malloced) - = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity - <+> text (show malloced) <> colon) + = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity + <+> text (show malloced) <> colon) $$ nest 3 (case origin of Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';')) (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}' @@ -212,8 +204,8 @@ instance Outputable BCInstr where ppr (PUSH_L offset) = text "PUSH_L " <+> ppr offset ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> ppr o1 <+> ppr o2 ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3 - ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm - ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers." + ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm + ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers." <> ppr op ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco) ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco) @@ -221,23 +213,23 @@ instance Outputable BCInstr where ppr (PUSH_UBX (Left lit) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit ppr (PUSH_UBX (Right aa) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> text (show aa) - ppr PUSH_APPLY_N = text "PUSH_APPLY_N" - ppr PUSH_APPLY_V = text "PUSH_APPLY_V" - ppr PUSH_APPLY_F = text "PUSH_APPLY_F" - ppr PUSH_APPLY_D = text "PUSH_APPLY_D" - ppr PUSH_APPLY_L = text "PUSH_APPLY_L" - ppr PUSH_APPLY_P = text "PUSH_APPLY_P" - ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP" - ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP" - ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP" - ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP" - ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP" + ppr PUSH_APPLY_N = text "PUSH_APPLY_N" + ppr PUSH_APPLY_V = text "PUSH_APPLY_V" + ppr PUSH_APPLY_F = text "PUSH_APPLY_F" + ppr PUSH_APPLY_D = text "PUSH_APPLY_D" + ppr PUSH_APPLY_L = text "PUSH_APPLY_L" + ppr PUSH_APPLY_P = text "PUSH_APPLY_P" + ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP" + ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP" + ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP" + ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP" + ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP" ppr (SLIDE n d) = text "SLIDE " <+> ppr n <+> ppr d ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> ppr sz ppr (ALLOC_AP_NOUPD sz) = text "ALLOC_AP_NOUPD " <+> ppr sz ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> ppr arity <+> ppr sz - ppr (MKAP offset sz) = text "MKAP " <+> ppr sz <+> text "words," + ppr (MKAP offset sz) = text "MKAP " <+> ppr sz <+> text "words," <+> ppr offset <+> text "stkoff" ppr (MKPAP offset sz) = text "MKPAP " <+> ppr sz <+> text "words," <+> ppr offset <+> text "stkoff" @@ -256,8 +248,8 @@ instance Outputable BCInstr where ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab ppr CASEFAIL = text "CASEFAIL" ppr (JMP lab) = text "JMP" <+> ppr lab - ppr (CCALL off marshall_addr int) = text "CCALL " <+> ppr off - <+> text "marshall code at" + ppr (CCALL off marshall_addr int) = text "CCALL " <+> ppr off + <+> text "marshall code at" <+> text (show marshall_addr) <+> (if int == 1 then text "(interruptible)" @@ -265,7 +257,7 @@ instance Outputable BCInstr where ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff <+> text "by" <+> ppr n ppr ENTER = text "ENTER" - ppr RETURN = text "RETURN" + ppr RETURN = text "RETURN" ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk ppr (BRK_FUN _breakArray index info) = text "BRK_FUN" <+> text "<array>" <+> ppr index <+> ppr info @@ -284,54 +276,54 @@ protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco)) bciStackUse :: BCInstr -> Word bciStackUse STKCHECK{} = 0 -bciStackUse PUSH_L{} = 1 -bciStackUse PUSH_LL{} = 2 +bciStackUse PUSH_L{} = 1 +bciStackUse PUSH_LL{} = 2 bciStackUse PUSH_LLL{} = 3 -bciStackUse PUSH_G{} = 1 +bciStackUse PUSH_G{} = 1 bciStackUse PUSH_PRIMOP{} = 1 -bciStackUse PUSH_BCO{} = 1 +bciStackUse PUSH_BCO{} = 1 bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco bciStackUse (PUSH_UBX _ nw) = fromIntegral nw -bciStackUse PUSH_APPLY_N{} = 1 -bciStackUse PUSH_APPLY_V{} = 1 -bciStackUse PUSH_APPLY_F{} = 1 -bciStackUse PUSH_APPLY_D{} = 1 -bciStackUse PUSH_APPLY_L{} = 1 -bciStackUse PUSH_APPLY_P{} = 1 -bciStackUse PUSH_APPLY_PP{} = 1 -bciStackUse PUSH_APPLY_PPP{} = 1 -bciStackUse PUSH_APPLY_PPPP{} = 1 -bciStackUse PUSH_APPLY_PPPPP{} = 1 -bciStackUse PUSH_APPLY_PPPPPP{} = 1 +bciStackUse PUSH_APPLY_N{} = 1 +bciStackUse PUSH_APPLY_V{} = 1 +bciStackUse PUSH_APPLY_F{} = 1 +bciStackUse PUSH_APPLY_D{} = 1 +bciStackUse PUSH_APPLY_L{} = 1 +bciStackUse PUSH_APPLY_P{} = 1 +bciStackUse PUSH_APPLY_PP{} = 1 +bciStackUse PUSH_APPLY_PPP{} = 1 +bciStackUse PUSH_APPLY_PPPP{} = 1 +bciStackUse PUSH_APPLY_PPPPP{} = 1 +bciStackUse PUSH_APPLY_PPPPPP{} = 1 bciStackUse ALLOC_AP{} = 1 bciStackUse ALLOC_AP_NOUPD{} = 1 bciStackUse ALLOC_PAP{} = 1 bciStackUse (UNPACK sz) = fromIntegral sz -bciStackUse LABEL{} = 0 -bciStackUse TESTLT_I{} = 0 -bciStackUse TESTEQ_I{} = 0 -bciStackUse TESTLT_W{} = 0 -bciStackUse TESTEQ_W{} = 0 -bciStackUse TESTLT_F{} = 0 -bciStackUse TESTEQ_F{} = 0 -bciStackUse TESTLT_D{} = 0 -bciStackUse TESTEQ_D{} = 0 -bciStackUse TESTLT_P{} = 0 -bciStackUse TESTEQ_P{} = 0 -bciStackUse CASEFAIL{} = 0 -bciStackUse JMP{} = 0 -bciStackUse ENTER{} = 0 -bciStackUse RETURN{} = 0 -bciStackUse RETURN_UBX{} = 1 -bciStackUse CCALL{} = 0 -bciStackUse SWIZZLE{} = 0 -bciStackUse BRK_FUN{} = 0 +bciStackUse LABEL{} = 0 +bciStackUse TESTLT_I{} = 0 +bciStackUse TESTEQ_I{} = 0 +bciStackUse TESTLT_W{} = 0 +bciStackUse TESTEQ_W{} = 0 +bciStackUse TESTLT_F{} = 0 +bciStackUse TESTEQ_F{} = 0 +bciStackUse TESTLT_D{} = 0 +bciStackUse TESTEQ_D{} = 0 +bciStackUse TESTLT_P{} = 0 +bciStackUse TESTEQ_P{} = 0 +bciStackUse CASEFAIL{} = 0 +bciStackUse JMP{} = 0 +bciStackUse ENTER{} = 0 +bciStackUse RETURN{} = 0 +bciStackUse RETURN_UBX{} = 1 +bciStackUse CCALL{} = 0 +bciStackUse SWIZZLE{} = 0 +bciStackUse BRK_FUN{} = 0 -- These insns actually reduce stack use, but we need the high-tide level, -- so can't use this info. Not that it matters much. -bciStackUse SLIDE{} = 0 -bciStackUse MKAP{} = 0 -bciStackUse MKPAP{} = 0 -bciStackUse PACK{} = 1 -- worst case is PACK 0 words +bciStackUse SLIDE{} = 0 +bciStackUse MKAP{} = 0 +bciStackUse MKPAP{} = 0 +bciStackUse PACK{} = 1 -- worst case is PACK 0 words \end{code} diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index d508a1c5aa..cbedb717fe 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -260,13 +260,13 @@ linkFail who what -- HACKS!!! ToDo: cleaner nameToCLabel :: Name -> String{-suffix-} -> String nameToCLabel n suffix - = if pkgid /= mainPackageId + = if pkgid /= mainPackageKey then package_part ++ '_': qual_name else qual_name where - pkgid = modulePackageId mod + pkgid = modulePackageKey mod mod = ASSERT( isExternalName n ) nameModule n - package_part = zString (zEncodeFS (packageIdFS (modulePackageId mod))) + package_part = zString (zEncodeFS (packageKeyFS (modulePackageKey mod))) module_part = zString (zEncodeFS (moduleNameFS (moduleName mod))) occ_part = zString (zEncodeFS (occNameFS (nameOccName n))) qual_name = module_part ++ '_':occ_part ++ '_':suffix diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs index 67767e41b9..9ccb113314 100644 --- a/compiler/ghci/DebuggerUtils.hs +++ b/compiler/ghci/DebuggerUtils.hs @@ -46,7 +46,7 @@ dataConInfoPtrToName x = do modFS = mkFastStringByteList mod occFS = mkFastStringByteList occ occName = mkOccNameFS OccName.dataName occFS - modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS) + modName = mkModule (fsToPackageKey pkgFS) (mkModuleNameFS modFS) return (Left $ showSDoc dflags $ ppr modName <> dot <> ppr occName) `recoverM` (Right `fmap` lookupOrig modName occName) diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 162c349a8d..40b83bbbae 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -59,7 +59,6 @@ import Control.Monad import Data.IORef import Data.List -import qualified Data.Map as Map import Control.Concurrent.MVar import System.FilePath @@ -70,7 +69,7 @@ import System.Directory hiding (findFile) import System.Directory #endif -import Distribution.Package hiding (depends, PackageId) +import Distribution.Package hiding (depends, mkPackageKey, PackageKey) import Exception \end{code} @@ -124,12 +123,8 @@ data PersistentLinkerState -- The currently-loaded packages; always object code -- Held, as usual, in dependency order; though I am not sure if -- that is really important - pkgs_loaded :: ![PackageId], - - -- we need to remember the name of the last temporary DLL/.so - -- so we can link it - last_temp_so :: !(Maybe FilePath) - } + pkgs_loaded :: ![PackageKey] + } emptyPLS :: DynFlags -> PersistentLinkerState emptyPLS _ = PersistentLinkerState { @@ -137,18 +132,17 @@ emptyPLS _ = PersistentLinkerState { itbl_env = emptyNameEnv, pkgs_loaded = init_pkgs, bcos_loaded = [], - objs_loaded = [], - last_temp_so = Nothing } + objs_loaded = [] } -- Packages that don't need loading, because the compiler -- shares them with the interpreted program. -- -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details. - where init_pkgs = [rtsPackageId] + where init_pkgs = [rtsPackageKey] -extendLoadedPkgs :: [PackageId] -> IO () +extendLoadedPkgs :: [PackageKey] -> IO () extendLoadedPkgs pkgs = modifyPLS_ $ \s -> return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } @@ -320,14 +314,14 @@ reallyInitDynLinker dflags = ; if null cmdline_lib_specs then return pls else do - { pls1 <- foldM (preloadLib dflags lib_paths framework_paths) pls cmdline_lib_specs + { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs ; maybePutStr dflags "final link ... " ; ok <- resolveObjs ; if succeeded ok then maybePutStrLn dflags "done" else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed") - ; return pls1 + ; return pls }} @@ -366,21 +360,19 @@ classifyLdInput dflags f return Nothing where platform = targetPlatform dflags -preloadLib :: DynFlags -> [String] -> [String] -> PersistentLinkerState -> LibrarySpec -> IO (PersistentLinkerState) -preloadLib dflags lib_paths framework_paths pls lib_spec +preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO () +preloadLib dflags lib_paths framework_paths lib_spec = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ") case lib_spec of Object static_ish - -> do (b, pls1) <- preload_static lib_paths static_ish + -> do b <- preload_static lib_paths static_ish maybePutStrLn dflags (if b then "done" else "not found") - return pls1 Archive static_ish -> do b <- preload_static_archive lib_paths static_ish maybePutStrLn dflags (if b then "done" else "not found") - return pls DLL dll_unadorned -> do maybe_errstr <- loadDLL (mkSOName platform dll_unadorned) @@ -396,14 +388,12 @@ preloadLib dflags lib_paths framework_paths pls lib_spec case err2 of Nothing -> maybePutStrLn dflags "done" Just _ -> preloadFailed mm lib_paths lib_spec - return pls DLLPath dll_path -> do maybe_errstr <- loadDLL dll_path case maybe_errstr of Nothing -> maybePutStrLn dflags "done" Just mm -> preloadFailed mm lib_paths lib_spec - return pls Framework framework -> if platformUsesFrameworks (targetPlatform dflags) @@ -411,7 +401,6 @@ preloadLib dflags lib_paths framework_paths pls lib_spec case maybe_errstr of Nothing -> maybePutStrLn dflags "done" Just mm -> preloadFailed mm framework_paths lib_spec - return pls else panic "preloadLib Framework" where @@ -431,13 +420,11 @@ preloadLib dflags lib_paths framework_paths pls lib_spec -- Not interested in the paths in the static case. preload_static _paths name = do b <- doesFileExist name - if not b then return (False, pls) - else if dynamicGhc - then do pls1 <- dynLoadObjs dflags pls [name] - return (True, pls1) - else do loadObj name - return (True, pls) - + if not b then return False + else do if dynamicGhc + then dynLoadObjs dflags [name] + else loadObj name + return True preload_static_archive _paths name = do b <- doesFileExist name if not b then return False @@ -539,7 +526,7 @@ getLinkDeps :: HscEnv -> HomePackageTable -> Maybe FilePath -- replace object suffices? -> SrcSpan -- for error messages -> [Module] -- If you need these - -> IO ([Linkable], [PackageId]) -- ... then link these first + -> IO ([Linkable], [PackageKey]) -- ... then link these first -- Fails with an IO exception if it can't find enough files getLinkDeps hsc_env hpt pls replace_osuf span mods @@ -577,8 +564,8 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods -- tree recursively. See bug #936, testcase ghci/prog007. follow_deps :: [Module] -- modules to follow -> UniqSet ModuleName -- accum. module dependencies - -> UniqSet PackageId -- accum. package dependencies - -> IO ([ModuleName], [PackageId]) -- result + -> UniqSet PackageKey -- accum. package dependencies + -> IO ([ModuleName], [PackageKey]) -- result follow_deps [] acc_mods acc_pkgs = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs) follow_deps (mod:mods) acc_mods acc_pkgs @@ -592,7 +579,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods when (mi_boot iface) $ link_boot_mod_error mod let - pkg = modulePackageId mod + pkg = modulePackageKey mod deps = mi_deps iface pkg_deps = dep_pkgs deps @@ -804,8 +791,8 @@ dynLinkObjs dflags pls objs = do wanted_objs = map nameOfObject unlinkeds if dynamicGhc - then do pls2 <- dynLoadObjs dflags pls1 wanted_objs - return (pls2, Succeeded) + then do dynLoadObjs dflags wanted_objs + return (pls1, Succeeded) else do mapM_ loadObj wanted_objs -- Link them all together @@ -819,11 +806,9 @@ dynLinkObjs dflags pls objs = do pls2 <- unload_wkr dflags [] pls1 return (pls2, Failed) - -dynLoadObjs :: DynFlags -> PersistentLinkerState -> [FilePath] - -> IO PersistentLinkerState -dynLoadObjs _ pls [] = return pls -dynLoadObjs dflags pls objs = do +dynLoadObjs :: DynFlags -> [FilePath] -> IO () +dynLoadObjs _ [] = return () +dynLoadObjs dflags objs = do let platform = targetPlatform dflags soFile <- newTempName dflags (soExt platform) let -- When running TH for a non-dynamic way, we still need to make @@ -831,22 +816,10 @@ dynLoadObjs dflags pls objs = do -- Opt_Static off dflags1 = gopt_unset dflags Opt_Static dflags2 = dflags1 { - -- We don't want the original ldInputs in - -- (they're already linked in), but we do want - -- to link against the previous dynLoadObjs - -- library if there was one, so that the linker - -- can resolve dependencies when it loads this - -- library. - ldInputs = - case last_temp_so pls of - Nothing -> [] - Just so -> - let (lp, l) = splitFileName so in - [ Option ("-L" ++ lp) - , Option ("-Wl,-rpath") - , Option ("-Wl," ++ lp) - , Option ("-l:" ++ l) - ], + -- We don't want to link the ldInputs in; we'll + -- be calling dynLoadObjs with any objects that + -- need to be linked. + ldInputs = [], -- Even if we're e.g. profiling, we still want -- the vanilla dynamic libraries, so we set the -- ways / build tag to be just WayDyn. @@ -858,7 +831,7 @@ dynLoadObjs dflags pls objs = do consIORef (filesToNotIntermediateClean dflags) soFile m <- loadDLL soFile case m of - Nothing -> return pls { last_temp_so = Just soFile } + Nothing -> return () Just err -> panic ("Loading temp shared object failed: " ++ err) rmDupLinkables :: [Linkable] -- Already loaded @@ -1071,7 +1044,7 @@ showLS (Framework nm) = "(framework) " ++ nm -- automatically, and it doesn't matter what order you specify the input -- packages. -- -linkPackages :: DynFlags -> [PackageId] -> IO () +linkPackages :: DynFlags -> [PackageKey] -> IO () -- NOTE: in fact, since each module tracks all the packages it depends on, -- we don't really need to use the package-config dependencies. -- @@ -1087,16 +1060,13 @@ linkPackages dflags new_pkgs = do modifyPLS_ $ \pls -> do linkPackages' dflags new_pkgs pls -linkPackages' :: DynFlags -> [PackageId] -> PersistentLinkerState +linkPackages' :: DynFlags -> [PackageKey] -> PersistentLinkerState -> IO PersistentLinkerState linkPackages' dflags new_pks pls = do pkgs' <- link (pkgs_loaded pls) new_pks return $! pls { pkgs_loaded = pkgs' } where - pkg_map = pkgIdMap (pkgState dflags) - ipid_map = installedPackageIdMap (pkgState dflags) - - link :: [PackageId] -> [PackageId] -> IO [PackageId] + link :: [PackageKey] -> [PackageKey] -> IO [PackageKey] link pkgs new_pkgs = foldM link_one pkgs new_pkgs @@ -1104,17 +1074,16 @@ linkPackages' dflags new_pks pls = do | new_pkg `elem` pkgs -- Already linked = return pkgs - | Just pkg_cfg <- lookupPackage pkg_map new_pkg + | Just pkg_cfg <- lookupPackage dflags new_pkg = do { -- Link dependents first - pkgs' <- link pkgs [ Maybes.expectJust "link_one" $ - Map.lookup ipid ipid_map + pkgs' <- link pkgs [ resolveInstalledPackageId dflags ipid | ipid <- depends pkg_cfg ] -- Now link the package itself ; linkPackage dflags pkg_cfg ; return (new_pkg : pkgs') } | otherwise - = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ packageIdString new_pkg)) + = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ packageKeyString new_pkg)) linkPackage :: DynFlags -> PackageConfig -> IO () @@ -1235,7 +1204,9 @@ locateLib dflags is_hs dirs lib 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 + mk_dyn_lib_path dir = case (arch, os) of + (ArchX86_64, OSSolaris2) -> dir </> ("64/" ++ so_name) + _ -> dir </> so_name findObject = liftM (fmap Object) $ findFile mk_obj_path dirs findDynObject = liftM (fmap Object) $ findFile mk_dyn_obj_path dirs @@ -1252,6 +1223,8 @@ locateLib dflags is_hs dirs lib Nothing -> g platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) searchForLibUsingGcc dflags so dirs = do diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index a2f9af92f1..dde813d31d 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -7,14 +7,6 @@ -- Pepe Iborra (supported by Google SoC) 2006 -- ----------------------------------------------------------------------------- - -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module RtClosureInspect( cvObtainTerm, -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term cvReconstructType, @@ -85,9 +77,9 @@ import System.IO.Unsafe data Term = Term { ty :: RttiType , dc :: Either String DataCon -- Carries a text representation if the datacon is - -- not exported by the .hi file, which is the case + -- not exported by the .hi file, which is the case -- for private constructors in -O0 compiled libraries - , val :: HValue + , val :: HValue , subTerms :: [Term] } | Prim { ty :: RttiType @@ -142,20 +134,20 @@ instance Outputable (Term) where ------------------------------------------------------------------------- -- Runtime Closure Datatype and functions for retrieving closure related stuff ------------------------------------------------------------------------- -data ClosureType = Constr - | Fun - | Thunk Int +data ClosureType = Constr + | Fun + | Thunk Int | ThunkSelector - | Blackhole - | AP - | PAP - | Indirection Int + | Blackhole + | AP + | PAP + | Indirection Int | MutVar Int | MVar Int | Other Int deriving (Show, Eq) -data Closure = Closure { tipe :: ClosureType +data Closure = Closure { tipe :: ClosureType , infoPtr :: Ptr () , infoTable :: StgInfoTable , ptrs :: Array Int HValue @@ -163,7 +155,7 @@ data Closure = Closure { tipe :: ClosureType } instance Outputable ClosureType where - ppr = text . show + ppr = text . show #include "../includes/rts/storage/ClosureTypes.h" @@ -175,7 +167,7 @@ pAP_CODE = PAP getClosureData :: DynFlags -> a -> IO Closure getClosureData dflags a = - case unpackClosure# a of + case unpackClosure# a of (# iptr, ptrs, nptrs #) -> do let iptr' | ghciTablesNextToCode = @@ -194,11 +186,11 @@ getClosureData dflags a = nptrs_data = [W# (indexWordArray# nptrs i) | I# i <- [0.. fromIntegral (BCI.nptrs itbl)-1] ] ASSERT(elems >= 0) return () - ptrsList `seq` + ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data) readCType :: Integral a => a -> ClosureType -readCType i +readCType i | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr | i >= FUN && i <= FUN_STATIC = Fun | i >= THUNK && i < THUNK_SELECTOR = Thunk i' @@ -212,7 +204,7 @@ readCType i | i == MVAR_CLEAN || i == MVAR_DIRTY = MVar i' | otherwise = Other i' where i' = fromIntegral i - + isConstr, isIndirection, isThunk :: ClosureType -> Bool isConstr Constr = True isConstr _ = False @@ -240,7 +232,7 @@ unsafeDeepSeq :: a -> b -> b unsafeDeepSeq = unsafeDeepSeq1 2 where unsafeDeepSeq1 0 a b = seq a $! b unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks - | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b + | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b -- | unsafePerformIO (isFullyEvaluated a) = b | otherwise = case unsafePerformIO (getClosureData a) of closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure) @@ -315,7 +307,7 @@ mapTermTypeM f = foldTermM TermFoldM { termTyVars :: Term -> TyVarSet termTyVars = foldTerm TermFold { - fTerm = \ty _ _ tt -> + fTerm = \ty _ _ tt -> tyVarsOfType ty `plusVarEnv` concatVarEnv tt, fSuspension = \_ ty _ _ -> tyVarsOfType ty, fPrim = \ _ _ -> emptyVarEnv, @@ -347,21 +339,21 @@ ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do tt_docs <- mapM (y app_prec) tt return $ cparen (not (null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs) - -ppr_termM y p Term{dc=Right dc, subTerms=tt} + +ppr_termM y p Term{dc=Right dc, subTerms=tt} {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity - = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2) - <+> hsep (map (ppr_term1 True) tt) + = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2) + <+> hsep (map (ppr_term1 True) tt) -} -- TODO Printing infix constructors properly | null sub_terms_to_show = return (ppr dc) - | otherwise + | otherwise = do { tt_docs <- mapM (y app_prec) sub_terms_to_show ; return $ cparen (p >= app_prec) $ sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] } where - sub_terms_to_show -- Don't show the dictionary arguments to - -- constructors unless -dppr-debug is on + sub_terms_to_show -- Don't show the dictionary arguments to + -- constructors unless -dppr-debug is on | opt_PprStyle_Debug = tt | otherwise = dropList (dataConTheta dc) tt @@ -378,9 +370,9 @@ ppr_termM _ _ t = ppr_termM1 t ppr_termM1 :: Monad m => Term -> m SDoc -ppr_termM1 Prim{value=words, ty=ty} = +ppr_termM1 Prim{value=words, ty=ty} = return $ repPrim (tyConAppTyCon ty) words -ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = +ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = return (char '_' <+> ifPprDebug (text "::" <> ppr ty)) ppr_termM1 Suspension{ty=ty, bound_to=Just n} -- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>") @@ -392,7 +384,7 @@ ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap" pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t} | Just (tc,_) <- tcSplitTyConApp_maybe ty , ASSERT(isNewTyCon tc) True - , Just new_dc <- tyConSingleDataCon_maybe tc = do + , Just new_dc <- tyConSingleDataCon_maybe tc = do real_term <- y max_prec t return $ cparen (p >= app_prec) (ppr new_dc <+> real_term) pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap" @@ -401,11 +393,11 @@ pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap" -- Custom Term Pretty Printers ------------------------------------------------------- --- We can want to customize the representation of a --- term depending on its type. +-- We can want to customize the representation of a +-- term depending on its type. -- However, note that custom printers have to work with -- type representations, instead of directly with types. --- We cannot use type classes here, unless we employ some +-- We cannot use type classes here, unless we employ some -- typerep trickery (e.g. Weirich's RepLib tricks), -- which I didn't. Therefore, this code replicates a lot -- of what type classes provide for free. @@ -413,7 +405,7 @@ pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap" type CustomTermPrinter m = TermPrinterM m -> [Precedence -> Term -> (m (Maybe SDoc))] --- | Takes a list of custom printers with a explicit recursion knot and a term, +-- | Takes a list of custom printers with a explicit recursion knot and a term, -- and returns the output of the first successful printer, or the default printer cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc cPprTerm printers_ = go 0 where @@ -430,7 +422,7 @@ cPprTerm printers_ = go 0 where -- Default set of custom printers. Note that the recursion knot is explicit cPprTermBase :: forall m. Monad m => CustomTermPrinter m cPprTermBase y = - [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma) + [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma) . mapM (y (-1)) . subTerms) , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2) @@ -441,7 +433,7 @@ cPprTermBase y = , ifTerm (isTyCon doubleTyCon . ty) ppr_double , ifTerm (isIntegerTy . ty) ppr_integer ] - where + where ifTerm :: (Term -> Bool) -> (Precedence -> Term -> m SDoc) -> Precedence -> Term -> m (Maybe SDoc) @@ -449,11 +441,11 @@ cPprTermBase y = | pred t = Just `liftM` f prec t ifTerm _ _ _ _ = return Nothing - isTupleTy ty = fromMaybe False $ do - (tc,_) <- tcSplitTyConApp_maybe ty + isTupleTy ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty return (isBoxedTupleTyCon tc) - isTyCon a_tc ty = fromMaybe False $ do + isTyCon a_tc ty = fromMaybe False $ do (tc,_) <- tcSplitTyConApp_maybe ty return (a_tc == tc) @@ -461,7 +453,7 @@ cPprTermBase y = (tc,_) <- tcSplitTyConApp_maybe ty return (tyConName tc == integerTyConName) - ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer + ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer :: Precedence -> Term -> m SDoc ppr_int _ v = return (Ppr.int (unsafeCoerce# (val v))) ppr_char _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'') @@ -474,16 +466,16 @@ cPprTermBase y = ppr_list p (Term{subTerms=[h,t]}) = do let elems = h : getListTerms t isConsLast = not(termType(last elems) `eqType` termType h) - is_string = all (isCharTy . ty) elems + is_string = all (isCharTy . ty) elems print_elems <- mapM (y cons_prec) elems if is_string then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems)))) else if isConsLast - then return $ cparen (p >= cons_prec) - $ pprDeeperList fsep + then return $ cparen (p >= cons_prec) + $ pprDeeperList fsep $ punctuate (space<>colon) print_elems - else return $ brackets + else return $ brackets $ pprDeeperList fcat $ punctuate comma print_elems @@ -524,9 +516,9 @@ repPrim t = rep where | t == mVarPrimTyCon = text "<mVar>" | t == tVarPrimTyCon = text "<tVar>" | otherwise = char '<' <> ppr t <> char '>' - where build ww = unsafePerformIO $ withArray ww (peek . castPtr) --- This ^^^ relies on the representation of Haskell heap values being --- the same as in a C array. + where build ww = unsafePerformIO $ withArray ww (peek . castPtr) +-- This ^^^ relies on the representation of Haskell heap values being +-- the same as in a C array. ----------------------------------- -- Type Reconstruction @@ -537,14 +529,14 @@ The algorithm walks the heap generating a set of equations, which are solved with syntactic unification. A type reconstruction equation looks like: - <datacon reptype> = <actual heap contents> + <datacon reptype> = <actual heap contents> The full equation set is generated by traversing all the subterms, starting from a given term. The only difficult part is that newtypes are only found in the lhs of equations. -Right hand sides are missing them. We can either (a) drop them from the lhs, or -(b) reconstruct them in the rhs when possible. +Right hand sides are missing them. We can either (a) drop them from the lhs, or +(b) reconstruct them in the rhs when possible. The function congruenceNewtypes takes a shot at (b) -} @@ -574,7 +566,7 @@ runTR hsc_env thing = do runTR_maybe :: HscEnv -> TR a -> IO (Maybe a) runTR_maybe hsc_env thing_inside - = do { (_errs, res) <- initTc hsc_env HsSrcFile False + = do { (_errs, res) <- initTc hsc_env HsSrcFile False (icInteractiveModule (hsc_IC hsc_env)) thing_inside ; return res } @@ -583,17 +575,17 @@ traceTR :: SDoc -> TR () traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti --- Semantically different to recoverM in TcRnMonad +-- Semantically different to recoverM in TcRnMonad -- recoverM retains the errors in the first action, -- whereas recoverTc here does not recoverTR :: TR a -> TR a -> TR a -recoverTR recover thing = do +recoverTR recover thing = do (_,mb_res) <- tryTcErrs thing - case mb_res of + case mb_res of Nothing -> recover Just res -> return res -trIO :: IO a -> TR a +trIO :: IO a -> TR a trIO = liftTcM . liftIO liftTcM :: TcM a -> TR a @@ -608,17 +600,17 @@ instTyVars :: [TyVar] -> TR ([TcTyVar], [TcType], TvSubst) instTyVars = liftTcM . tcInstTyVars type RttiInstantiation = [(TcTyVar, TyVar)] - -- Associates the typechecker-world meta type variables - -- (which are mutable and may be refined), to their + -- Associates the typechecker-world meta type variables + -- (which are mutable and may be refined), to their -- debugger-world RuntimeUnk counterparts. -- If the TcTyVar has not been refined by the runtime type -- elaboration, then we want to turn it back into the -- original RuntimeUnk --- | Returns the instantiated type scheme ty', and the +-- | Returns the instantiated type scheme ty', and the -- mapping from new (instantiated) -to- old (skolem) type variables instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation) -instScheme (tvs, ty) +instScheme (tvs, ty) = liftTcM $ do { (tvs', _, subst) <- tcInstTyVars tvs ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs] ; return (substTy subst ty, rtti_inst) } @@ -698,7 +690,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do text "Term obtained: " <> ppr term $$ text "Type obtained: " <> ppr (termType term)) return term - where + where dflags = hsc_dflags hsc_env go :: Int -> Type -> Type -> HValue -> TcM Term @@ -715,7 +707,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do clos <- trIO $ getClosureData dflags a return (Suspension (tipe clos) my_ty a Nothing) go max_depth my_ty old_ty a = do - let monomorphic = not(isTyVarTy my_ty) + let monomorphic = not(isTyVarTy my_ty) -- This ^^^ is a convention. The ancestor tests for -- monomorphism and passes a type instead of a tv clos <- trIO $ getClosureData dflags a @@ -735,14 +727,14 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty -> do -- Deal with the MutVar# primitive - -- It does not have a constructor at all, + -- It does not have a constructor at all, -- so we simulate the following one -- MutVar# :: contents_ty -> MutVar# s contents_ty traceTR (text "Following a MutVar") contents_tv <- newVar liftedTypeKind contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w ASSERT(isUnliftedTypeKind $ typeKind my_ty) return () - (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy + (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy contents_ty (mkTyConApp tycon [world,contents_ty]) addConstraint (mkFunTy contents_tv my_ty) mutvar_ty x <- go (pred max_depth) contents_tv contents_ty contents @@ -762,12 +754,12 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do -- In such case, we return a best approximation: -- ignore the unpointed args, and recover the pointeds -- This preserves laziness, and should be safe. - traceTR (text "Not constructor" <+> ppr dcname) + traceTR (text "Not constructor" <+> ppr dcname) let dflags = hsc_dflags hsc_env tag = showPpr dflags dcname - vars <- replicateM (length$ elems$ ptrs clos) + vars <- replicateM (length$ elems$ ptrs clos) (newVar liftedTypeKind) - subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i + subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i | (i, tv) <- zip [0..] vars] return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms) Just dc -> do @@ -875,7 +867,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <> int max_depth <> text " steps") search stop expand l d = - case viewl l of + case viewl l of EmptyL -> return () x :< xx -> unlessM stop $ do new <- expand x @@ -921,7 +913,7 @@ findPtrTys i ty | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty , isUnboxedTupleTyCon tc = findPtrTyss i elem_tys - + | otherwise = case repType ty of UnaryRep rep_ty | typePrimRep rep_ty == PtrRep -> return (i + 1, [(i, ty)]) @@ -954,7 +946,7 @@ getDataConArgTys :: DataCon -> Type -> TR [Type] -- I believe that con_app_ty should not have any enclosing foralls getDataConArgTys dc con_app_ty = do { let UnaryRep rep_con_app_ty = repType con_app_ty - ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty + ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty))) ; (_, _, subst) <- instTyVars (univ_tvs ++ ex_tvs) ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc)) @@ -975,7 +967,7 @@ Consider a GADT (cf Trac #7386) ... In getDataConArgTys -* con_app_ty is the known type (from outside) of the constructor application, +* con_app_ty is the known type (from outside) of the constructor application, say D [Int] Int * The data constructor MkT has a (representation) dataConTyCon = DList, @@ -984,7 +976,7 @@ In getDataConArgTys MkT :: a -> DList a (Maybe a) ... -So the dataConTyCon of the data constructor, DList, differs from +So the dataConTyCon of the data constructor, DList, differs from the "outside" type, D. So we can't straightforwardly decompose the "outside" type, and we end up in the "_" branch of the case. @@ -1126,9 +1118,9 @@ check2 (_, rtti_ty) (_, old_ty) -- Dealing with newtypes -------------------------- {- - congruenceNewtypes does a parallel fold over two Type values, - compensating for missing newtypes on both sides. - This is necessary because newtypes are not present + congruenceNewtypes does a parallel fold over two Type values, + compensating for missing newtypes on both sides. + This is necessary because newtypes are not present in runtime, but sometimes there is evidence available. Evidence can come from DataCon signatures or from compile-time type inference. @@ -1174,8 +1166,8 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') return (mkFunTy r1' r2') -- TyconApp Inductive case; this is the interesting bit. | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs - , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs - , tycon_l /= tycon_r + , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs + , tycon_l /= tycon_r = upgrade tycon_l r | otherwise = return r @@ -1185,7 +1177,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') | not (isNewTyCon new_tycon) = do traceTR (text "(Upgrade) Not matching newtype evidence: " <> ppr new_tycon <> text " for " <> ppr ty) - return ty + return ty | otherwise = do traceTR (text "(Upgrade) upgraded " <> ppr ty <> text " in presence of newtype evidence " <> ppr new_tycon) @@ -1193,7 +1185,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') let ty' = mkTyConApp new_tycon vars UnaryRep rep_ty = repType ty' _ <- liftTcM (unifyType ty rep_ty) - -- assumes that reptype doesn't ^^^^ touch tyconApp args + -- assumes that reptype doesn't ^^^^ touch tyconApp args return ty' @@ -1205,7 +1197,7 @@ zonkTerm = foldTermM (TermFoldM return (Suspension ct ty v b) , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' -> return$ NewtypeWrap ty' dc t - , fRefWrapM = \ty t -> return RefWrap `ap` + , fRefWrapM = \ty t -> return RefWrap `ap` zonkRttiType ty `ap` return t , fPrimM = (return.) . Prim }) @@ -1214,13 +1206,13 @@ zonkRttiType :: TcType -> TcM Type -- by skolems, safely out of Meta-tyvar-land zonkRttiType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_meta) where - zonk_unbound_meta tv + zonk_unbound_meta tv = ASSERT( isTcTyVar tv ) do { tv' <- skolemiseUnboundMetaTyVar tv RuntimeUnk - -- This is where RuntimeUnks are born: - -- otherwise-unconstrained unification variables are - -- turned into RuntimeUnks as they leave the - -- typechecker's monad + -- This is where RuntimeUnks are born: + -- otherwise-unconstrained unification variables are + -- turned into RuntimeUnks as they leave the + -- typechecker's monad ; return (mkTyVarTy tv') } -------------------------------------------------------------------------------- diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 6862901437..d722a402e0 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -201,13 +201,20 @@ cvtDec (ClassD ctxt cl tvs fds decs) ; unless (null adts') (failWith $ (ptext (sLit "Default data instance declarations are not allowed:")) $$ (Outputable.ppr adts')) + ; at_defs <- mapM cvt_at_def ats' ; returnL $ TyClD $ ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds' - , tcdATs = fams', tcdATDefs = ats', tcdDocs = [] + , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = [] , tcdFVs = placeHolderNames } -- no docs in TH ^^ } + where + cvt_at_def :: LTyFamInstDecl RdrName -> CvtM (LTyFamDefltEqn RdrName) + -- Very similar to what happens in RdrHsSyn.mkClassDecl + cvt_at_def decl = case RdrHsSyn.mkATDefault decl of + Right def -> return def + Left (_, msg) -> failWith msg cvtDec (InstanceD ctxt ty decs) = do { let doc = ptext (sLit "an instance declaration") @@ -216,7 +223,7 @@ cvtDec (InstanceD ctxt ty decs) ; ctxt' <- cvtContext ctxt ; L loc ty' <- cvtType ty ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty' - ; returnL $ InstD (ClsInstD (ClsInstDecl inst_ty' binds' sigs' ats' adts')) } + ; returnL $ InstD (ClsInstD (ClsInstDecl inst_ty' binds' sigs' ats' adts' Nothing)) } cvtDec (ForeignD ford) = do { ford' <- cvtForD ford @@ -280,9 +287,9 @@ cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName) cvtTySynEqn tc (TySynEqn lhs rhs) = do { lhs' <- mapM cvtType lhs ; rhs' <- cvtType rhs - ; returnL $ TyFamInstEqn { tfie_tycon = tc - , tfie_pats = mkHsWithBndrs lhs' - , tfie_rhs = rhs' } } + ; returnL $ TyFamEqn { tfe_tycon = tc + , tfe_pats = mkHsWithBndrs lhs' + , tfe_rhs = rhs' } } ---------------- cvt_ci_decs :: MsgDoc -> [TH.Dec] @@ -1143,8 +1150,8 @@ mk_ghc_ns TH.VarName = OccName.varName mk_mod :: TH.ModName -> ModuleName mk_mod mod = mkModuleName (TH.modString mod) -mk_pkg :: TH.PkgName -> PackageId -mk_pkg pkg = stringToPackageId (TH.pkgString pkg) +mk_pkg :: TH.PkgName -> PackageKey +mk_pkg pkg = stringToPackageKey (TH.pkgString pkg) mk_uniq :: Int# -> Unique mk_uniq u = mkUniqueGrimily (I# u) diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 2261a89741..04a72225f1 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -166,13 +166,7 @@ data HsBindLR idL idR abs_binds :: LHsBinds idL -- ^ Typechecked user bindings } - | PatSynBind { - patsyn_id :: Located idL, -- ^ Name of the pattern synonym - bind_fvs :: NameSet, -- ^ See Note [Bind free vars] - patsyn_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names - patsyn_def :: LPat idR, -- ^ Right-hand side - patsyn_dir :: HsPatSynDir idR -- ^ Directionality - } + | PatSynBind (PatSynBind idL idR) deriving (Data, Typeable) -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] @@ -195,6 +189,14 @@ data ABExport id , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas } deriving (Data, Typeable) +data PatSynBind idL idR + = PSB { psb_id :: Located idL, -- ^ Name of the pattern synonym + psb_fvs :: NameSet, -- ^ See Note [Bind free vars] + psb_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names + psb_def :: LPat idR, -- ^ Right-hand side + psb_dir :: HsPatSynDir idR -- ^ Directionality + } deriving (Data, Typeable) + -- | Used for the NameSet in FunBind and PatBind prior to the renamer placeHolderNames :: NameSet placeHolderNames = panic "placeHolderNames" @@ -437,20 +439,7 @@ ppr_monobind (FunBind { fun_id = fun, fun_infix = inf, $$ ifPprDebug (pprBndr LetBind (unLoc fun)) $$ pprFunBind (unLoc fun) inf matches $$ ifPprDebug (ppr wrap) -ppr_monobind (PatSynBind{ patsyn_id = L _ psyn, patsyn_args = details, - patsyn_def = pat, patsyn_dir = dir }) - = ppr_lhs <+> ppr_rhs - where - ppr_lhs = ptext (sLit "pattern") <+> ppr_details details - ppr_simple syntax = syntax <+> ppr pat - - ppr_details (InfixPatSyn v1 v2) = hsep [ppr v1, pprInfixOcc psyn, ppr v2] - ppr_details (PrefixPatSyn vs) = hsep (pprPrefixOcc psyn : map ppr vs) - - ppr_rhs = case dir of - Unidirectional -> ppr_simple (ptext (sLit "<-")) - ImplicitBidirectional -> ppr_simple equals - +ppr_monobind (PatSynBind psb) = ppr psb ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars , abs_exports = exports, abs_binds = val_binds , abs_ev_binds = ev_binds }) @@ -467,6 +456,23 @@ instance (OutputableBndr id) => Outputable (ABExport id) where = vcat [ ppr gbl <+> ptext (sLit "<=") <+> ppr lcl , nest 2 (pprTcSpecPrags prags) , nest 2 (ppr wrap)] + +instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL idR) where + ppr (PSB{ psb_id = L _ psyn, psb_args = details, psb_def = pat, psb_dir = dir }) + = ppr_lhs <+> ppr_rhs + where + ppr_lhs = ptext (sLit "pattern") <+> ppr_details + ppr_simple syntax = syntax <+> ppr pat + + (is_infix, ppr_details) = case details of + InfixPatSyn v1 v2 -> (True, hsep [ppr v1, pprInfixOcc psyn, ppr v2]) + PrefixPatSyn vs -> (False, hsep (pprPrefixOcc psyn : map ppr vs)) + + ppr_rhs = case dir of + Unidirectional -> ppr_simple (ptext (sLit "<-")) + ImplicitBidirectional -> ppr_simple equals + ExplicitBidirectional mg -> ppr_simple (ptext (sLit "<-")) <+> ptext (sLit "where") $$ + (nest 2 $ pprFunBind psyn is_infix mg) \end{code} @@ -785,10 +791,9 @@ instance Traversable HsPatSynDetails where traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args -data HsPatSynDirLR idL idR +data HsPatSynDir id = Unidirectional | ImplicitBidirectional + | ExplicitBidirectional (MatchGroup id (LHsExpr id)) deriving (Data, Typeable) - -type HsPatSynDir id = HsPatSynDirLR id id \end{code} diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index c4174db776..313dccccd5 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -29,7 +29,7 @@ module HsDecls ( InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..), TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts, DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, - TyFamInstEqn(..), LTyFamInstEqn, + TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn, LClsInstDecl, ClsInstDecl(..), -- ** Standalone deriving declarations @@ -472,7 +472,7 @@ data TyClDecl name tcdSigs :: [LSig name], -- ^ Methods' signatures tcdMeths :: LHsBinds name, -- ^ Default methods tcdATs :: [LFamilyDecl name], -- ^ Associated types; ie - tcdATDefs :: [LTyFamInstDecl name], -- ^ Associated type defaults + tcdATDefs :: [LTyFamDefltEqn name], -- ^ Associated type defaults tcdDocs :: [LDocDecl], -- ^ Haddock docs tcdFVs :: NameSet } @@ -573,7 +573,7 @@ tyFamInstDeclName = unLoc . tyFamInstDeclLName tyFamInstDeclLName :: OutputableBndr name => TyFamInstDecl name -> Located name tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = - (L _ (TyFamInstEqn { tfie_tycon = ln })) }) + (L _ (TyFamEqn { tfe_tycon = ln })) }) = ln tyClDeclLName :: TyClDecl name -> Located name @@ -632,7 +632,7 @@ instance OutputableBndr name | otherwise -- Laid out = vcat [ top_matter <+> ptext (sLit "where") , nest 2 $ pprDeclList (map ppr ats ++ - map ppr at_defs ++ + map ppr_fam_deflt_eqn at_defs ++ pprLHsBindsForUser methods sigs) ] where top_matter = ptext (sLit "class") @@ -657,7 +657,7 @@ instance (OutputableBndr name) => Outputable (FamilyDecl name) where ClosedTypeFamily eqns -> ( ptext (sLit "where") , if null eqns then ptext (sLit "..") - else vcat $ map ppr eqns ) + else vcat $ map ppr_fam_inst_eqn eqns ) _ -> (empty, empty) pprFlavour :: FamilyInfo name -> SDoc @@ -678,7 +678,7 @@ pp_vanilla_decl_head thing tyvars context pp_fam_inst_lhs :: OutputableBndr name => Located name - -> HsWithBndrs [LHsType name] + -> HsTyPats name -> HsContext name -> SDoc pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patterns @@ -686,12 +686,13 @@ pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patt , hsep (map (pprParendHsType.unLoc) typats)] pprTyClDeclFlavour :: TyClDecl a -> SDoc -pprTyClDeclFlavour (ClassDecl {}) = ptext (sLit "class") -pprTyClDeclFlavour (FamDecl {}) = ptext (sLit "family") -pprTyClDeclFlavour (SynDecl {}) = ptext (sLit "type") -pprTyClDeclFlavour (DataDecl { tcdDataDefn = (HsDataDefn { dd_ND = nd }) }) - = ppr nd +pprTyClDeclFlavour (ClassDecl {}) = ptext (sLit "class") +pprTyClDeclFlavour (SynDecl {}) = ptext (sLit "type") pprTyClDeclFlavour (ForeignType {}) = ptext (sLit "foreign type") +pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) + = pprFlavour info +pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) + = ppr nd \end{code} %************************************************************************ @@ -893,25 +894,49 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT { %* * %************************************************************************ +Note [Type family instance declarations in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The data type TyFamEqn represents one equation of a type family instance. +It is parameterised over its tfe_pats field: + + * An ordinary type family instance declaration looks like this in source Haskell + type instance T [a] Int = a -> a + (or something similar for a closed family) + It is represented by a TyFamInstEqn, with *type* in the tfe_pats field. + + * On the other hand, the *default instance* of an associated type looksl like + this in source Haskell + class C a where + type T a b + type T a b = a -> b -- The default instance + It is represented by a TyFamDefltEqn, with *type variables8 in the tfe_pats field. + \begin{code} ----------------- Type synonym family instances ------------- +type LTyFamInstEqn name = Located (TyFamInstEqn name) +type LTyFamDefltEqn name = Located (TyFamDefltEqn name) -type LTyFamInstEqn name = Located (TyFamInstEqn name) - --- | One equation in a type family instance declaration -data TyFamInstEqn name - = TyFamInstEqn - { tfie_tycon :: Located name - , tfie_pats :: HsWithBndrs [LHsType name] +type HsTyPats name = HsWithBndrs [LHsType name] -- ^ Type patterns (with kind and type bndrs) -- See Note [Family instance declaration binders] - , tfie_rhs :: LHsType name } + +type TyFamInstEqn name = TyFamEqn name (HsTyPats name) +type TyFamDefltEqn name = TyFamEqn name (LHsTyVarBndrs name) + -- See Note [Type family instance declarations in HsSyn] + +-- | One equation in a type family instance declaration +-- See Note [Type family instance declarations in HsSyn] +data TyFamEqn name pats + = TyFamEqn + { tfe_tycon :: Located name + , tfe_pats :: pats + , tfe_rhs :: LHsType name } deriving( Typeable, Data ) type LTyFamInstDecl name = Located (TyFamInstDecl name) -data TyFamInstDecl name +data TyFamInstDecl name = TyFamInstDecl - { tfid_eqn :: LTyFamInstEqn name + { tfid_eqn :: LTyFamInstEqn name , tfid_fvs :: NameSet } deriving( Typeable, Data ) @@ -921,11 +946,9 @@ type LDataFamInstDecl name = Located (DataFamInstDecl name) data DataFamInstDecl name = DataFamInstDecl { dfid_tycon :: Located name - , dfid_pats :: HsWithBndrs [LHsType name] -- lhs - -- ^ Type patterns (with kind and type bndrs) - -- See Note [Family instance declaration binders] - , dfid_defn :: HsDataDefn name -- rhs - , dfid_fvs :: NameSet } -- free vars for dependency analysis + , dfid_pats :: HsTyPats name -- LHS + , dfid_defn :: HsDataDefn name -- RHS + , dfid_fvs :: NameSet } -- Rree vars for dependency analysis deriving( Typeable, Data ) @@ -937,10 +960,11 @@ data ClsInstDecl name { cid_poly_ty :: LHsType name -- Context => Class Instance-type -- Using a polytype means that the renamer conveniently -- figures out the quantified type variables for us. - , cid_binds :: LHsBinds name - , cid_sigs :: [LSig name] -- User-supplied pragmatic info - , cid_tyfam_insts :: [LTyFamInstDecl name] -- type family instances - , cid_datafam_insts :: [LDataFamInstDecl name] -- data family instances + , cid_binds :: LHsBinds name -- Class methods + , cid_sigs :: [LSig name] -- User-supplied pragmatic info + , cid_tyfam_insts :: [LTyFamInstDecl name] -- Type family instances + , cid_datafam_insts :: [LDataFamInstDecl name] -- Data family instances + , cid_overlap_mode :: Maybe OverlapMode } deriving (Data, Typeable) @@ -983,17 +1007,23 @@ instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where pprTyFamInstDecl :: OutputableBndr name => TopLevelFlag -> TyFamInstDecl name -> SDoc pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) - = ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> (ppr eqn) + = ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn ppr_instance_keyword :: TopLevelFlag -> SDoc ppr_instance_keyword TopLevel = ptext (sLit "instance") ppr_instance_keyword NotTopLevel = empty -instance (OutputableBndr name) => Outputable (TyFamInstEqn name) where - ppr (TyFamInstEqn { tfie_tycon = tycon - , tfie_pats = pats - , tfie_rhs = rhs }) - = (pp_fam_inst_lhs tycon pats []) <+> equals <+> (ppr rhs) +ppr_fam_inst_eqn :: OutputableBndr name => LTyFamInstEqn name -> SDoc +ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon + , tfe_pats = pats + , tfe_rhs = rhs })) + = pp_fam_inst_lhs tycon pats [] <+> equals <+> ppr rhs + +ppr_fam_deflt_eqn :: OutputableBndr name => LTyFamDefltEqn name -> SDoc +ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon + , tfe_pats = tvs + , tfe_rhs = rhs })) + = pp_vanilla_decl_head tycon tvs [] <+> equals <+> ppr rhs instance (OutputableBndr name) => Outputable (DataFamInstDecl name) where ppr = pprDataFamInstDecl TopLevel @@ -1013,6 +1043,7 @@ pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) instance (OutputableBndr name) => Outputable (ClsInstDecl name) where ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_overlap_mode = mbOverlap , cid_datafam_insts = adts }) | null sigs, null ats, null adts, isEmptyBag binds -- No "where" part = top_matter @@ -1024,7 +1055,21 @@ instance (OutputableBndr name) => Outputable (ClsInstDecl name) where map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++ pprLHsBindsForUser binds sigs ] where - top_matter = ptext (sLit "instance") <+> ppr inst_ty + top_matter = ptext (sLit "instance") <+> ppOverlapPragma mbOverlap + <+> ppr inst_ty + +ppOverlapPragma :: Maybe OverlapMode -> SDoc +ppOverlapPragma mb = + case mb of + Nothing -> empty + Just NoOverlap -> ptext (sLit "{-# NO_OVERLAP #-}") + Just Overlappable -> ptext (sLit "{-# OVERLAPPABLE #-}") + Just Overlapping -> ptext (sLit "{-# OVERLAPPING #-}") + Just Overlaps -> ptext (sLit "{-# OVERLAPS #-}") + Just Incoherent -> ptext (sLit "{-# INCOHERENT #-}") + + + instance (OutputableBndr name) => Outputable (InstDecl name) where ppr (ClsInstD { cid_inst = decl }) = ppr decl @@ -1052,12 +1097,14 @@ instDeclDataFamInsts inst_decls \begin{code} type LDerivDecl name = Located (DerivDecl name) -data DerivDecl name = DerivDecl { deriv_type :: LHsType name } +data DerivDecl name = DerivDecl { deriv_type :: LHsType name + , deriv_overlap_mode :: Maybe OverlapMode + } deriving (Data, Typeable) instance (OutputableBndr name) => Outputable (DerivDecl name) where - ppr (DerivDecl ty) - = hsep [ptext (sLit "deriving instance"), ppr ty] + ppr (DerivDecl ty o) + = hsep [ptext (sLit "deriving instance"), ppOverlapPragma o, ppr ty] \end{code} %************************************************************************ diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index aa7923f444..69b6df64ec 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -79,8 +79,6 @@ noSyntaxExpr = HsLit (HsString (fsLit "noSyntaxExpr")) type CmdSyntaxTable id = [(Name, SyntaxExpr id)] -- See Note [CmdSyntaxTable] -noSyntaxTable :: CmdSyntaxTable id -noSyntaxTable = [] \end{code} Note [CmdSyntaxtable] @@ -88,7 +86,7 @@ Note [CmdSyntaxtable] Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps track of the methods needed for a Cmd. -* Before the renamer, this list is 'noSyntaxTable' +* Before the renamer, this list is an empty list * After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ For example, for the 'arr' method diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index ae7866cf03..5d4d22fae2 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -1,10 +1,12 @@ +> {-# LANGUAGE ScopedTypeVariables #-} + % % (c) The University of Glasgow, 1992-2006 % Here we collect a variety of helper functions that construct or analyse HsSyn. All these functions deal with generic HsSyn; functions -which deal with the intantiated versions are located elsewhere: +which deal with the instantiated versions are located elsewhere: Parameterised by Module ---------------- ------------- @@ -100,7 +102,10 @@ import FastString import Util import Bag import Outputable + import Data.Either +import Data.Function +import Data.List \end{code} @@ -500,11 +505,13 @@ mkVarBind var rhs = L (getLoc rhs) $ VarBind { var_id = var, var_rhs = rhs, var_inline = False } mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName -mkPatSynBind name details lpat dir = PatSynBind{ patsyn_id = name - , patsyn_args = details - , patsyn_def = lpat - , patsyn_dir = dir - , bind_fvs = placeHolderNames } +mkPatSynBind name details lpat dir = PatSynBind psb + where + psb = PSB{ psb_id = name + , psb_args = details + , psb_def = lpat + , psb_dir = dir + , psb_fvs = placeHolderNames } ------------ mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] @@ -572,7 +579,7 @@ collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc -- I don't think we want the binders from the nested binds -- The only time we collect binders from a typechecked -- binding (hence see AbsBinds) is in zonking in TcHsSyn -collect_bind (PatSynBind { patsyn_id = L _ ps }) acc = ps : acc +collect_bind (PatSynBind (PSB { psb_id = L _ ps })) acc = ps : acc collectHsBindsBinders :: LHsBindsLR idL idR -> [idL] collectHsBindsBinders binds = collect_binds binds [] @@ -743,24 +750,26 @@ hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons -- See Note [Binders in family instances] ------------------- -hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name] +hsConDeclsBinders :: forall name. (Eq name) => [LConDecl name] -> [Located name] -- See hsLTyClDeclBinders for what this does -- The function is boringly complicated because of the records -- And since we only have equality, we have to be a little careful -hsConDeclsBinders cons - = snd (foldl do_one ([], []) cons) - where - do_one (flds_seen, acc) (L loc (ConDecl { con_name = L _ name - , con_details = RecCon flds })) - = (map unLoc new_flds ++ flds_seen, L loc name : new_flds ++ acc) - where +hsConDeclsBinders cons = go id cons + where go :: ([Located name] -> [Located name]) -> [LConDecl name] -> [Located name] + go _ [] = [] + go remSeen (r:rs) = -- don't re-mangle the location of field names, because we don't -- have a record of the full location of the field declaration anyway - new_flds = filterOut (\f -> unLoc f `elem` flds_seen) - (map cd_fld_name flds) + case r of + -- remove only the first occurrence of any seen field in order to + -- avoid circumventing detection of duplicate fields (#9156) + L loc (ConDecl { con_name = L _ name , con_details = RecCon flds }) -> + (L loc name) : r' ++ go remSeen' rs + where r' = remSeen (map cd_fld_name flds) + remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc) v | v <- r'] + L loc (ConDecl { con_name = L _ name }) -> + (L loc name) : go remSeen rs - do_one (flds_seen, acc) (L loc (ConDecl { con_name = L _ name })) - = (flds_seen, L loc name : acc) \end{code} Note [Binders in family instances] diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 9dd95fc0f2..4ec9ec7cbb 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -260,7 +260,7 @@ getSymbolTable bh ncu = do mapAccumR (fromOnDiskName arr) namecache od_names in (namecache', arr) -type OnDiskName = (PackageId, ModuleName, OccName) +type OnDiskName = (PackageKey, ModuleName, OccName) fromOnDiskName :: Array Int Name -> NameCache -> OnDiskName -> (NameCache, Name) fromOnDiskName _ nc (pid, mod_name, occ) = @@ -277,7 +277,7 @@ fromOnDiskName _ nc (pid, mod_name, occ) = serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () serialiseName bh name _ = do let mod = ASSERT2( isExternalName name, ppr name ) nameModule name - put_ bh (modulePackageId mod, moduleName mod, nameOccName name) + put_ bh (modulePackageKey mod, moduleName mod, nameOccName name) -- Note [Symbol table representation of names] diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index f2d6f7e39a..46091adf80 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -330,7 +330,7 @@ We cannot represent this by a newtype, even though it's not existential, because there are two value fields (the equality predicate and op. See Trac #2238 -Moreover, +Moreover, class (a ~ F b) => C a b where {} Here we can't use a newtype either, even though there is only one field, because equality predicates are unboxed, and classes diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 7b202acf7d..935b8eda93 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -168,9 +168,10 @@ data IfaceClassOp = IfaceClassOp IfaceTopBndr DefMethSpec IfaceType -- Just False => ordinary polymorphic default method -- Just True => generic default method -data IfaceAT = IfaceAT - IfaceDecl -- The associated type declaration - [IfaceAxBranch] -- Default associated type instances, if any +data IfaceAT = IfaceAT -- See Class.ClassATItem + IfaceDecl -- The associated type declaration + (Maybe IfaceType) -- Default associated type instance, if any + -- This is just like CoAxBranch data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] @@ -839,12 +840,12 @@ instance Outputable IfaceAT where ppr = pprIfaceAT showAll pprIfaceAT :: ShowSub -> IfaceAT -> SDoc -pprIfaceAT ss (IfaceAT d defs) +pprIfaceAT ss (IfaceAT d mb_def) = vcat [ pprIfaceDecl ss d - , ppUnless (null defs) $ nest 2 $ - ptext (sLit "Defaults:") <+> vcat (map (pprAxBranch pp_tc) defs) ] - where - pp_tc = ppr (ifName d) + , case mb_def of + Nothing -> empty + Just rhs -> nest 2 $ + ptext (sLit "Default:") <+> ppr rhs ] instance Outputable IfaceTyConParent where ppr p = pprIfaceTyConParent p @@ -1174,9 +1175,11 @@ freeNamesIfContext :: IfaceContext -> NameSet freeNamesIfContext = fnList freeNamesIfType freeNamesIfAT :: IfaceAT -> NameSet -freeNamesIfAT (IfaceAT decl defs) +freeNamesIfAT (IfaceAT decl mb_def) = freeNamesIfDecl decl &&& - fnList freeNamesIfAxBranch defs + case mb_def of + Nothing -> emptyNameSet + Just rhs -> freeNamesIfType rhs freeNamesIfClsSig :: IfaceClassOp -> NameSet freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 03ce53fff8..2be6e9d4d8 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -353,13 +353,13 @@ wantHiBootFile dflags eps mod from -- The boot-ness of the requested interface, -- based on the dependencies in directly-imported modules where - this_package = thisPackage dflags == modulePackageId mod + this_package = thisPackage dflags == modulePackageKey mod badSourceImport :: Module -> SDoc badSourceImport mod = hang (ptext (sLit "You cannot {-# SOURCE #-} import a module from another package")) 2 (ptext (sLit "but") <+> quotes (ppr mod) <+> ptext (sLit "is from package") - <+> quotes (ppr (modulePackageId mod))) + <+> quotes (ppr (modulePackageKey mod))) \end{code} Note [Care with plugin imports] @@ -573,7 +573,7 @@ findAndReadIface doc_str mod hi_boot_file (ml_hi_file loc) -- See Note [Home module load error] - if thisPackage dflags == modulePackageId mod && + if thisPackage dflags == modulePackageKey mod && not (isOneShot (ghcMode dflags)) then return (Failed (homeModError mod loc)) else do r <- read_file file_path @@ -876,7 +876,9 @@ badIfaceFile file err hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc hiModuleNameMismatchWarn requested_mod read_mod = - withPprStyle defaultUserStyle $ + -- ToDo: This will fail to have enough qualification when the package IDs + -- are the same + withPprStyle (mkUserStyle alwaysQualify AllTheWay) $ -- we want the Modules below to be qualified with package names, -- so reset the PrintUnqualified setting. hsep [ ptext (sLit "Something is amiss; requested module ") diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index b4d36aed91..1aba9eee44 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -218,12 +218,12 @@ mkDependencies -- on M.hi-boot, and hence that we should do the hi-boot consistency -- check.) - pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports) + pkgs | th_used = insertList thPackageKey (imp_dep_pkgs imports) | otherwise = imp_dep_pkgs imports -- Set the packages required to be Safe according to Safe Haskell. -- See Note [RnNames . Tracking Trust Transitively] - sorted_pkgs = sortBy stablePackageIdCmp pkgs + sorted_pkgs = sortBy stablePackageKeyCmp pkgs trust_pkgs = imp_trust_pkgs imports dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs @@ -559,7 +559,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- dependency tree. We only care about orphan modules in the current -- package, because changes to orphans outside this package will be -- tracked by the usage on the ABI hash of package modules that we import. - let orph_mods = filter ((== this_pkg) . modulePackageId) + let orph_mods = filter ((== this_pkg) . modulePackageKey) $ dep_orphs sorted_deps dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods @@ -661,7 +661,7 @@ getOrphanHashes hsc_env mods = do sortDependencies :: Dependencies -> Dependencies sortDependencies d = Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d), - dep_pkgs = sortBy (stablePackageIdCmp `on` fst) (dep_pkgs d), + dep_pkgs = sortBy (stablePackageKeyCmp `on` fst) (dep_pkgs d), dep_orphs = sortBy stableModuleCmp (dep_orphs d), dep_finsts = sortBy stableModuleCmp (dep_finsts d) } \end{code} @@ -989,7 +989,7 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names -- things in *this* module = Nothing - | modulePackageId mod /= this_pkg + | modulePackageKey mod /= this_pkg = Just UsagePackageModule{ usg_mod = mod, usg_mod_hash = mod_hash, usg_safe = imp_safe } @@ -1318,7 +1318,7 @@ checkDependencies hsc_env summary iface return (RecompBecause reason) else return UpToDate - where pkg = modulePackageId mod + where pkg = modulePackageKey mod _otherwise -> return (RecompBecause reason) needInterface :: Module -> (ModIface -> IfG RecompileRequired) @@ -1347,7 +1347,7 @@ needInterface mod continue -- | Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out -- whether M needs to be recompiled. -checkModUsage :: PackageId -> Usage -> IfG RecompileRequired +checkModUsage :: PackageKey -> Usage -> IfG RecompileRequired checkModUsage _this_pkg UsagePackageModule{ usg_mod = mod, usg_mod_hash = old_mod_hash } @@ -1476,7 +1476,7 @@ checkList (check:checks) = do recompile <- check \begin{code} tyThingToIfaceDecl :: TyThing -> IfaceDecl tyThingToIfaceDecl (AnId id) = idToIfaceDecl id -tyThingToIfaceDecl (ATyCon tycon) = tyConToIfaceDecl emptyTidyEnv tycon +tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon) tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax tyThingToIfaceDecl (AConLike cl) = case cl of RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only @@ -1568,48 +1568,52 @@ coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs -- See Note [CoAxBranch type variables] in CoAxiom ----------------- -tyConToIfaceDecl :: TidyEnv -> TyCon -> IfaceDecl +tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl) -- We *do* tidy TyCons, because they are not (and cannot -- conveniently be) built in tidy form +-- The returned TidyEnv is the one after tidying the tyConTyVars tyConToIfaceDecl env tycon | Just clas <- tyConClass_maybe tycon = classToIfaceDecl env clas | Just syn_rhs <- synTyConRhs_maybe tycon - = IfaceSyn { ifName = getOccName tycon, - ifTyVars = if_tc_tyvars, - ifRoles = tyConRoles tycon, - ifSynRhs = to_ifsyn_rhs syn_rhs, - ifSynKind = tidyToIfaceType tc_env1 (synTyConResKind tycon) } + = ( tc_env1 + , IfaceSyn { ifName = getOccName tycon, + ifTyVars = if_tc_tyvars, + ifRoles = tyConRoles tycon, + ifSynRhs = to_ifsyn_rhs syn_rhs, + ifSynKind = tidyToIfaceType tc_env1 (synTyConResKind tycon) }) | isAlgTyCon tycon - = IfaceData { ifName = getOccName tycon, - ifCType = tyConCType tycon, - ifTyVars = if_tc_tyvars, - ifRoles = tyConRoles tycon, - ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon), - ifCons = ifaceConDecls (algTyConRhs tycon), - ifRec = boolToRecFlag (isRecursiveTyCon tycon), - ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifPromotable = isJust (promotableTyCon_maybe tycon), - ifParent = parent } + = ( tc_env1 + , IfaceData { ifName = getOccName tycon, + ifCType = tyConCType tycon, + ifTyVars = if_tc_tyvars, + ifRoles = tyConRoles tycon, + ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon), + ifCons = ifaceConDecls (algTyConRhs tycon), + ifRec = boolToRecFlag (isRecursiveTyCon tycon), + ifGadtSyntax = isGadtSyntaxTyCon tycon, + ifPromotable = isJust (promotableTyCon_maybe tycon), + ifParent = parent }) | isForeignTyCon tycon - = IfaceForeign { ifName = getOccName tycon, - ifExtName = tyConExtName tycon } + = (env, IfaceForeign { ifName = getOccName tycon, + ifExtName = tyConExtName tycon }) - | otherwise + | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon -- For pretty printing purposes only. - = IfaceData { ifName = getOccName tycon, - ifCType = Nothing, - ifTyVars = funAndPrimTyVars, - ifRoles = tyConRoles tycon, - ifCtxt = [], - ifCons = IfDataTyCon [], - ifRec = boolToRecFlag False, - ifGadtSyntax = False, - ifPromotable = False, - ifParent = IfNoParent } + = ( env + , IfaceData { ifName = getOccName tycon, + ifCType = Nothing, + ifTyVars = funAndPrimTyVars, + ifRoles = tyConRoles tycon, + ifCtxt = [], + ifCons = IfDataTyCon [], + ifRec = boolToRecFlag False, + ifGadtSyntax = False, + ifPromotable = False, + ifParent = IfNoParent }) where (tc_env1, tc_tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon) if_tc_tyvars = toIfaceTvBndrs tc_tyvars @@ -1680,17 +1684,18 @@ toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env c toIfaceBang _ HsStrict = IfStrict toIfaceBang _ (HsUserBang {}) = panic "toIfaceBang" -classToIfaceDecl :: TidyEnv -> Class -> IfaceDecl +classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl) 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, - ifMinDef = fmap getFS (classMinimalDef clas), - ifRec = boolToRecFlag (isRecursiveTyCon tycon) } + = ( env1 + , 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, + ifMinDef = fmap getFS (classMinimalDef clas), + ifRec = boolToRecFlag (isRecursiveTyCon tycon) }) where (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff) = classExtraBigSig clas @@ -1699,8 +1704,10 @@ classToIfaceDecl env clas (env1, clas_tyvars') = tidyTyVarBndrs env clas_tyvars toIfaceAT :: ClassATItem -> IfaceAT - toIfaceAT (tc, defs) - = IfaceAT (tyConToIfaceDecl env1 tc) (map (coAxBranchToIfaceBranch' tc) defs) + toIfaceAT (ATI tc def) + = IfaceAT if_decl (fmap (tidyToIfaceType env2) def) + where + (env2, if_decl) = tyConToIfaceDecl env1 tc toIfaceClassOp (sel_id, def_meth) = ASSERT(sel_tyvars == clas_tyvars) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 867674b3e6..68f9e8fd65 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -344,26 +344,34 @@ tcHiBootIface hsc_src mod else do -- OK, so we're in one-shot mode. - -- In that case, we're read all the direct imports by now, - -- so eps_is_boot will record if any of our imports mention us by - -- way of hi-boot file - { eps <- getEps - ; case lookupUFM (eps_is_boot eps) (moduleName mod) of { - Nothing -> return emptyModDetails ; -- The typical case + -- Re #9245, we always check if there is an hi-boot interface + -- to check consistency against, rather than just when we notice + -- that an hi-boot is necessary due to a circular import. + { read_result <- findAndReadIface + need mod + True -- Hi-boot file - Just (_, False) -> failWithTc moduleLoop ; + ; case read_result of { + Succeeded (iface, _path) -> typecheckIface iface ; + Failed err -> + + -- There was no hi-boot file. But if there is circularity in + -- the module graph, there really should have been one. + -- Since we've read all the direct imports by now, + -- eps_is_boot will record if any of our imports mention the + -- current module, which either means a module loop (not + -- a SOURCE import) or that our hi-boot file has mysteriously + -- disappeared. + do { eps <- getEps + ; case lookupUFM (eps_is_boot eps) (moduleName mod) of + Nothing -> return emptyModDetails -- The typical case + + Just (_, False) -> failWithTc moduleLoop -- Someone below us imported us! -- This is a loop with no hi-boot in the way - Just (_mod, True) -> -- There's a hi-boot interface below us - - do { read_result <- findAndReadIface - need mod - True -- Hi-boot file - - ; case read_result of - Failed err -> failWithTc (elaborate err) - Succeeded (iface, _path) -> typecheckIface iface + Just (_mod, True) -> failWithTc (elaborate err) + -- The hi-boot file has mysteriously disappeared. }}}} where need = ptext (sLit "Need the hi-boot interface for") <+> ppr mod @@ -536,13 +544,18 @@ tc_iface_decl _parent ignore_prags -- it mentions unless it's necessary to do so ; return (op_name, dm, op_ty) } - tc_at cls (IfaceAT tc_decl defs_decls) + tc_at cls (IfaceAT tc_decl if_def) = do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl - defs <- forkM (mk_at_doc tc) (tc_ax_branches defs_decls) + mb_def <- case if_def of + Nothing -> return Nothing + Just def -> forkM (mk_at_doc tc) $ + extendIfaceTyVarEnv (tyConTyVars tc) $ + do { tc_def <- tcIfaceType def + ; return (Just tc_def) } -- 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) + return (ATI tc mb_def) mk_sc_doc pred = ptext (sLit "Superclass") <+> ppr pred mk_at_doc tc = ptext (sLit "Associated type") <+> ppr tc diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs index f92bd89c5c..24d0856ea3 100644 --- a/compiler/llvmGen/Llvm/AbsSyn.hs +++ b/compiler/llvmGen/Llvm/AbsSyn.hs @@ -65,6 +65,8 @@ data LlvmFunction = LlvmFunction { type LlvmFunctions = [LlvmFunction] +type SingleThreaded = Bool + -- | LLVM ordering types for synchronization purposes. (Introduced in LLVM -- 3.0). Please see the LLVM documentation for a better description. data LlvmSyncOrdering @@ -224,6 +226,11 @@ data LlvmExpression | Load LlvmVar {- | + Atomic load of the value at location ptr + -} + | ALoad LlvmSyncOrdering SingleThreaded LlvmVar + + {- | Navigate in an structure, selecting elements * inbound: Is the pointer inbounds? (computed pointer doesn't overflow) * ptr: Location of the structure diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index 025078226d..73077257f8 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -239,6 +239,7 @@ ppLlvmExpression expr Insert vec elt idx -> ppInsert vec elt idx GetElemPtr inb ptr indexes -> ppGetElementPtr inb ptr indexes Load ptr -> ppLoad ptr + ALoad ord st ptr -> ppALoad ord st ptr 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 @@ -327,13 +328,18 @@ ppSyncOrdering SyncSeqCst = text "seq_cst" -- of specifying alignment. ppLoad :: LlvmVar -> SDoc -ppLoad var - | isVecPtrVar var = text "load" <+> ppr var <> - comma <+> text "align 1" - | otherwise = text "load" <+> ppr var +ppLoad var = text "load" <+> ppr var <> align where - isVecPtrVar :: LlvmVar -> Bool - isVecPtrVar = isVector . pLower . getVarType + align | isVector . pLower . getVarType $ var = text ", align 1" + | otherwise = empty + +ppALoad :: LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc +ppALoad ord st var = sdocWithDynFlags $ \dflags -> + let alignment = (llvmWidthInBits dflags $ getVarType var) `quot` 8 + align = text ", align" <+> ppr alignment + sThreaded | st = text " singlethread" + | otherwise = empty + in text "load atomic" <+> ppr var <> sThreaded <+> ppSyncOrdering ord <> align ppStore :: LlvmVar -> LlvmVar -> SDoc ppStore val dst diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 686b352c2a..50cd824b24 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -406,7 +406,7 @@ strDisplayName_llvm lbl = do dflags <- getDynFlags let sdoc = pprCLabel platform lbl depth = Outp.PartWay 1 - style = Outp.mkUserStyle (\ _ _ -> Outp.NameNotInScope2, Outp.alwaysQualifyModules) depth + style = Outp.mkUserStyle Outp.reallyAlwaysQualify depth str = Outp.renderWithStyle dflags sdoc style return (fsLit (dropInfoSuffix str)) diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 517553516b..4a56600937 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -15,6 +15,7 @@ import BlockId import CodeGen.Platform ( activeStgRegs, callerSaves ) import CLabel import Cmm +import CPrim import PprCmm import CmmUtils import Hoopl @@ -32,6 +33,7 @@ import Unique import Data.List ( nub ) import Data.Maybe ( catMaybes ) +type Atomic = Bool type LlvmStatements = OrdList LlvmStatement -- ----------------------------------------------------------------------------- @@ -228,6 +230,17 @@ genCall t@(PrimTarget (MO_PopCnt w)) dsts args = genCall t@(PrimTarget (MO_BSwap w)) dsts args = genCallSimpleCast w t dsts args +genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = do + dstV <- getCmmReg (CmmLocal dst) + (v1, stmts, top) <- genLoad True addr (localRegType dst) + let stmt1 = Store v1 dstV + return (stmts `snocOL` stmt1, top) + +-- TODO: implement these properly rather than calling to RTS functions. +-- genCall t@(PrimTarget (MO_AtomicWrite width)) [] [addr, val] = undefined +-- genCall t@(PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = undefined +-- genCall t@(PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] = undefined + -- Handle memcpy function specifically since llvm's intrinsic version takes -- some extra parameters. genCall t@(PrimTarget op) [] args' @@ -548,7 +561,6 @@ cmmPrimOpFunctions mop = do (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch" - MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported MO_U_QuotRem2 {} -> unsupported @@ -558,6 +570,12 @@ cmmPrimOpFunctions mop = do MO_Touch -> unsupported MO_UF_Conv _ -> unsupported + MO_AtomicRead _ -> unsupported + + MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop + MO_Cmpxchg w -> fsLit $ cmpxchgLabel w + MO_AtomicWrite w -> fsLit $ atomicWriteLabel w + -- | Tail function calls genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData @@ -849,7 +867,7 @@ exprToVarOpt opt e = case e of -> genLit opt lit CmmLoad e' ty - -> genLoad e' ty + -> genLoad False e' ty -- Cmmreg in expression is the value, so must load. If you want actual -- reg pointer, call getCmmReg directly. @@ -1268,41 +1286,41 @@ genMachOp_slow _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!" -- | Handle CmmLoad expression. -genLoad :: CmmExpr -> CmmType -> LlvmM ExprData +genLoad :: Atomic -> 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 e@(CmmReg (CmmGlobal r)) ty - = genLoad_fast e r 0 ty +genLoad atomic e@(CmmReg (CmmGlobal r)) ty + = genLoad_fast atomic e r 0 ty -genLoad e@(CmmRegOff (CmmGlobal r) n) ty - = genLoad_fast e r n ty +genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty + = genLoad_fast atomic e r n ty -genLoad e@(CmmMachOp (MO_Add _) [ +genLoad atomic e@(CmmMachOp (MO_Add _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) ty - = genLoad_fast e r (fromInteger n) ty + = genLoad_fast atomic e r (fromInteger n) ty -genLoad e@(CmmMachOp (MO_Sub _) [ +genLoad atomic e@(CmmMachOp (MO_Sub _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) ty - = genLoad_fast e r (negate $ fromInteger n) ty + = genLoad_fast atomic e r (negate $ fromInteger n) ty -- generic case -genLoad e ty +genLoad atomic e ty = do other <- getTBAAMeta otherN - genLoad_slow e ty other + genLoad_slow atomic 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 :: CmmExpr -> GlobalReg -> Int -> CmmType - -> LlvmM ExprData -genLoad_fast e r n ty = do +genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType + -> LlvmM ExprData +genLoad_fast atomic e r n ty = do dflags <- getDynFlags (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) meta <- getTBAARegMeta r @@ -1315,7 +1333,7 @@ genLoad_fast e r n ty = do case grt == ty' of -- were fine True -> do - (var, s3) <- doExpr ty' (MExpr meta $ Load ptr) + (var, s3) <- doExpr ty' (MExpr meta $ loadInstr ptr) return (var, s1 `snocOL` s2 `snocOL` s3, []) @@ -1323,32 +1341,34 @@ genLoad_fast e r n ty = do False -> do let pty = pLift ty' (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty - (var, s4) <- doExpr ty' (MExpr meta $ Load ptr') + (var, s4) <- doExpr ty' (MExpr meta $ loadInstr 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 e ty meta - + False -> genLoad_slow atomic e ty meta + where + loadInstr ptr | atomic = ALoad SyncSeqCst False ptr + | otherwise = Load ptr -- | Handle Cmm load expression. -- Generic case. Uses casts and pointer arithmetic if needed. -genLoad_slow :: CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData -genLoad_slow e ty meta = do +genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData +genLoad_slow atomic e ty meta = do (iptr, stmts, tops) <- exprToVar e dflags <- getDynFlags case getVarType iptr of LMPointer _ -> do (dvar, load) <- doExpr (cmmToLlvmType ty) - (MExpr meta $ Load iptr) + (MExpr meta $ loadInstr 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) - (MExpr meta $ Load ptr) + (MExpr meta $ loadInstr ptr) return (dvar, stmts `snocOL` cast `snocOL` load, tops) other -> do dflags <- getDynFlags @@ -1357,6 +1377,9 @@ genLoad_slow e ty meta = do "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ ", Var: " ++ showSDoc dflags (ppr iptr))) + where + loadInstr ptr | atomic = ALoad SyncSeqCst False ptr + | otherwise = Load ptr -- | Handle CmmReg expression. This will return a pointer to the stack diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index c0a609ba2e..7a554f4d20 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -50,7 +50,7 @@ codeOutput :: DynFlags -> FilePath -> ModLocation -> ForeignStubs - -> [PackageId] + -> [PackageKey] -> Stream IO RawCmmGroup () -- Compiled C-- -> IO (FilePath, (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})) @@ -100,7 +100,7 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action outputC :: DynFlags -> FilePath -> Stream IO RawCmmGroup () - -> [PackageId] + -> [PackageKey] -> IO () outputC dflags filenm cmm_stream packages @@ -115,7 +115,7 @@ outputC dflags filenm cmm_stream packages -- * -#include options from the cmdline and OPTIONS pragmas -- * the _stub.h file, if there is one. -- - let rts = getPackageDetails (pkgState dflags) rtsPackageId + let rts = getPackageDetails dflags rtsPackageKey let cc_injects = unlines (map mk_include (includes rts)) mk_include h_file = @@ -210,7 +210,7 @@ outputForeignStubs dflags mod location stubs -- we need the #includes from the rts package for the stub files let rts_includes = - let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in + let rts_pkg = getPackageDetails dflags rtsPackageKey in concatMap mk_include (includes rts_pkg) mk_include i = "#include \"" ++ i ++ "\"\n" diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 11427e27cf..f7b5eb8782 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -390,7 +390,7 @@ link' dflags batch_attempt_linking hpt return Succeeded -linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [PackageId] -> IO Bool +linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [PackageKey] -> IO Bool linkingNeeded dflags staticLink linkables pkg_deps = do -- if the modification time on the executable is later than the -- modification times on all of the objects and libraries, then omit @@ -411,9 +411,8 @@ linkingNeeded dflags staticLink linkables pkg_deps = do -- next, check libraries. XXX this only checks Haskell libraries, -- not extra_libraries or -l things from the command line. - let pkg_map = pkgIdMap (pkgState dflags) - pkg_hslibs = [ (libraryDirs c, lib) - | Just c <- map (lookupPackage pkg_map) pkg_deps, + let pkg_hslibs = [ (libraryDirs c, lib) + | Just c <- map (lookupPackage dflags) pkg_deps, lib <- packageHsLibs dflags c ] pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs @@ -427,7 +426,7 @@ linkingNeeded dflags staticLink linkables pkg_deps = do -- Returns 'False' if it was, and we can avoid linking, because the -- previous binary was linked with "the same options". -checkLinkInfo :: DynFlags -> [PackageId] -> FilePath -> IO Bool +checkLinkInfo :: DynFlags -> [PackageKey] -> FilePath -> IO Bool checkLinkInfo dflags pkg_deps exe_file | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) -- ToDo: Windows and OS X do not use the ELF binary format, so @@ -1113,7 +1112,7 @@ runPhase (RealPhase cc_phase) input_fn dflags -- way we do the import depends on whether we're currently compiling -- the base package or not. ++ (if platformOS platform == OSMinGW32 && - thisPackage dflags == basePackageId + thisPackage dflags == basePackageKey then [ "-DCOMPILING_BASE_PACKAGE" ] else []) @@ -1559,7 +1558,7 @@ mkExtraObj dflags extn xs = do cFile <- newTempName dflags extn oFile <- newTempName dflags "o" writeFile cFile xs - let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId + let rtsDetails = getPackageDetails dflags rtsPackageKey SysTools.runCc dflags ([Option "-c", FileOption "" cFile, @@ -1608,7 +1607,7 @@ mkExtraObjToLinkIntoBinary dflags = do -- this was included as inline assembly in the main.c file but this -- is pretty fragile. gas gets upset trying to calculate relative offsets -- that span the .note section (notably .text) when debug info is present -mkNoteObjsToLinkIntoBinary :: DynFlags -> [PackageId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary :: DynFlags -> [PackageKey] -> IO [FilePath] mkNoteObjsToLinkIntoBinary dflags dep_packages = do link_info <- getLinkInfo dflags dep_packages @@ -1649,7 +1648,7 @@ mkNoteObjsToLinkIntoBinary dflags dep_packages = do -- link. We save this information in the binary, and the next time we -- link, if nothing else has changed, we use the link info stored in -- the existing binary to decide whether to re-link or not. -getLinkInfo :: DynFlags -> [PackageId] -> IO String +getLinkInfo :: DynFlags -> [PackageKey] -> IO String getLinkInfo dflags dep_packages = do package_link_opts <- getPackageLinkOpts dflags dep_packages pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags) @@ -1727,13 +1726,13 @@ mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $ ----------------------------------------------------------------------------- -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file -getHCFilePackages :: FilePath -> IO [PackageId] +getHCFilePackages :: FilePath -> IO [PackageKey] getHCFilePackages filename = Exception.bracket (openFile filename ReadMode) hClose $ \h -> do l <- hGetLine h case l of '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> - return (map stringToPackageId (words rest)) + return (map stringToPackageKey (words rest)) _other -> return [] @@ -1750,10 +1749,10 @@ getHCFilePackages filename = -- read any interface files), so the user must explicitly specify all -- the packages. -linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO () +linkBinary :: DynFlags -> [FilePath] -> [PackageKey] -> IO () linkBinary = linkBinary' False -linkBinary' :: Bool -> DynFlags -> [FilePath] -> [PackageId] -> IO () +linkBinary' :: Bool -> DynFlags -> [FilePath] -> [PackageKey] -> IO () linkBinary' staticLink dflags o_files dep_packages = do let platform = targetPlatform dflags mySettings = settings dflags @@ -2027,7 +2026,7 @@ maybeCreateManifest dflags exe_filename | otherwise = return [] -linkDynLibCheck :: DynFlags -> [String] -> [PackageId] -> IO () +linkDynLibCheck :: DynFlags -> [String] -> [PackageKey] -> IO () linkDynLibCheck dflags o_files dep_packages = do when (haveRtsOptsFlags dflags) $ do @@ -2037,7 +2036,7 @@ linkDynLibCheck dflags o_files dep_packages linkDynLib dflags o_files dep_packages -linkStaticLibCheck :: DynFlags -> [String] -> [PackageId] -> IO () +linkStaticLibCheck :: DynFlags -> [String] -> [PackageKey] -> IO () linkStaticLibCheck dflags o_files dep_packages = do when (platformOS (targetPlatform dflags) `notElem` [OSiOS, OSDarwin]) $ @@ -2166,7 +2165,9 @@ joinObjectFiles dflags o_files output_fn = do if ldIsGnuLd then do script <- newTempName dflags "ldscript" - writeFile script $ "INPUT(" ++ unwords o_files ++ ")" + cwd <- getCurrentDirectory + let o_files_abs = map (cwd </>) o_files + writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")" ld_r [SysTools.FileOption "" script] ccInfo else if sLdSupportsFilelist mySettings then do diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 122eafff19..74bd1397b8 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -43,7 +43,7 @@ module DynFlags ( targetRetainsAllBindings, GhcMode(..), isOneShot, GhcLink(..), isNoLink, - PackageFlag(..), + PackageFlag(..), PackageArg(..), ModRenaming, PkgConfRef(..), Option(..), showOpt, DynLibLoader(..), @@ -61,7 +61,7 @@ module DynFlags ( safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn, packageTrustOn, safeDirectImpsReq, safeImplicitImpsReq, - unsafeFlags, + unsafeFlags, unsafeFlagsForInfer, -- ** System tool settings and locations Settings(..), @@ -90,7 +90,7 @@ module DynFlags ( getVerbFlags, updOptLevel, setTmpDir, - setPackageName, + setPackageKey, -- ** Parsing DynFlags parseDynamicFlagsCmdLine, @@ -190,6 +190,8 @@ import Data.Word import System.FilePath import System.IO import System.IO.Error +import Text.ParserCombinators.ReadP hiding (char) +import Text.ParserCombinators.ReadP as R import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet @@ -269,6 +271,7 @@ data DumpFlag | Opt_D_dump_hi | Opt_D_dump_hi_diffs | Opt_D_dump_mod_cycles + | Opt_D_dump_mod_map | Opt_D_dump_view_pattern_commoning | Opt_D_verbose_core2core @@ -480,7 +483,6 @@ data SafeHaskellMode | Sf_Unsafe | Sf_Trustworthy | Sf_Safe - | Sf_SafeInferred deriving (Eq) instance Show SafeHaskellMode where @@ -488,7 +490,6 @@ instance Show SafeHaskellMode where show Sf_Unsafe = "Unsafe" show Sf_Trustworthy = "Trustworthy" show Sf_Safe = "Safe" - show Sf_SafeInferred = "Safe-Inferred" instance Outputable SafeHaskellMode where ppr = text . show @@ -630,7 +631,7 @@ data DynFlags = DynFlags { ctxtStkDepth :: Int, -- ^ Typechecker context stack depth tyFunStkDepth :: Int, -- ^ Typechecker type function stack depth - thisPackage :: PackageId, -- ^ name of package currently being compiled + thisPackage :: PackageKey, -- ^ name of package currently being compiled -- ways ways :: [Way], -- ^ Way flags from the command line @@ -737,11 +738,14 @@ data DynFlags = DynFlags { language :: Maybe Language, -- | Safe Haskell mode safeHaskell :: SafeHaskellMode, + safeInfer :: Bool, + safeInferred :: Bool, -- We store the location of where some extension and flags were turned on so -- we can produce accurate error messages when Safe Haskell fails due to -- them. thOnLoc :: SrcSpan, newDerivOnLoc :: SrcSpan, + overlapInstLoc :: SrcSpan, pkgTrustOnLoc :: SrcSpan, warnSafeOnLoc :: SrcSpan, warnUnsafeOnLoc :: SrcSpan, @@ -1019,9 +1023,15 @@ isNoLink :: GhcLink -> Bool isNoLink NoLink = True isNoLink _ = False +data PackageArg = PackageArg String + | PackageIdArg String + | PackageKeyArg String + deriving (Eq, Show) + +type ModRenaming = Maybe [(String, String)] + data PackageFlag - = ExposePackage String - | ExposePackageId String + = ExposePackage PackageArg ModRenaming | HidePackage String | IgnorePackage String | TrustPackage String @@ -1215,7 +1225,6 @@ wayOptl platform WayThreaded = -- the problems are our fault or theirs, but it seems that using the -- alternative 1:1 threading library libthr works around it: OSFreeBSD -> ["-lthr"] - OSSolaris2 -> ["-lrt"] OSOpenBSD -> ["-pthread"] OSNetBSD -> ["-pthread"] _ -> [] @@ -1352,7 +1361,7 @@ defaultDynFlags mySettings = ctxtStkDepth = mAX_CONTEXT_REDUCTION_DEPTH, tyFunStkDepth = mAX_TYPE_FUNCTION_REDUCTION_DEPTH, - thisPackage = mainPackageId, + thisPackage = mainPackageKey, objectDir = Nothing, dylibInstallName = Nothing, @@ -1417,9 +1426,12 @@ defaultDynFlags mySettings = warningFlags = IntSet.fromList (map fromEnum standardWarnings), ghciScripts = [], language = Nothing, - safeHaskell = Sf_SafeInferred, + safeHaskell = Sf_None, + safeInfer = True, + safeInferred = True, thOnLoc = noSrcSpan, newDerivOnLoc = noSrcSpan, + overlapInstLoc = noSrcSpan, pkgTrustOnLoc = noSrcSpan, warnSafeOnLoc = noSrcSpan, warnUnsafeOnLoc = noSrcSpan, @@ -1626,6 +1638,7 @@ dopt f dflags = (fromEnum f `IntSet.member` dumpFlags dflags) enableIfVerbose Opt_D_dump_ticked = False enableIfVerbose Opt_D_dump_view_pattern_commoning = False enableIfVerbose Opt_D_dump_mod_cycles = False + enableIfVerbose Opt_D_dump_mod_map = False enableIfVerbose _ = True -- | Set a 'DumpFlag' @@ -1702,7 +1715,7 @@ packageTrustOn = gopt Opt_PackageTrust -- | Is Safe Haskell on in some way (including inference mode) safeHaskellOn :: DynFlags -> Bool -safeHaskellOn dflags = safeHaskell dflags /= Sf_None +safeHaskellOn dflags = safeHaskell dflags /= Sf_None || safeInferOn dflags -- | Is the Safe Haskell safe language in use safeLanguageOn :: DynFlags -> Bool @@ -1710,7 +1723,7 @@ safeLanguageOn dflags = safeHaskell dflags == Sf_Safe -- | Is the Safe Haskell safe inference mode active safeInferOn :: DynFlags -> Bool -safeInferOn dflags = safeHaskell dflags == Sf_SafeInferred +safeInferOn = safeInfer -- | Test if Safe Imports are on in some form safeImportsOn :: DynFlags -> Bool @@ -1724,7 +1737,11 @@ setSafeHaskell s = updM f where f dfs = do let sf = safeHaskell dfs safeM <- combineSafeFlags sf s - return $ dfs { safeHaskell = safeM } + return $ case (s == Sf_Safe || s == Sf_Unsafe) of + True -> dfs { safeHaskell = safeM, safeInfer = False } + -- leave safe inferrence on in Trustworthy mode so we can warn + -- if it could have been inferred safe. + False -> dfs { safeHaskell = safeM } -- | Are all direct imports required to be safe for this Safe Haskell mode? -- Direct imports are when the code explicitly imports a module @@ -1741,9 +1758,7 @@ safeImplicitImpsReq d = safeLanguageOn d -- want to export this functionality from the module but do want to export the -- type constructors. combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode -combineSafeFlags a b | a == Sf_SafeInferred = return b - | b == Sf_SafeInferred = return a - | a == Sf_None = return b +combineSafeFlags a b | a == Sf_None = return b | b == Sf_None = return a | a == b = return a | otherwise = addErr errm >> return (panic errm) @@ -1755,13 +1770,19 @@ combineSafeFlags a b | a == Sf_SafeInferred = return b -- * function to get srcspan that enabled the flag -- * function to test if the flag is on -- * function to turn the flag off -unsafeFlags :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] +unsafeFlags, unsafeFlagsForInfer + :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] unsafeFlags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc, xopt Opt_GeneralizedNewtypeDeriving, flip xopt_unset Opt_GeneralizedNewtypeDeriving), ("-XTemplateHaskell", thOnLoc, xopt Opt_TemplateHaskell, flip xopt_unset Opt_TemplateHaskell)] +unsafeFlagsForInfer = unsafeFlags ++ + -- TODO: Can we do better than this for inference? + [("-XOverlappingInstances", overlapInstLoc, + xopt Opt_OverlappingInstances, + flip xopt_unset Opt_OverlappingInstances)] -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from @@ -2043,43 +2064,41 @@ updateWays dflags -- The bool is to indicate if we are parsing command line flags (false means -- file pragma). This allows us to generate better warnings. safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String]) -safeFlagCheck _ dflags | not (safeLanguageOn dflags || safeInferOn dflags) - = (dflags, []) - --- safe or safe-infer ON -safeFlagCheck cmdl dflags = - case safeLanguageOn dflags of - True -> (dflags', warns) +safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns) + where + -- Handle illegal flags under safe language. + (dflagsUnset, warns) = foldl check_method (dflags, []) unsafeFlags - -- throw error if -fpackage-trust by itself with no safe haskell flag - False | not cmdl && packageTrustOn dflags - -> (gopt_unset dflags' Opt_PackageTrust, - [L (pkgTrustOnLoc dflags') $ - "-fpackage-trust ignored;" ++ - " must be specified with a Safe Haskell flag"] - ) + check_method (df, warns) (str,loc,test,fix) + | test df = (fix df, warns ++ safeFailure (loc df) str) + | otherwise = (df, warns) - False | null warns && safeInfOk - -> (dflags', []) + safeFailure loc str + = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " + ++ str] - | otherwise - -> (dflags' { safeHaskell = Sf_None }, []) - -- Have we inferred Unsafe? - -- See Note [HscMain . Safe Haskell Inference] - where - -- TODO: Can we do better than this for inference? - safeInfOk = not $ xopt Opt_OverlappingInstances dflags +safeFlagCheck cmdl dflags = + case (safeInferOn dflags) of + True | safeFlags -> (dflags', warn) + True -> (dflags' { safeInferred = False }, warn) + False -> (dflags', warn) - (dflags', warns) = foldl check_method (dflags, []) unsafeFlags + where + -- dynflags and warn for when -fpackage-trust by itself with no safe + -- haskell flag + (dflags', warn) + | safeHaskell dflags == Sf_None && not cmdl && packageTrustOn dflags + = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg) + | otherwise = (dflags, []) - check_method (df, warns) (str,loc,test,fix) - | test df = (apFix fix df, warns ++ safeFailure (loc dflags) str) - | otherwise = (df, warns) + pkgWarnMsg = [L (pkgTrustOnLoc dflags') $ + "-fpackage-trust ignored;" ++ + " must be specified with a Safe Haskell flag"] - apFix f = if safeInferOn dflags then id else f + safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer + -- Have we inferred Unsafe? + -- See Note [HscMain . Safe Haskell Inference] - safeFailure loc str - = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " ++ str] {- ********************************************************************** %* * @@ -2364,6 +2383,7 @@ dynamic_flags = [ , Flag "ddump-hpc" (setDumpFlag Opt_D_dump_ticked) -- back compat , Flag "ddump-ticked" (setDumpFlag Opt_D_dump_ticked) , Flag "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles) + , Flag "ddump-mod-map" (setDumpFlag Opt_D_dump_mod_map) , Flag "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning) , Flag "ddump-to-file" (NoArg (setGeneralFlag Opt_DumpToFile)) , Flag "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs) @@ -2478,7 +2498,7 @@ dynamic_flags = [ ------ Safe Haskell flags ------------------------------------------- , Flag "fpackage-trust" (NoArg setPackageTrust) - , Flag "fno-safe-infer" (NoArg (setSafeHaskell Sf_None)) + , Flag "fno-safe-infer" (noArg (\d -> d { safeInfer = False } )) , Flag "fPIC" (NoArg (setGeneralFlag Opt_PIC)) , Flag "fno-PIC" (NoArg (unSetGeneralFlag Opt_PIC)) ] @@ -2517,9 +2537,13 @@ package_flags = [ removeUserPkgConf deprecate "Use -no-user-package-db instead") - , Flag "package-name" (hasArg setPackageName) + , Flag "package-name" (HasArg $ \name -> do + upd (setPackageKey name) + deprecate "Use -this-package-key instead") + , Flag "this-package-key" (hasArg setPackageKey) , Flag "package-id" (HasArg exposePackageId) , Flag "package" (HasArg exposePackage) + , Flag "package-key" (HasArg exposePackageKey) , Flag "hide-package" (HasArg hidePackage) , Flag "hide-all-packages" (NoArg (setGeneralFlag Opt_HideAllPackages)) , Flag "ignore-package" (HasArg ignorePackage) @@ -2872,7 +2896,9 @@ xFlags = [ deprecatedForExtension "MultiParamTypeClasses" ), ( "FunctionalDependencies", Opt_FunctionalDependencies, nop ), ( "GeneralizedNewtypeDeriving", Opt_GeneralizedNewtypeDeriving, setGenDeriving ), - ( "OverlappingInstances", Opt_OverlappingInstances, nop ), + ( "OverlappingInstances", Opt_OverlappingInstances, + \ turn_on -> when turn_on + $ deprecate "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS" ), ( "UndecidableInstances", Opt_UndecidableInstances, nop ), ( "IncoherentInstances", Opt_IncoherentInstances, nop ), ( "PackageImports", Opt_PackageImports, nop ), @@ -3327,11 +3353,39 @@ removeGlobalPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotGlobal . extra clearPkgConf :: DynP () clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] } -exposePackage, exposePackageId, hidePackage, ignorePackage, +parsePackageFlag :: (String -> PackageArg) -- type of argument + -> String -- string to parse + -> PackageFlag +parsePackageFlag constr str = case filter ((=="").snd) (readP_to_S parse str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str) + where parse = do + pkg <- munch1 (\c -> isAlphaNum c || c `elem` ":-_.") + (do _ <- tok $ R.char '(' + rns <- tok $ sepBy parseItem (tok $ R.char ',') + _ <- tok $ R.char ')' + return (ExposePackage (constr pkg) (Just rns)) + +++ + return (ExposePackage (constr pkg) Nothing)) + parseMod = munch1 (\c -> isAlphaNum c || c `elem` ".") + parseItem = do + orig <- tok $ parseMod + (do _ <- tok $ string "as" + new <- tok $ parseMod + return (orig, new) + +++ + return (orig, orig)) + tok m = skipSpaces >> m + +exposePackage, exposePackageId, exposePackageKey, hidePackage, ignorePackage, trustPackage, distrustPackage :: String -> DynP () exposePackage p = upd (exposePackage' p) exposePackageId p = - upd (\s -> s{ packageFlags = ExposePackageId p : packageFlags s }) + upd (\s -> s{ packageFlags = + parsePackageFlag PackageIdArg p : packageFlags s }) +exposePackageKey p = + upd (\s -> s{ packageFlags = + parsePackageFlag PackageKeyArg p : packageFlags s }) hidePackage p = upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) ignorePackage p = @@ -3343,10 +3397,11 @@ distrustPackage p = exposePackage p >> exposePackage' :: String -> DynFlags -> DynFlags exposePackage' p dflags - = dflags { packageFlags = ExposePackage p : packageFlags dflags } + = dflags { packageFlags = + parsePackageFlag PackageArg p : packageFlags dflags } -setPackageName :: String -> DynFlags -> DynFlags -setPackageName p s = s{ thisPackage = stringToPackageId p } +setPackageKey :: String -> DynFlags -> DynFlags +setPackageKey p s = s{ thisPackage = stringToPackageKey p } -- If we're linking a binary, then only targets that produce object -- code are allowed (requests for other target types are ignored). @@ -3398,10 +3453,10 @@ setMainIs arg | not (null main_fn) && isLower (head main_fn) -- The arg looked like "Foo.Bar.baz" = upd $ \d -> d{ mainFunIs = Just main_fn, - mainModIs = mkModule mainPackageId (mkModuleName main_mod) } + mainModIs = mkModule mainPackageKey (mkModuleName main_mod) } | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" - = upd $ \d -> d{ mainModIs = mkModule mainPackageId (mkModuleName arg) } + = upd $ \d -> d{ mainModIs = mkModule mainPackageKey (mkModuleName arg) } | otherwise -- The arg looked like "baz" = upd $ \d -> d{ mainFunIs = Just arg } @@ -3588,6 +3643,8 @@ compilerInfo dflags ("RTS ways", cGhcRTSWays), ("Support dynamic-too", if isWindows then "NO" else "YES"), ("Support parallel --make", "YES"), + ("Support reexported-modules", "YES"), + ("Uses package keys", "YES"), ("Dynamic by default", if dYNAMIC_BY_DEFAULT dflags then "YES" else "NO"), ("GHC Dynamic", if dynamicGhc diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 02f731d3c2..c43064e7f1 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -7,15 +7,18 @@ {-# LANGUAGE CPP #-} module ErrUtils ( + MsgDoc, + Validity(..), andValid, allValid, isValid, getInvalids, + ErrMsg, WarnMsg, Severity(..), Messages, ErrorMessages, WarningMessages, errMsgSpan, errMsgContext, errMsgShortDoc, errMsgExtraInfo, - MsgDoc, mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc, + mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc, pprLocErrMsg, makeIntoWarning, - + errorsFound, emptyMessages, isEmptyMessages, mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg, - printBagOfErrors, + printBagOfErrors, warnIsErrorMsg, mkLongWarnMsg, ghcExit, @@ -46,7 +49,7 @@ import DynFlags import System.Directory import System.Exit ( ExitCode(..), exitWith ) -import System.FilePath +import System.FilePath ( takeDirectory, (</>) ) import Data.List import qualified Data.Set as Set import Data.IORef @@ -56,6 +59,29 @@ import Control.Monad import Control.Monad.IO.Class import System.IO +------------------------- +type MsgDoc = SDoc + +------------------------- +data Validity + = IsValid -- Everything is fine + | NotValid MsgDoc -- A problem, and some indication of why + +isValid :: Validity -> Bool +isValid IsValid = True +isValid (NotValid {}) = False + +andValid :: Validity -> Validity -> Validity +andValid IsValid v = v +andValid v _ = v + +allValid :: [Validity] -> Validity -- If they aren't all valid, return the first +allValid [] = IsValid +allValid (v : vs) = v `andValid` allValid vs + +getInvalids :: [Validity] -> [MsgDoc] +getInvalids vs = [d | NotValid d <- vs] + -- ----------------------------------------------------------------------------- -- Basic error messages: just render a message with a source location. @@ -74,7 +100,6 @@ data ErrMsg = ErrMsg { -- The SrcSpan is used for sorting errors into line-number order type WarnMsg = ErrMsg -type MsgDoc = SDoc data Severity = SevOutput diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index cbfd4e4f1c..f9c7e2eee0 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -43,13 +43,12 @@ import Maybes ( expectJust ) import Exception ( evaluate ) import Distribution.Text -import Distribution.Package hiding (PackageId) import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef ) import System.Directory import System.FilePath import Control.Monad -import Data.List ( partition ) import Data.Time +import Data.List ( foldl' ) type FileExt = String -- Filename extension @@ -80,12 +79,12 @@ flushFinderCaches hsc_env = do fc_ref = hsc_FC hsc_env mlc_ref = hsc_MLC hsc_env -flushModLocationCache :: PackageId -> IORef ModLocationCache -> IO () +flushModLocationCache :: PackageKey -> IORef ModLocationCache -> IO () flushModLocationCache this_pkg ref = do atomicModifyIORef ref $ \fm -> (filterModuleEnv is_ext fm, ()) _ <- evaluate =<< readIORef ref return () - where is_ext mod _ | modulePackageId mod /= this_pkg = True + where is_ext mod _ | modulePackageKey mod /= this_pkg = True | otherwise = False addToFinderCache :: IORef FinderCache -> ModuleName -> FindResult -> IO () @@ -148,7 +147,7 @@ findImportedModule hsc_env mod_name mb_pkg = findExactModule :: HscEnv -> Module -> IO FindResult findExactModule hsc_env mod = let dflags = hsc_dflags hsc_env - in if modulePackageId mod == thisPackage dflags + in if modulePackageKey mod == thisPackage dflags then findHomeModule hsc_env (moduleName mod) else findPackageModule hsc_env mod @@ -190,41 +189,21 @@ homeSearchCache hsc_env mod_name do_this = do findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult findExposedPackageModule hsc_env mod_name mb_pkg - -- not found in any package: - = case lookupModuleWithSuggestions (hsc_dflags hsc_env) mod_name of - Left suggest -> return (NotFound { fr_paths = [], fr_pkg = Nothing - , fr_pkgs_hidden = [] - , fr_mods_hidden = [] - , fr_suggestions = suggest }) - Right found - | null found_exposed -- Found, but with no exposed copies - -> return (NotFound { fr_paths = [], fr_pkg = Nothing - , fr_pkgs_hidden = pkg_hiddens - , fr_mods_hidden = mod_hiddens - , fr_suggestions = [] }) - - | [(pkg_conf,_)] <- found_exposed -- Found uniquely - -> let pkgid = packageConfigId pkg_conf in - findPackageModule_ hsc_env (mkModule pkgid mod_name) pkg_conf - - | otherwise -- Found in more than one place - -> return (FoundMultiple (map (packageConfigId.fst) found_exposed)) - where - for_this_pkg = case mb_pkg of - Nothing -> found - Just p -> filter ((`matches` p) . fst) found - found_exposed = filter is_exposed for_this_pkg - is_exposed (pkg_conf,exposed_mod) = exposed pkg_conf && exposed_mod - - mod_hiddens = [ packageConfigId pkg_conf - | (pkg_conf,False) <- found ] - - pkg_hiddens = [ packageConfigId pkg_conf - | (pkg_conf,_) <- found, not (exposed pkg_conf) ] - - pkg_conf `matches` pkg - = case packageName pkg_conf of - PackageName n -> pkg == mkFastString n + = case lookupModuleWithSuggestions (hsc_dflags hsc_env) mod_name mb_pkg of + LookupFound m pkg_conf -> + findPackageModule_ hsc_env m pkg_conf + LookupMultiple rs -> + return (FoundMultiple rs) + LookupHidden pkg_hiddens mod_hiddens -> + return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = map (modulePackageKey.fst) pkg_hiddens + , fr_mods_hidden = map (modulePackageKey.fst) mod_hiddens + , fr_suggestions = [] }) + LookupNotFound suggest -> + return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_suggestions = suggest }) modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult modLocationCache hsc_env mod do_this = do @@ -295,15 +274,22 @@ findPackageModule :: HscEnv -> Module -> IO FindResult findPackageModule hsc_env mod = do let dflags = hsc_dflags hsc_env - pkg_id = modulePackageId mod - pkg_map = pkgIdMap (pkgState dflags) + pkg_id = modulePackageKey mod -- - case lookupPackage pkg_map pkg_id of + case lookupPackage dflags pkg_id of Nothing -> return (NoPackage pkg_id) Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf +-- | Look up the interface file associated with module @mod@. This function +-- requires a few invariants to be upheld: (1) the 'Module' in question must +-- be the module identifier of the *original* implementation of a module, +-- not a reexport (this invariant is upheld by @Packages.lhs@) and (2) +-- the 'PackageConfig' must be consistent with the package key in the 'Module'. +-- The redundancy is to avoid an extra lookup in the package state +-- for the appropriate config. findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindResult findPackageModule_ hsc_env mod pkg_conf = + ASSERT( modulePackageKey mod == packageConfigId pkg_conf ) modLocationCache hsc_env mod $ -- special case for GHC.Prim; we won't find it in the filesystem. @@ -373,7 +359,7 @@ searchPathExts paths mod exts ] search [] = return (NotFound { fr_paths = map fst to_search - , fr_pkg = Just (modulePackageId mod) + , fr_pkg = Just (modulePackageKey mod) , fr_mods_hidden = [], fr_pkgs_hidden = [] , fr_suggestions = [] }) @@ -548,18 +534,38 @@ cannotFindInterface = cantFindErr (sLit "Failed to load interface for") cantFindErr :: LitString -> LitString -> DynFlags -> ModuleName -> FindResult -> SDoc -cantFindErr _ multiple_found _ mod_name (FoundMultiple pkgs) +cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) + | Just pkgs <- unambiguousPackages = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( sep [ptext (sLit "it was found in multiple packages:"), - hsep (map (text.packageIdString) pkgs)] + hsep (map ppr pkgs) ] ) + | otherwise + = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( + vcat (map pprMod mods) + ) + where + unambiguousPackages = foldl' unambiguousPackage (Just []) mods + unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) + = Just (modulePackageKey m : xs) + unambiguousPackage _ _ = Nothing + + pprMod (m, o) = ptext (sLit "it is bound as") <+> ppr m <+> + ptext (sLit "by") <+> pprOrigin m o + pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" + pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( + if e == Just True + then [ptext (sLit "package") <+> ppr (modulePackageKey m)] + else [] ++ + map ((ptext (sLit "a reexport in package") <+>) + .ppr.packageConfigId) res ++ + if f then [ptext (sLit "a package flag")] else [] + ) + cantFindErr cannot_find _ dflags mod_name find_result = ptext cannot_find <+> quotes (ppr mod_name) $$ more_info where - pkg_map :: PackageConfigMap - pkg_map = pkgIdMap (pkgState dflags) - more_info = case find_result of NoPackage pkg @@ -615,7 +621,7 @@ cantFindErr cannot_find _ dflags mod_name find_result <> dot $$ cabal_pkg_hidden_hint pkg cabal_pkg_hidden_hint pkg | gopt Opt_BuildingCabalPackage dflags - = case simpleParse (packageIdString pkg) of + = case simpleParse (packageKeyString pkg) of Just pid -> ptext (sLit "Perhaps you need to add") <+> quotes (text (display (pkgName pid))) <+> @@ -626,22 +632,40 @@ cantFindErr cannot_find _ dflags mod_name find_result mod_hidden pkg = ptext (sLit "it is a hidden module in the package") <+> quotes (ppr pkg) - pp_suggestions :: [Module] -> SDoc + pp_suggestions :: [ModuleSuggestion] -> SDoc pp_suggestions sugs | null sugs = empty | otherwise = hang (ptext (sLit "Perhaps you meant")) - 2 (vcat [ vcat (map pp_exp exposed_sugs) - , vcat (map pp_hid hidden_sugs) ]) - where - (exposed_sugs, hidden_sugs) = partition from_exposed_pkg sugs - - from_exposed_pkg m = case lookupPackage pkg_map (modulePackageId m) of - Just pkg_config -> exposed pkg_config - Nothing -> WARN( True, ppr m ) -- Should not happen - False - - pp_exp mod = ppr (moduleName mod) - <+> parens (ptext (sLit "from") <+> ppr (modulePackageId mod)) - pp_hid mod = ppr (moduleName mod) - <+> parens (ptext (sLit "needs flag -package") <+> ppr (modulePackageId mod)) + 2 (vcat (map pp_sugg sugs)) + + -- NB: Prefer the *original* location, and then reexports, and then + -- package flags when making suggestions. ToDo: if the original package + -- also has a reexport, prefer that one + pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o + where provenance ModHidden = empty + provenance (ModOrigin{ fromOrigPackage = e, + fromExposedReexport = res, + fromPackageFlag = f }) + | Just True <- e + = parens (ptext (sLit "from") <+> ppr (modulePackageKey mod)) + | f && moduleName mod == m + = parens (ptext (sLit "from") <+> ppr (modulePackageKey mod)) + | (pkg:_) <- res + = parens (ptext (sLit "from") <+> ppr (packageConfigId pkg) + <> comma <+> ptext (sLit "reexporting") <+> ppr mod) + | f + = parens (ptext (sLit "defined via package flags to be") + <+> ppr mod) + | otherwise = empty + pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o + where provenance ModHidden = empty + provenance (ModOrigin{ fromOrigPackage = e, + fromHiddenReexport = rhs }) + | Just False <- e + = parens (ptext (sLit "needs flag -package-key") + <+> ppr (modulePackageKey mod)) + | (pkg:_) <- rhs + = parens (ptext (sLit "needs flag -package-key") + <+> ppr (packageConfigId pkg)) + | otherwise = empty \end{code} diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 13d4f87009..9ab52ebf1d 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -81,7 +81,7 @@ module GHC ( SafeHaskellMode(..), -- * Querying the environment - packageDbModules, + -- packageDbModules, -- * Printing PrintUnqualified, alwaysQualify, @@ -133,10 +133,10 @@ module GHC ( -- * Abstract syntax elements -- ** Packages - PackageId, + PackageKey, -- ** Modules - Module, mkModule, pprModule, moduleName, modulePackageId, + Module, mkModule, pprModule, moduleName, modulePackageKey, ModuleName, mkModuleName, moduleNameString, -- ** Names @@ -534,7 +534,7 @@ checkBrokenTablesNextToCode' dflags -- flags. If you are not doing linking or doing static linking, you -- can ignore the list of packages returned. -- -setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId] +setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageKey] setSessionDynFlags dflags = do (dflags', preload) <- liftIO $ initPackages dflags modifySession $ \h -> h{ hsc_dflags = dflags' @@ -543,7 +543,7 @@ setSessionDynFlags dflags = do return preload -- | Sets the program 'DynFlags'. -setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageId] +setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageKey] setProgramDynFlags dflags = do (dflags', preload) <- liftIO $ initPackages dflags modifySession $ \h -> h{ hsc_dflags = dflags' } @@ -1167,9 +1167,10 @@ getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) -- ----------------------------------------------------------------------------- +{- ToDo: Move the primary logic here to compiler/main/Packages.lhs -- | Return all /external/ modules available in the package database. -- Modules from the current session (i.e., from the 'HomePackageTable') are --- not included. +-- not included. This includes module names which are reexported by packages. packageDbModules :: GhcMonad m => Bool -- ^ Only consider exposed packages. -> m [Module] @@ -1177,10 +1178,13 @@ packageDbModules only_exposed = do dflags <- getSessionDynFlags let pkgs = eltsUFM (pkgIdMap (pkgState dflags)) return $ - [ mkModule pid modname | p <- pkgs - , not only_exposed || exposed p - , let pid = packageConfigId p - , modname <- exposedModules p ] + [ mkModule pid modname + | p <- pkgs + , not only_exposed || exposed p + , let pid = packageConfigId p + , modname <- exposedModules p + ++ map exportName (reexportedModules p) ] + -} -- ----------------------------------------------------------------------------- -- Misc exported utils @@ -1301,7 +1305,7 @@ showRichTokenStream ts = go startLoc ts "" -- ----------------------------------------------------------------------------- -- Interactive evaluation --- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the +-- | Takes a 'ModuleName' and possibly a 'PackageKey', and consults the -- filesystem and package database to find the corresponding 'Module', -- using the algorithm that is used for an @import@ declaration. findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module @@ -1311,7 +1315,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do this_pkg = thisPackage dflags -- case maybe_pkg of - Just pkg | fsToPackageId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do + Just pkg | fsToPackageKey pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg case res of Found _ m -> return m @@ -1323,7 +1327,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do Nothing -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg case res of - Found loc m | modulePackageId m /= this_pkg -> return m + Found loc m | modulePackageKey m /= this_pkg -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError $ noModError dflags noSrcSpan mod_name err @@ -1368,7 +1372,7 @@ isModuleTrusted m = withSession $ \hsc_env -> liftIO $ hscCheckSafe hsc_env m noSrcSpan -- | Return if a module is trusted and the pkgs it depends on to be trusted. -moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [PackageId]) +moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [PackageKey]) moduleTrustReqs m = withSession $ \hsc_env -> liftIO $ hscGetSafe hsc_env m noSrcSpan diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 694778115d..0c63203d4c 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -63,6 +63,7 @@ import qualified Data.Set as Set import qualified FiniteMap as Map ( insertListWith ) import Control.Concurrent ( forkIOWithUnmask, killThread ) +import qualified GHC.Conc as CC import Control.Concurrent.MVar import Control.Concurrent.QSem import Control.Exception @@ -80,6 +81,11 @@ import System.IO.Error ( isDoesNotExistError ) import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities ) +label_self :: String -> IO () +label_self thread_name = do + self_tid <- CC.myThreadId + CC.labelThread self_tid thread_name + -- ----------------------------------------------------------------------------- -- Loading the program @@ -744,10 +750,18 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do | ((ms,mvar,_),idx) <- comp_graph_w_idx ] + liftIO $ label_self "main --make thread" -- For each module in the module graph, spawn a worker thread that will -- compile this module. let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) -> forkIOWithUnmask $ \unmask -> do + liftIO $ label_self $ unwords + [ "worker --make thread" + , "for module" + , show (moduleNameString (ms_mod_name mod)) + , "number" + , show mod_idx + ] -- Replace the default log_action with one that writes each -- message to the module's log_queue. The main thread will -- deal with synchronously printing these messages. @@ -1786,7 +1800,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) just_found location mod | otherwise -> -- Drop external-pkg - ASSERT(modulePackageId mod /= thisPackage dflags) + ASSERT(modulePackageKey mod /= thisPackage dflags) return Nothing err -> return $ Just $ Left $ noModError dflags loc wanted_mod err diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index aef6007fb7..15d67fc882 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -407,19 +407,20 @@ tcRnModule' hsc_env sum save_rn_syntax mod = do tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_res) dflags <- getDynFlags + let allSafeOK = safeInferred dflags && tcSafeOK - -- end of the Safe Haskell line, how to respond to user? - if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK) - -- if safe haskell off or safe infer failed, wipe trust - then wipeTrust tcg_res emptyBag + -- end of the safe haskell line, how to respond to user? + if not (safeHaskellOn dflags) || (safeInferOn dflags && not allSafeOK) + -- if safe Haskell off or safe infer failed, mark unsafe + then markUnsafe tcg_res emptyBag - -- module safe, throw warning if needed + -- module (could be) safe, throw warning if needed else do tcg_res' <- hscCheckSafeImports tcg_res safe <- liftIO $ readIORef (tcg_safeInfer tcg_res') when (safe && wopt Opt_WarnSafe dflags) - (logWarnings $ unitBag $ - mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ errSafe tcg_res') + (logWarnings $ unitBag $ mkPlainWarnMsg dflags + (warnSafeOnLoc dflags) $ errSafe tcg_res') return tcg_res' where pprMod t = ppr $ moduleName $ tcg_mod t @@ -773,16 +774,15 @@ hscCheckSafeImports tcg_env = do tcg_env' <- checkSafeImports dflags tcg_env case safeLanguageOn dflags of True -> do - -- we nuke user written RULES in -XSafe + -- XSafe: we nuke user written RULES logWarnings $ warns dflags (tcg_rules tcg_env') return tcg_env' { tcg_rules = [] } False - -- user defined RULES, so not safe or already unsafe - | safeInferOn dflags && not (null $ tcg_rules tcg_env') || - safeHaskell dflags == Sf_None - -> wipeTrust tcg_env' $ warns dflags (tcg_rules tcg_env') + -- SafeInferred: user defined RULES, so not safe + | safeInferOn dflags && not (null $ tcg_rules tcg_env') + -> markUnsafe tcg_env' $ warns dflags (tcg_rules tcg_env') - -- trustworthy OR safe inferred with no RULES + -- Trustworthy OR SafeInferred: with no RULES | otherwise -> return tcg_env' @@ -828,7 +828,7 @@ checkSafeImports dflags tcg_env True -> -- did we fail safe inference or fail -XSafe? case safeInferOn dflags of - True -> wipeTrust tcg_env errs + True -> markUnsafe tcg_env errs False -> liftIO . throwIO . mkSrcErr $ errs -- All good matey! @@ -842,14 +842,16 @@ checkSafeImports dflags tcg_env imp_info = tcg_imports tcg_env -- ImportAvails imports = imp_mods imp_info -- ImportedMods imports' = moduleEnvToList imports -- (Module, [ImportedModsVal]) - pkg_reqs = imp_trust_pkgs imp_info -- [PackageId] + pkg_reqs = imp_trust_pkgs imp_info -- [PackageKey] condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) condense (_, []) = panic "HscMain.condense: Pattern match failure!" condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs -- we turn all imports into safe ones when -- inference mode is on. - let s' = if safeInferOn dflags then True else s + let s' = if safeInferOn dflags && + safeHaskell dflags == Sf_None + then True else s return (m, l, s') -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) @@ -879,7 +881,7 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do return $ isEmptyBag errs -- | Return if a module is trusted and the pkgs it depends on to be trusted. -hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [PackageId]) +hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [PackageKey]) hscGetSafe hsc_env m l = runHsc hsc_env $ do dflags <- getDynFlags (self, pkgs) <- hscCheckSafe' dflags m l @@ -893,15 +895,15 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do -- Return (regardless of trusted or not) if the trust type requires the modules -- own package be trusted and a list of other packages required to be trusted -- (these later ones haven't been checked) but the own package trust has been. -hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId, [PackageId]) +hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageKey, [PackageKey]) hscCheckSafe' dflags m l = do (tw, pkgs) <- isModSafe m l case tw of False -> return (Nothing, pkgs) True | isHomePkg m -> return (Nothing, pkgs) - | otherwise -> return (Just $ modulePackageId m, pkgs) + | otherwise -> return (Just $ modulePackageKey m, pkgs) where - isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageId]) + isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageKey]) isModSafe m l = do iface <- lookup' m case iface of @@ -915,7 +917,7 @@ hscCheckSafe' dflags m l = do let trust = getSafeMode $ mi_trust iface' trust_own_pkg = mi_trust_pkg iface' -- check module is trusted - safeM = trust `elem` [Sf_SafeInferred, Sf_Safe, Sf_Trustworthy] + safeM = trust `elem` [Sf_Safe, Sf_Trustworthy] -- check package is trusted safeP = packageTrusted trust trust_own_pkg m -- pkg trust reqs @@ -930,13 +932,13 @@ hscCheckSafe' dflags m l = do return (trust == Sf_Trustworthy, pkgRs) where - pkgTrustErr = unitBag $ mkPlainErrMsg dflags l $ + pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" - , text "The package (" <> ppr (modulePackageId m) + , text "The package (" <> ppr (modulePackageKey m) <> text ") the module resides in isn't trusted." ] - modTrustErr = unitBag $ mkPlainErrMsg dflags l $ + modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The module itself isn't safe." ] @@ -951,11 +953,9 @@ hscCheckSafe' dflags m l = do packageTrusted _ _ _ | not (packageTrustOn dflags) = True packageTrusted Sf_Safe False _ = True - packageTrusted Sf_SafeInferred False _ = True packageTrusted _ _ m | isHomePkg m = True - | otherwise = trusted $ getPackageDetails (pkgState dflags) - (modulePackageId m) + | otherwise = trusted $ getPackageDetails dflags (modulePackageKey m) lookup' :: Module -> Hsc (Maybe ModIface) lookup' m = do @@ -979,11 +979,11 @@ hscCheckSafe' dflags m l = do isHomePkg :: Module -> Bool isHomePkg m - | thisPackage dflags == modulePackageId m = True + | thisPackage dflags == modulePackageKey m = True | otherwise = False -- | Check the list of packages are trusted. -checkPkgTrust :: DynFlags -> [PackageId] -> Hsc () +checkPkgTrust :: DynFlags -> [PackageKey] -> Hsc () checkPkgTrust dflags pkgs = case errors of [] -> return () @@ -991,19 +991,20 @@ checkPkgTrust dflags pkgs = where errors = catMaybes $ map go pkgs go pkg - | trusted $ getPackageDetails (pkgState dflags) pkg + | trusted $ getPackageDetails dflags pkg = Nothing | otherwise - = Just $ mkPlainErrMsg dflags noSrcSpan + = Just $ mkErrMsg dflags noSrcSpan (pkgQual dflags) $ text "The package (" <> ppr pkg <> text ") is required" <> text " to be trusted but it isn't!" --- | Set module to unsafe and wipe trust information. +-- | Set module to unsafe and (potentially) wipe trust information. -- -- Make sure to call this method to set a module to inferred unsafe, --- it should be a central and single failure method. -wipeTrust :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv -wipeTrust tcg_env whyUnsafe = do +-- it should be a central and single failure method. We only wipe the trust +-- information when we aren't in a specific Safe Haskell mode. +markUnsafe :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv +markUnsafe tcg_env whyUnsafe = do dflags <- getDynFlags when (wopt Opt_WarnUnsafe dflags) @@ -1011,7 +1012,12 @@ wipeTrust tcg_env whyUnsafe = do mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) liftIO $ writeIORef (tcg_safeInfer tcg_env) False - return $ tcg_env { tcg_imports = wiped_trust } + -- NOTE: Only wipe trust when not in an explicity safe haskell mode. Other + -- times inference may be on but we are in Trustworthy mode -- so we want + -- to record safe-inference failed but not wipe the trust dependencies. + case safeHaskell dflags == Sf_None of + True -> return $ tcg_env { tcg_imports = wiped_trust } + False -> return tcg_env where wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] } @@ -1021,7 +1027,7 @@ wipeTrust tcg_env whyUnsafe = do , nest 4 $ (vcat $ badFlags df) $+$ (vcat $ pprErrMsgBagWithLoc whyUnsafe) ] - badFlags df = concat $ map (badFlag df) unsafeFlags + badFlags df = concat $ map (badFlag df) unsafeFlagsForInfer badFlag df (str,loc,on,_) | on df = [mkLocMessage SevOutput (loc df) $ text str <+> text "is not allowed in Safe Haskell"] @@ -1368,7 +1374,7 @@ hscStmtWithLocation hsc_env0 stmt source linenumber = handleWarnings -- Then code-gen, and link it - -- It's important NOT to have package 'interactive' as thisPackageId + -- It's important NOT to have package 'interactive' as thisPackageKey -- for linking, else we try to link 'main' and can't find it. -- Whereas the linker already knows to ignore 'interactive' let src_span = srcLocSpan interactiveSrcLoc diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 9738f590b6..123b0777fc 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -54,6 +54,7 @@ module HscTypes ( setInteractivePrintName, icInteractiveModule, InteractiveImport(..), setInteractivePackage, mkPrintUnqualified, pprModulePrefix, + mkQualPackage, mkQualModule, pkgQual, -- * Interfaces ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache, @@ -443,7 +444,7 @@ instance Outputable TargetId where -- | Helps us find information about modules in the home package type HomePackageTable = ModuleNameEnv HomeModInfo -- Domain = modules in the home package that have been fully compiled - -- "home" package name cached here for convenience + -- "home" package key cached here for convenience -- | Helps us find information about modules in the imported packages type PackageIfaceTable = ModuleEnv ModIface @@ -634,26 +635,26 @@ type FinderCache = ModuleNameEnv FindResult data FindResult = Found ModLocation Module -- ^ The module was found - | NoPackage PackageId + | NoPackage PackageKey -- ^ The requested package was not found - | FoundMultiple [PackageId] + | FoundMultiple [(Module, ModuleOrigin)] -- ^ _Error_: both in multiple packages -- | Not found | NotFound { fr_paths :: [FilePath] -- Places where I looked - , fr_pkg :: Maybe PackageId -- Just p => module is in this package's + , fr_pkg :: Maybe PackageKey -- Just p => module is in this package's -- manifest, but couldn't find -- the .hi file - , fr_mods_hidden :: [PackageId] -- Module is in these packages, + , fr_mods_hidden :: [PackageKey] -- Module is in these packages, -- but the *module* is hidden - , fr_pkgs_hidden :: [PackageId] -- Module is in these packages, + , fr_pkgs_hidden :: [PackageKey] -- Module is in these packages, -- but the *package* is hidden - , fr_suggestions :: [Module] -- Possible mis-spelled modules + , fr_suggestions :: [ModuleSuggestion] -- Possible mis-spelled modules } -- | Cache that remembers where we found a particular module. Contains both @@ -995,8 +996,8 @@ data ModGuts mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment -- These fields all describe the things **declared in this module** - mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module - -- ToDo: I'm unconvinced this is actually used anywhere + mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module. + -- Used for creating interface files. mg_tcs :: ![TyCon], -- ^ TyCons declared in this module -- (includes TyCons for classes) mg_insts :: ![ClsInst], -- ^ Class instances declared in this module @@ -1067,7 +1068,7 @@ data CgGuts -- as part of the code-gen of tycons cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs - cg_dep_pkgs :: ![PackageId], -- ^ Dependent packages, used to + cg_dep_pkgs :: ![PackageKey], -- ^ Dependent packages, used to -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information cg_modBreaks :: !ModBreaks -- ^ Module breakpoints @@ -1100,13 +1101,13 @@ appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) Note [The interactive package] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Type and class declarations at the command prompt are treated as if -they were defined in modules +Type, class, and value declarations at the command prompt are treated +as if they were defined in modules interactive:Ghci1 interactive:Ghci2 ...etc... with each bunch of declarations using a new module, all sharing a -common package 'interactive' (see Module.interactivePackageId, and +common package 'interactive' (see Module.interactivePackageKey, and PrelNames.mkInteractiveModule). This scheme deals well with shadowing. For example: @@ -1138,7 +1139,7 @@ The details are a bit tricky though: extend the HPT. * The 'thisPackage' field of DynFlags is *not* set to 'interactive'. - It stays as 'main' (or whatever -package-name says), and is the + It stays as 'main' (or whatever -this-package-key says), and is the package to which :load'ed modules are added to. * So how do we arrange that declarations at the command prompt get @@ -1148,14 +1149,15 @@ The details are a bit tricky though: turn get the module from it 'icInteractiveModule' field of the interactive context. - The 'thisPackage' field stays as 'main' (or whatever -package-name says. + The 'thisPackage' field stays as 'main' (or whatever -this-package-key says. * The main trickiness is that the type environment (tcg_type_env and - fixity envt (tcg_fix_env) now contains entities from all the - GhciN modules together, rather than just a single module as is usually - the case. So you can't use "nameIsLocalOrFrom" to decide whether - to look in the TcGblEnv vs the HPT/PTE. This is a change, but not - a problem provided you know. + fixity envt (tcg_fix_env), and instances (tcg_insts, tcg_fam_insts) + now contains entities from all the interactive-package modules + (Ghci1, Ghci2, ...) together, rather than just a single module as + is usually the case. So you can't use "nameIsLocalOrFrom" to + decide whether to look in the TcGblEnv vs the HPT/PTE. This is a + change, but not a problem provided you know. Note [Interactively-bound Ids in GHCi] @@ -1341,7 +1343,7 @@ extendInteractiveContext ictxt new_tythings setInteractivePackage :: HscEnv -> HscEnv -- Set the 'thisPackage' DynFlag to 'interactive' setInteractivePackage hsc_env - = hsc_env { hsc_dflags = (hsc_dflags hsc_env) { thisPackage = interactivePackageId } } + = hsc_env { hsc_dflags = (hsc_dflags hsc_env) { thisPackage = interactivePackageKey } } setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext setInteractivePrintName ic n = ic{ic_int_print = n} @@ -1408,11 +1410,28 @@ exposed (say P2), so we use M.T for that, and P1:M.T for the other one. This is handled by the qual_mod component of PrintUnqualified, inside the (ppr mod) of case (3), in Name.pprModulePrefix +Note [Printing package keys] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the old days, original names were tied to PackageIds, which directly +corresponded to the entities that users wrote in Cabal files, and were perfectly +suitable for printing when we need to disambiguate packages. However, with +PackageKey, the situation is different. First, the key is not a human readable +at all, so we need to consult the package database to find the appropriate +PackageId to display. Second, there may be multiple copies of a library visible +with the same PackageId, in which case we need to disambiguate. For now, +we just emit the actual package key (which the user can go look up); however, +another scheme is to (recursively) say which dependencies are different. + +NB: When we extend package keys to also have holes, we will have to disambiguate +those as well. + \begin{code} -- | Creates some functions that work out the best ways to format --- names for the user according to a set of heuristics +-- names for the user according to a set of heuristics. mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified -mkPrintUnqualified dflags env = (qual_name, qual_mod) +mkPrintUnqualified dflags env = QueryQualify qual_name + (mkQualModule dflags) + (mkQualPackage dflags) where qual_name mod occ | [gre] <- unqual_gres @@ -1445,18 +1464,48 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod) -- "import M" would resolve unambiguously to P:M. (if P is the -- current package we can just assume it is unqualified). - qual_mod mod - | modulePackageId mod == thisPackage dflags = False +-- | Creates a function for formatting modules based on two heuristics: +-- (1) if the module is the current module, don't qualify, and (2) if there +-- is only one exposed package which exports this module, don't qualify. +mkQualModule :: DynFlags -> QueryQualifyModule +mkQualModule dflags mod + | modulePackageKey mod == thisPackage dflags = False - | [pkgconfig] <- [pkg | (pkg,exposed_module) <- lookup, - exposed pkg && exposed_module], - packageConfigId pkgconfig == modulePackageId mod + | [(_, pkgconfig)] <- lookup, + packageConfigId pkgconfig == modulePackageKey mod -- this says: we are given a module P:M, is there just one exposed package -- that exposes a module M, and is it package P? = False | otherwise = True where lookup = lookupModuleInAllPackages dflags (moduleName mod) + +-- | Creates a function for formatting packages based on two heuristics: +-- (1) don't qualify if the package in question is "main", and (2) only qualify +-- with a package key if the package ID would be ambiguous. +mkQualPackage :: DynFlags -> QueryQualifyPackage +mkQualPackage dflags pkg_key + | pkg_key == mainPackageKey + -- Skip the lookup if it's main, since it won't be in the package + -- database! + = False + | searchPackageId dflags pkgid `lengthIs` 1 + -- this says: we are given a package pkg-0.1@MMM, are there only one + -- exposed packages whose package ID is pkg-0.1? + = False + | otherwise + = True + where pkg = fromMaybe (pprPanic "qual_pkg" (ftext (packageKeyFS pkg_key))) + (lookupPackage dflags pkg_key) + pkgid = sourcePackageId pkg + +-- | A function which only qualifies package names if necessary; but +-- qualifies all other identifiers. +pkgQual :: DynFlags -> PrintUnqualified +pkgQual dflags = alwaysQualify { + queryQualifyPackage = mkQualPackage dflags + } + \end{code} @@ -1904,7 +1953,7 @@ data Dependencies -- I.e. modules that this one imports, or that are in the -- dep_mods of those directly-imported modules - , dep_pkgs :: [(PackageId, Bool)] + , dep_pkgs :: [(PackageKey, Bool)] -- ^ All packages transitively below this module -- I.e. packages to which this module's direct imports belong, -- or that are in the dep_pkgs of those modules @@ -2493,14 +2542,15 @@ trustInfoToNum it Sf_Unsafe -> 1 Sf_Trustworthy -> 2 Sf_Safe -> 3 - Sf_SafeInferred -> 4 numToTrustInfo :: Word8 -> IfaceTrustInfo numToTrustInfo 0 = setSafeMode Sf_None numToTrustInfo 1 = setSafeMode Sf_Unsafe numToTrustInfo 2 = setSafeMode Sf_Trustworthy numToTrustInfo 3 = setSafeMode Sf_Safe -numToTrustInfo 4 = setSafeMode Sf_SafeInferred +numToTrustInfo 4 = setSafeMode Sf_Safe -- retained for backwards compat, used + -- to be Sf_SafeInfered but we no longer + -- differentiate. numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" instance Outputable IfaceTrustInfo where @@ -2508,7 +2558,6 @@ instance Outputable IfaceTrustInfo where ppr (TrustInfo Sf_Unsafe) = ptext $ sLit "unsafe" 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 diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index cfcc076235..d60cf56eba 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -879,7 +879,7 @@ getContext = withSession $ \HscEnv{ hsc_IC=ic } -> -- its full top-level scope available. moduleIsInterpreted :: GhcMonad m => Module -> m Bool moduleIsInterpreted modl = withSession $ \h -> - if modulePackageId modl /= thisPackage (hsc_dflags h) + if modulePackageKey modl /= thisPackage (hsc_dflags h) then return False else case lookupUFM (hsc_HPT h) (moduleName modl) of Just details -> return (isJust (mi_globals (hm_iface details))) diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs index 514a2e004f..864980be9d 100644 --- a/compiler/main/PackageConfig.hs +++ b/compiler/main/PackageConfig.hs @@ -9,8 +9,8 @@ module PackageConfig ( -- $package_naming - -- * PackageId - mkPackageId, packageConfigId, + -- * PackageKey + mkPackageKey, packageConfigId, -- * The PackageConfig type: information about a package PackageConfig, @@ -26,7 +26,8 @@ module PackageConfig ( import Distribution.InstalledPackageInfo import Distribution.ModuleName -import Distribution.Package hiding (PackageId) +import Distribution.Package hiding (PackageKey, mkPackageKey) +import qualified Distribution.Package as Cabal import Distribution.Text import Distribution.Version @@ -43,31 +44,33 @@ defaultPackageConfig :: PackageConfig defaultPackageConfig = emptyInstalledPackageInfo -- ----------------------------------------------------------------------------- --- PackageId (package names with versions) +-- PackageKey (package names, versions and dep hash) -- $package_naming -- #package_naming# --- Mostly the compiler deals in terms of 'PackageId's, which have the --- form @<pkg>-<version>@. You're expected to pass in the version for --- the @-package-name@ flag. However, for wired-in packages like @base@ --- & @rts@, we don't necessarily know what the version is, so these are --- handled specially; see #wired_in_packages#. +-- Mostly the compiler deals in terms of 'PackageKey's, which are md5 hashes +-- of a package ID, keys of its dependencies, and Cabal flags. You're expected +-- to pass in the package key in the @-this-package-key@ flag. However, for +-- wired-in packages like @base@ & @rts@, we don't necessarily know what the +-- version is, so these are handled specially; see #wired_in_packages#. --- | Turn a Cabal 'PackageIdentifier' into a GHC 'PackageId' -mkPackageId :: PackageIdentifier -> PackageId -mkPackageId = stringToPackageId . display +-- | Turn a Cabal 'PackageIdentifier' into a GHC 'PackageKey' +mkPackageKey :: Cabal.PackageKey -> PackageKey +mkPackageKey = stringToPackageKey . display --- | Get the GHC 'PackageId' right out of a Cabalish 'PackageConfig' -packageConfigId :: PackageConfig -> PackageId -packageConfigId = mkPackageId . sourcePackageId +-- | Get the GHC 'PackageKey' right out of a Cabalish 'PackageConfig' +packageConfigId :: PackageConfig -> PackageKey +packageConfigId = mkPackageKey . packageKey -- | Turn a 'PackageConfig', which contains GHC 'Module.ModuleName's into a Cabal specific -- 'InstalledPackageInfo' which contains Cabal 'Distribution.ModuleName.ModuleName's packageConfigToInstalledPackageInfo :: PackageConfig -> InstalledPackageInfo packageConfigToInstalledPackageInfo (pkgconf@(InstalledPackageInfo { exposedModules = e, + reexportedModules = r, hiddenModules = h })) = pkgconf{ exposedModules = map convert e, + reexportedModules = map (fmap convert) r, hiddenModules = map convert h } where convert :: Module.ModuleName -> Distribution.ModuleName.ModuleName convert = (expectJust "packageConfigToInstalledPackageInfo") . simpleParse . moduleNameString @@ -77,7 +80,9 @@ packageConfigToInstalledPackageInfo installedPackageInfoToPackageConfig :: InstalledPackageInfo_ String -> PackageConfig installedPackageInfoToPackageConfig (pkgconf@(InstalledPackageInfo { exposedModules = e, + reexportedModules = r, hiddenModules = h })) = pkgconf{ exposedModules = map mkModuleName e, + reexportedModules = map (fmap mkModuleName) r, hiddenModules = map mkModuleName h } diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index bb2e048cc3..78c8059046 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -2,21 +2,29 @@ % (c) The University of Glasgow, 2006 % \begin{code} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} -- | Package manipulation module Packages ( module PackageConfig, - -- * The PackageConfigMap - PackageConfigMap, emptyPackageConfigMap, lookupPackage, - extendPackageConfigMap, dumpPackages, simpleDumpPackages, - -- * Reading the package config, and processing cmdline args - PackageState(..), + PackageState(preloadPackages), initPackages, + + -- * Querying the package config + lookupPackage, + resolveInstalledPackageId, + searchPackageId, + dumpPackages, + simpleDumpPackages, getPackageDetails, - lookupModuleInAllPackages, lookupModuleWithSuggestions, + listVisibleModuleNames, + lookupModuleInAllPackages, + lookupModuleWithSuggestions, + LookupResult(..), + ModuleSuggestion(..), + ModuleOrigin(..), -- * Inspecting the set of packages in scope getPackageIncludePath, @@ -29,8 +37,12 @@ module Packages ( collectIncludeDirs, collectLibraryPaths, collectLinkOpts, packageHsLibs, + ModuleExport(..), -- * Utils + packageKeyPackageIdString, + pprFlag, + pprModuleMap, isDllName ) where @@ -51,10 +63,12 @@ import Maybes import System.Environment ( getEnv ) import Distribution.InstalledPackageInfo import Distribution.InstalledPackageInfo.Binary -import Distribution.Package hiding (PackageId,depends) +import Distribution.Package hiding (depends, PackageKey, mkPackageKey) +import Distribution.ModuleExport import FastString import ErrUtils ( debugTraceMsg, putMsg, MsgDoc ) import Exception +import Unique import System.Directory import System.FilePath as FilePath @@ -63,6 +77,7 @@ import Control.Monad import Data.Char (isSpace) import Data.List as List import Data.Map (Map) +import Data.Monoid hiding ((<>)) import qualified Data.Map as Map import qualified FiniteMap as Map import qualified Data.Set as Set @@ -75,12 +90,18 @@ import qualified Data.Set as Set -- provide. -- -- The package state is computed by 'initPackages', and kept in DynFlags. +-- It is influenced by various package flags: -- --- * @-package <pkg>@ causes @<pkg>@ to become exposed, and all other packages --- with the same name to become hidden. +-- * @-package <pkg>@ and @-package-id <pkg>@ cause @<pkg>@ to become exposed. +-- If @-hide-all-packages@ was not specified, these commands also cause +-- all other packages with the same name to become hidden. -- -- * @-hide-package <pkg>@ causes @<pkg>@ to become hidden. -- +-- * (there are a few more flags, check below for their semantics) +-- +-- The package state has the following properties. +-- -- * Let @exposedPackages@ be the set of packages thus exposed. -- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of -- their dependencies. @@ -109,39 +130,166 @@ import qualified Data.Set as Set -- When compiling A, we record in B's Module value whether it's -- in a different DLL, by setting the DLL flag. -data PackageState = PackageState { - pkgIdMap :: PackageConfigMap, -- PackageId -> PackageConfig - -- The exposed flags are adjusted according to -package and - -- -hide-package flags, and -ignore-package removes packages. - - preloadPackages :: [PackageId], - -- The packages we're going to link in eagerly. This list - -- should be in reverse dependency order; that is, a package - -- is always mentioned before the packages it depends on. - - moduleToPkgConfAll :: UniqFM [(PackageConfig,Bool)], -- ModuleEnv mapping - -- Derived from pkgIdMap. - -- Maps Module to (pkgconf,exposed), where pkgconf is the - -- PackageConfig for the package containing the module, and - -- exposed is True if the package exposes that module. +-- | Given a module name, there may be multiple ways it came into scope, +-- possibly simultaneously. This data type tracks all the possible ways +-- it could have come into scope. Warning: don't use the record functions, +-- they're partial! +data ModuleOrigin = + -- | Module is hidden, and thus never will be available for import. + -- (But maybe the user didn't realize), so we'll still keep track + -- of these modules.) + ModHidden + -- | Module is public, and could have come from some places. + | ModOrigin { + -- | @Just False@ means that this module is in + -- someone's @exported-modules@ list, but that package is hidden; + -- @Just True@ means that it is available; @Nothing@ means neither + -- applies. + fromOrigPackage :: Maybe Bool + -- | Is the module available from a reexport of an exposed package? + -- There could be multiple. + , fromExposedReexport :: [PackageConfig] + -- | Is the module available from a reexport of a hidden package? + , fromHiddenReexport :: [PackageConfig] + -- | Did the module export come from a package flag? (ToDo: track + -- more information. + , fromPackageFlag :: Bool + } + +instance Outputable ModuleOrigin where + ppr ModHidden = text "hidden module" + ppr (ModOrigin e res rhs f) = sep (punctuate comma ( + (case e of + Nothing -> [] + Just False -> [text "hidden package"] + Just True -> [text "exposed package"]) ++ + (if null res + then [] + else [text "reexport by" <+> + sep (map (ppr . packageConfigId) res)]) ++ + (if null rhs + then [] + else [text "hidden reexport by" <+> + sep (map (ppr . packageConfigId) res)]) ++ + (if f then [text "package flag"] else []) + )) + +-- | Smart constructor for a module which is in @exposed-modules@. Takes +-- as an argument whether or not the defining package is exposed. +fromExposedModules :: Bool -> ModuleOrigin +fromExposedModules e = ModOrigin (Just e) [] [] False + +-- | Smart constructor for a module which is in @reexported-modules@. Takes +-- as an argument whether or not the reexporting package is expsed, and +-- also its 'PackageConfig'. +fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin +fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False +fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False + +-- | Smart constructor for a module which was bound by a package flag. +fromFlag :: ModuleOrigin +fromFlag = ModOrigin Nothing [] [] True + +instance Monoid ModuleOrigin where + mempty = ModOrigin Nothing [] [] False + mappend (ModOrigin e res rhs f) (ModOrigin e' res' rhs' f') = + ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') + where g (Just b) (Just b') + | b == b' = Just b + | otherwise = panic "ModOrigin: package both exposed/hidden" + g Nothing x = x + g x Nothing = x + mappend _ _ = panic "ModOrigin: hidden module redefined" + +-- | Is the name from the import actually visible? (i.e. does it cause +-- ambiguity, or is it only relevant when we're making suggestions?) +originVisible :: ModuleOrigin -> Bool +originVisible ModHidden = False +originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f + +-- | Are there actually no providers for this module? This will never occur +-- except when we're filtering based on package imports. +originEmpty :: ModuleOrigin -> Bool +originEmpty (ModOrigin Nothing [] [] False) = True +originEmpty _ = False + +-- | When we do a plain lookup (e.g. for an import), initially, all we want +-- to know is if we can find it or not (and if we do and it's a reexport, +-- what the real name is). If the find fails, we'll want to investigate more +-- to give a good error message. +data SimpleModuleConf = + SModConf Module PackageConfig ModuleOrigin + | SModConfAmbiguous + +-- | 'UniqFM' map from 'ModuleName' +type ModuleNameMap = UniqFM + +-- | 'UniqFM' map from 'PackageKey' +type PackageKeyMap = UniqFM + +-- | 'UniqFM' map from 'PackageKey' to 'PackageConfig' +type PackageConfigMap = PackageKeyMap PackageConfig + +-- | 'UniqFM' map from 'PackageKey' to (1) whether or not all modules which +-- are exposed should be dumped into scope, (2) any custom renamings that +-- should also be apply, and (3) what package name is associated with the +-- key, if it might be hidden +type VisibilityMap = + PackageKeyMap (Bool, [(ModuleName, ModuleName)], FastString) + +-- | Map from 'ModuleName' to 'Module' to all the origins of the bindings +-- in scope. The 'PackageConf' is not cached, mostly for convenience reasons +-- (since this is the slow path, we'll just look it up again). +type ModuleToPkgConfAll = + Map ModuleName (Map Module ModuleOrigin) +data PackageState = PackageState { + -- | A mapping of 'PackageKey' to 'PackageConfig'. This list is adjusted + -- so that only valid packages are here. Currently, we also flip the + -- exposed/trusted bits based on package flags; however, the hope is to + -- stop doing that. + pkgIdMap :: PackageConfigMap, + + -- | The packages we're going to link in eagerly. This list + -- should be in reverse dependency order; that is, a package + -- is always mentioned before the packages it depends on. + preloadPackages :: [PackageKey], + + -- | This is a simplified map from 'ModuleName' to original 'Module' and + -- package configuration providing it. + moduleToPkgConf :: ModuleNameMap SimpleModuleConf, + + -- | This is a full map from 'ModuleName' to all modules which may possibly + -- be providing it. These providers may be hidden (but we'll still want + -- to report them in error messages), or it may be an ambiguous import. + moduleToPkgConfAll :: ModuleToPkgConfAll, + + -- | This is a map from 'InstalledPackageId' to 'PackageKey', since GHC + -- internally deals in package keys but the database may refer to installed + -- package IDs. installedPackageIdMap :: InstalledPackageIdMap } --- | A PackageConfigMap maps a 'PackageId' to a 'PackageConfig' -type PackageConfigMap = UniqFM PackageConfig - -type InstalledPackageIdMap = Map InstalledPackageId PackageId - +type InstalledPackageIdMap = Map InstalledPackageId PackageKey type InstalledPackageIndex = Map InstalledPackageId PackageConfig +-- | Empty package configuration map emptyPackageConfigMap :: PackageConfigMap emptyPackageConfigMap = emptyUFM --- | Find the package we know about with the given id (e.g. \"foo-1.0\"), if any -lookupPackage :: PackageConfigMap -> PackageId -> Maybe PackageConfig -lookupPackage = lookupUFM +-- | Find the package we know about with the given key (e.g. @foo_HASH@), if any +lookupPackage :: DynFlags -> PackageKey -> Maybe PackageConfig +lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags)) + +lookupPackage' :: PackageConfigMap -> PackageKey -> Maybe PackageConfig +lookupPackage' = lookupUFM + +-- | Search for packages with a given package ID (e.g. \"foo-0.1\") +searchPackageId :: DynFlags -> PackageId -> [PackageConfig] +searchPackageId dflags pid = filter ((pid ==) . sourcePackageId) + (listPackageConfigMap dflags) +-- | Extends the package configuration map with a list of package configs. extendPackageConfigMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap extendPackageConfigMap pkg_map new_pkgs @@ -150,8 +298,20 @@ extendPackageConfigMap pkg_map new_pkgs -- | Looks up the package with the given id in the package state, panicing if it is -- not found -getPackageDetails :: PackageState -> PackageId -> PackageConfig -getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdMap ps) pid) +getPackageDetails :: DynFlags -> PackageKey -> PackageConfig +getPackageDetails dflags pid = + expectJust "getPackageDetails" (lookupPackage dflags pid) + +-- | Get a list of entries from the package database. NB: be careful with +-- this function, it may not do what you expect it to. +listPackageConfigMap :: DynFlags -> [PackageConfig] +listPackageConfigMap dflags = eltsUFM (pkgIdMap (pkgState dflags)) + +-- | Looks up a 'PackageKey' given an 'InstalledPackageId' +resolveInstalledPackageId :: DynFlags -> InstalledPackageId -> PackageKey +resolveInstalledPackageId dflags ipid = + expectJust "resolveInstalledPackageId" + (Map.lookup ipid (installedPackageIdMap (pkgState dflags))) -- ---------------------------------------------------------------------------- -- Loading the package db files and building up the package state @@ -169,7 +329,7 @@ getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdM -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'pkgState' in 'DynFlags' and return a list of packages to -- link in. -initPackages :: DynFlags -> IO (DynFlags, [PackageId]) +initPackages :: DynFlags -> IO (DynFlags, [PackageKey]) initPackages dflags = do pkg_db <- case pkgDatabase dflags of Nothing -> readPackageConfigs dflags @@ -251,17 +411,12 @@ readPackageConfig dflags conf_file = do return pkg_configs2 setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig] -setBatchPackageFlags dflags pkgs = (maybeDistrustAll . maybeHideAll) pkgs +setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs where - maybeHideAll pkgs' - | gopt Opt_HideAllPackages dflags = map hide pkgs' - | otherwise = pkgs' - maybeDistrustAll pkgs' | gopt Opt_DistrustAllPackages dflags = map distrust pkgs' | otherwise = pkgs' - hide pkg = pkg{ exposed = False } distrust pkg = pkg{ trusted = False } -- TODO: This code is duplicated in utils/ghc-pkg/Main.hs @@ -318,75 +473,88 @@ mungePackagePaths top_dir pkgroot pkg = -- Modify our copy of the package database based on a package flag -- (-package, -hide-package, -ignore-package). +-- | A horrible hack, the problem is the package key we'll turn +-- up here is going to get edited when we select the wired in +-- packages, so preemptively pick up the right one. Also, this elem +-- test is slow. The alternative is to change wired in packages first, but +-- then we are no longer able to match against package keys e.g. from when +-- a user passes in a package flag. +calcKey :: PackageConfig -> PackageKey +calcKey p | pk <- display (pkgName (sourcePackageId p)) + , pk `elem` wired_in_pkgids + = stringToPackageKey pk + | otherwise = packageConfigId p + applyPackageFlag :: DynFlags -> UnusablePackages - -> [PackageConfig] -- Initial database + -> ([PackageConfig], VisibilityMap) -- Initial database -> PackageFlag -- flag to apply - -> IO [PackageConfig] -- new database + -> IO ([PackageConfig], VisibilityMap) -- new database -applyPackageFlag dflags unusable pkgs flag = - case flag of - ExposePackage str -> - case selectPackages (matchingStr str) pkgs unusable of - Left ps -> packageFlagErr dflags flag ps - Right (p:ps,qs) -> return (p':ps') - where p' = p {exposed=True} - ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) - _ -> panic "applyPackageFlag" +-- ToDo: Unfortunately, we still have to plumb the package config through, +-- because Safe Haskell trust is still implemented by modifying the database. +-- Eventually, track that separately and then axe @[PackageConfig]@ from +-- this fold entirely - ExposePackageId str -> - case selectPackages (matchingId str) pkgs unusable of +applyPackageFlag dflags unusable (pkgs, vm) flag = + case flag of + ExposePackage arg m_rns -> + case selectPackages (matching arg) pkgs unusable of Left ps -> packageFlagErr dflags flag ps - Right (p:ps,qs) -> return (p':ps') - where p' = p {exposed=True} - ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) + Right (p:_,_) -> return (pkgs, vm') + where + n = fsPackageName p + vm' = addToUFM_C edit vm_cleared (calcKey p) + (case m_rns of + Nothing -> (True, [], n) + Just rns' -> (False, map convRn rns', n)) + edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n) + convRn (a,b) = (mkModuleName a, mkModuleName b) + -- ToDo: ATM, -hide-all-packages implicitly triggers change in + -- behavior, maybe eventually make it toggleable with a separate + -- flag + vm_cleared | gopt Opt_HideAllPackages dflags = vm + -- NB: -package foo-0.1 (Foo as Foo1) does NOT hide + -- other versions of foo. Presence of renaming means + -- user probably wanted both. + | Just _ <- m_rns = vm + | otherwise = filterUFM_Directly + (\k (_,_,n') -> k == getUnique (calcKey p) + || n /= n') vm _ -> panic "applyPackageFlag" HidePackage str -> case selectPackages (matchingStr str) pkgs unusable of Left ps -> packageFlagErr dflags flag ps - Right (ps,qs) -> return (map hide ps ++ qs) - where hide p = p {exposed=False} + Right (ps,_) -> return (pkgs, vm') + where vm' = delListFromUFM vm (map calcKey ps) -- we trust all matching packages. Maybe should only trust first one? -- and leave others the same or set them untrusted TrustPackage str -> case selectPackages (matchingStr str) pkgs unusable of Left ps -> packageFlagErr dflags flag ps - Right (ps,qs) -> return (map trust ps ++ qs) + Right (ps,qs) -> return (map trust ps ++ qs, vm) where trust p = p {trusted=True} DistrustPackage str -> case selectPackages (matchingStr str) pkgs unusable of Left ps -> packageFlagErr dflags flag ps - Right (ps,qs) -> return (map distrust ps ++ qs) + Right (ps,qs) -> return (map distrust ps ++ qs, vm) where distrust p = p {trusted=False} - _ -> panic "applyPackageFlag" - - where - -- When a package is requested to be exposed, we hide all other - -- packages with the same name. - hideAll name ps = map maybe_hide ps - where maybe_hide p - | pkgName (sourcePackageId p) == name = p {exposed=False} - | otherwise = p - + IgnorePackage _ -> panic "applyPackageFlag: IgnorePackage" selectPackages :: (PackageConfig -> Bool) -> [PackageConfig] -> UnusablePackages -> Either [(PackageConfig, UnusablePackageReason)] ([PackageConfig], [PackageConfig]) selectPackages matches pkgs unusable - = let - (ps,rest) = partition matches pkgs - reasons = [ (p, Map.lookup (installedPackageId p) unusable) - | p <- ps ] - in - if all (isJust.snd) reasons - then Left [ (p, reason) | (p,Just reason) <- reasons ] - else Right (sortByVersion [ p | (p,Nothing) <- reasons ], rest) + = let (ps,rest) = partition matches pkgs + in if null ps + then Left (filter (matches.fst) (Map.elems unusable)) + else Right (sortByVersion ps, rest) -- A package named on the command line can either include the -- version, or just the name if it is unambiguous. @@ -398,6 +566,14 @@ matchingStr str p matchingId :: String -> PackageConfig -> Bool matchingId str p = InstalledPackageId str == installedPackageId p +matchingKey :: String -> PackageConfig -> Bool +matchingKey str p = str == display (packageKey p) + +matching :: PackageArg -> PackageConfig -> Bool +matching (PackageArg str) = matchingStr str +matching (PackageIdArg str) = matchingId str +matching (PackageKeyArg str) = matchingKey str + sortByVersion :: [InstalledPackageInfo_ m] -> [InstalledPackageInfo_ m] sortByVersion = sortBy (flip (comparing (pkgVersion.sourcePackageId))) @@ -411,7 +587,8 @@ packageFlagErr :: DynFlags -- for missing DPH package we emit a more helpful error message, because -- this may be the result of using -fdph-par or -fdph-seq. -packageFlagErr dflags (ExposePackage pkg) [] | is_dph_package pkg +packageFlagErr dflags (ExposePackage (PackageArg pkg) _) [] + | is_dph_package pkg = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err)) where dph_err = text "the " <> text pkg <> text " package is not installed." $$ text "To install it: \"cabal install dph\"." @@ -419,50 +596,37 @@ packageFlagErr dflags (ExposePackage pkg) [] | is_dph_package pkg packageFlagErr dflags flag reasons = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err)) - where err = text "cannot satisfy " <> ppr_flag <> + where err = text "cannot satisfy " <> pprFlag flag <> (if null reasons then empty else text ": ") $$ nest 4 (ppr_reasons $$ + -- ToDo: this admonition seems a bit dodgy text "(use -v for more information)") - ppr_flag = case flag of - IgnorePackage p -> text "-ignore-package " <> text p - HidePackage p -> text "-hide-package " <> text p - ExposePackage p -> text "-package " <> text p - ExposePackageId p -> text "-package-id " <> text p - TrustPackage p -> text "-trust " <> text p - DistrustPackage p -> text "-distrust " <> text p ppr_reasons = vcat (map ppr_reason reasons) ppr_reason (p, reason) = pprReason (pprIPkg p <+> text "is") reason --- ----------------------------------------------------------------------------- --- Hide old versions of packages - --- --- hide all packages for which there is also a later version --- that is already exposed. This just makes it non-fatal to have two --- versions of a package exposed, which can happen if you install a --- later version of a package in the user database, for example. --- -hideOldPackages :: DynFlags -> [PackageConfig] -> IO [PackageConfig] -hideOldPackages dflags pkgs = mapM maybe_hide pkgs - where maybe_hide p - | not (exposed p) = return p - | (p' : _) <- later_versions = do - debugTraceMsg dflags 2 $ - (ptext (sLit "hiding package") <+> pprSPkg p <+> - ptext (sLit "to avoid conflict with later version") <+> - pprSPkg p') - return (p {exposed=False}) - | otherwise = return p - where myname = pkgName (sourcePackageId p) - myversion = pkgVersion (sourcePackageId p) - later_versions = [ p | p <- pkgs, exposed p, - let pkg = sourcePackageId p, - pkgName pkg == myname, - pkgVersion pkg > myversion ] +pprFlag :: PackageFlag -> SDoc +pprFlag flag = case flag of + IgnorePackage p -> text "-ignore-package " <> text p + HidePackage p -> text "-hide-package " <> text p + ExposePackage a rns -> ppr_arg a <> ppr_rns rns + TrustPackage p -> text "-trust " <> text p + DistrustPackage p -> text "-distrust " <> text p + where ppr_arg arg = case arg of + PackageArg p -> text "-package " <> text p + PackageIdArg p -> text "-package-id " <> text p + PackageKeyArg p -> text "-package-key " <> text p + ppr_rns Nothing = empty + ppr_rns (Just rns) = char '(' <> hsep (punctuate comma (map ppr_rn rns)) + <> char ')' + ppr_rn (orig, new) | orig == new = text orig + | otherwise = text orig <+> text "as" <+> text new -- ----------------------------------------------------------------------------- -- Wired-in packages +wired_in_pkgids :: [String] +wired_in_pkgids = map packageKeyString wiredInPackageKeys + findWiredInPackages :: DynFlags -> [PackageConfig] -- database @@ -474,16 +638,6 @@ findWiredInPackages dflags pkgs = do -- their canonical names (eg. base-1.0 ==> base). -- let - wired_in_pkgids :: [String] - wired_in_pkgids = map packageIdString - [ primPackageId, - integerPackageId, - basePackageId, - rtsPackageId, - thPackageId, - dphSeqPackageId, - dphParPackageId ] - matches :: PackageConfig -> String -> Bool pc `matches` pid = display (pkgName (sourcePackageId pc)) == pid @@ -493,9 +647,10 @@ findWiredInPackages dflags pkgs = do -- one. -- -- When choosing which package to map to a wired-in package - -- name, we prefer exposed packages, and pick the latest - -- version. To override the default choice, -hide-package - -- could be used to hide newer versions. + -- name, we pick the latest version (modern Cabal makes it difficult + -- to install multiple versions of wired-in packages, however!) + -- To override the default choice, -ignore-package could be used to + -- hide newer versions. -- findWiredInPackage :: [PackageConfig] -> String -> IO (Maybe InstalledPackageId) @@ -542,7 +697,9 @@ findWiredInPackages dflags pkgs = do updateWiredInDependencies pkgs = map upd_pkg pkgs where upd_pkg p | installedPackageId p `elem` wired_in_ids - = p { sourcePackageId = (sourcePackageId p){ pkgVersion = Version [] [] } } + = let pid = (sourcePackageId p) { pkgVersion = Version [] [] } + in p { sourcePackageId = pid + , packageKey = OldPackageKey pid } | otherwise = p @@ -555,7 +712,8 @@ data UnusablePackageReason | MissingDependencies [InstalledPackageId] | ShadowedBy InstalledPackageId -type UnusablePackages = Map InstalledPackageId UnusablePackageReason +type UnusablePackages = Map InstalledPackageId + (PackageConfig, UnusablePackageReason) pprReason :: SDoc -> UnusablePackageReason -> SDoc pprReason pref reason = case reason of @@ -571,7 +729,7 @@ pprReason pref reason = case reason of reportUnusable :: DynFlags -> UnusablePackages -> IO () reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs) where - report (ipid, reason) = + report (ipid, (_, reason)) = debugTraceMsg dflags 2 $ pprReason (ptext (sLit "package") <+> @@ -591,7 +749,7 @@ findBroken pkgs = go [] Map.empty pkgs go avail ipids not_avail = case partitionWith (depsAvailable ipids) not_avail of ([], not_avail) -> - Map.fromList [ (installedPackageId p, MissingDependencies deps) + Map.fromList [ (installedPackageId p, (p, MissingDependencies deps)) | (p,deps) <- not_avail ] (new_avail, not_avail) -> go (new_avail ++ avail) new_ipids (map fst not_avail) @@ -620,19 +778,20 @@ shadowPackages pkgs preferred in Map.fromList shadowed where check (shadowed,pkgmap) pkg - | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg) + | Just oldpkg <- lookupUFM pkgmap pkgid , let ipid_new = installedPackageId pkg ipid_old = installedPackageId oldpkg -- , ipid_old /= ipid_new = if ipid_old `elem` preferred - then ( (ipid_new, ShadowedBy ipid_old) : shadowed, pkgmap ) - else ( (ipid_old, ShadowedBy ipid_new) : shadowed, pkgmap' ) + then ((ipid_new, (pkg, ShadowedBy ipid_old)) : shadowed, pkgmap) + else ((ipid_old, (oldpkg, ShadowedBy ipid_new)) : shadowed, pkgmap') | otherwise = (shadowed, pkgmap') where - pkgmap' = addToUFM pkgmap (packageConfigId pkg) pkg + pkgid = mkFastString (display (sourcePackageId pkg)) + pkgmap' = addToUFM pkgmap pkgid pkg -- ----------------------------------------------------------------------------- @@ -641,7 +800,7 @@ ignorePackages flags pkgs = Map.fromList (concatMap doit flags) where doit (IgnorePackage str) = case partition (matchingStr str) pkgs of - (ps, _) -> [ (installedPackageId p, IgnoredWithFlag) + (ps, _) -> [ (installedPackageId p, (p, IgnoredWithFlag)) | p <- ps ] -- missing package is not an error for -ignore-package, -- because a common usage is to -ignore-package P as @@ -669,11 +828,11 @@ depClosure index ipids = closure Map.empty ipids mkPackageState :: DynFlags -> [PackageConfig] -- initial database - -> [PackageId] -- preloaded packages - -> PackageId -- this package + -> [PackageKey] -- preloaded packages + -> PackageKey -- this package -> IO (PackageState, - [PackageId], -- new packages to preload - PackageId) -- this package, might be modified if the current + [PackageKey], -- new packages to preload + PackageKey) -- this package, might be modified if the current -- package is a wired-in package. mkPackageState dflags pkgs0 preload0 this_package = do @@ -684,12 +843,12 @@ mkPackageState dflags pkgs0 preload0 this_package = do 1. P = transitive closure of packages selected by -package-id 2. Apply shadowing. When there are multiple packages with the same - sourcePackageId, + packageKey, * if one is in P, use that one * otherwise, use the one highest in the package stack [ - rationale: we cannot use two packages with the same sourcePackageId - in the same program, because sourcePackageId is the symbol prefix. + rationale: we cannot use two packages with the same packageKey + in the same program, because packageKey is the symbol prefix. Hence we must select a consistent set of packages to use. We have a default algorithm for doing this: packages higher in the stack shadow those lower down. This default algorithm can be overriden @@ -737,30 +896,64 @@ mkPackageState dflags pkgs0 preload0 this_package = do ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ] - ipid_selected = depClosure ipid_map [ InstalledPackageId i - | ExposePackageId i <- flags ] + ipid_selected = depClosure ipid_map + [ InstalledPackageId i + | ExposePackage (PackageIdArg i) _ <- flags ] (ignore_flags, other_flags) = partition is_ignore flags is_ignore IgnorePackage{} = True is_ignore _ = False shadowed = shadowPackages pkgs0_unique ipid_selected - ignored = ignorePackages ignore_flags pkgs0_unique - pkgs0' = filter (not . (`Map.member` (Map.union shadowed ignored)) . installedPackageId) pkgs0_unique + isBroken = (`Map.member` (Map.union shadowed ignored)).installedPackageId + pkgs0' = filter (not . isBroken) pkgs0_unique + broken = findBroken pkgs0' + unusable = shadowed `Map.union` ignored `Map.union` broken + pkgs1 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs0' reportUnusable dflags unusable -- + -- Calculate the initial set of packages, prior to any package flags. + -- This set contains the latest version of all valid (not unusable) packages, + -- or is empty if we have -hide-all-packages + -- + let preferLater pkg pkg' = + case comparing (pkgVersion.sourcePackageId) pkg pkg' of + GT -> pkg + _ -> pkg' + calcInitial m pkg = addToUFM_C preferLater m (fsPackageName pkg) pkg + initial = if gopt Opt_HideAllPackages dflags + then emptyUFM + else foldl' calcInitial emptyUFM pkgs1 + vis_map0 = foldUFM (\p vm -> + if exposed p + then addToUFM vm (calcKey p) + (True, [], fsPackageName p) + else vm) + emptyUFM initial + + -- -- Modify the package database according to the command-line flags -- (-package, -hide-package, -ignore-package, -hide-all-packages). + -- This needs to know about the unusable packages, since if a user tries + -- to enable an unusable package, we should let them know. -- - pkgs1 <- foldM (applyPackageFlag dflags unusable) pkgs0_unique other_flags - let pkgs2 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs1 + (pkgs2, vis_map) <- foldM (applyPackageFlag dflags unusable) + (pkgs1, vis_map0) other_flags + -- + -- Sort out which packages are wired in. This has to be done last, since + -- it modifies the package keys of wired in packages, but when we process + -- package arguments we need to key against the old versions. + -- + pkgs3 <- findWiredInPackages dflags pkgs2 + + -- -- Here we build up a set of the packages mentioned in -package -- flags on the command line; these are called the "preload" -- packages. we link these packages in eagerly. The preload set @@ -769,22 +962,15 @@ mkPackageState dflags pkgs0 preload0 this_package = do -- let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ] - get_exposed (ExposePackage s) - = take 1 $ sortByVersion (filter (matchingStr s) pkgs2) - -- -package P means "the latest version of P" (#7030) - get_exposed (ExposePackageId s) = filter (matchingId s) pkgs2 - get_exposed _ = [] + get_exposed (ExposePackage a _) = take 1 . sortByVersion + . filter (matching a) + $ pkgs2 + get_exposed _ = [] - -- hide packages that are subsumed by later versions - pkgs3 <- hideOldPackages dflags pkgs2 - - -- sort out which packages are wired in - pkgs4 <- findWiredInPackages dflags pkgs3 - - let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs4 + let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs3 ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p) - | p <- pkgs4 ] + | p <- pkgs3 ] lookupIPID ipid@(InstalledPackageId str) | Just pid <- Map.lookup ipid ipid_map = return pid @@ -796,7 +982,8 @@ mkPackageState dflags pkgs0 preload0 this_package = do -- add base & rts to the preload packages basicLinkedPackages | gopt Opt_AutoLinkPackages dflags - = filter (flip elemUFM pkg_db) [basePackageId, rtsPackageId] + = filter (flip elemUFM pkg_db) + [basePackageKey, rtsPackageKey] | otherwise = [] -- but in any case remove the current package from the set of -- preloaded packages so that base/rts does not end up in the @@ -808,36 +995,118 @@ mkPackageState dflags pkgs0 preload0 this_package = do dep_preload <- closeDeps dflags pkg_db ipid_map (zip preload3 (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload - let pstate = PackageState{ preloadPackages = dep_preload, - pkgIdMap = pkg_db, - moduleToPkgConfAll = mkModuleMap pkg_db, - installedPackageIdMap = ipid_map - } - + let pstate = PackageState{ + preloadPackages = dep_preload, + pkgIdMap = pkg_db, + moduleToPkgConf = mkModuleToPkgConf dflags pkg_db ipid_map vis_map, + moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map, + installedPackageIdMap = ipid_map + } return (pstate, new_dep_preload, this_package) -- ----------------------------------------------------------------------------- --- Make the mapping from module to package info - -mkModuleMap - :: PackageConfigMap - -> UniqFM [(PackageConfig, Bool)] -mkModuleMap pkg_db = foldr extend_modmap emptyUFM pkgids - where - pkgids = map packageConfigId (eltsUFM pkg_db) - - extend_modmap pkgid modmap = - addListToUFM_C (++) modmap - ([(m, [(pkg, True)]) | m <- exposed_mods] ++ - [(m, [(pkg, False)]) | m <- hidden_mods]) - where - pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid) - exposed_mods = exposedModules pkg - hidden_mods = hiddenModules pkg - -pprSPkg :: PackageConfig -> SDoc -pprSPkg p = text (display (sourcePackageId p)) +-- | Makes the mapping from module to package info + +-- | This function is generic; we instantiate it +mkModuleToPkgConfGeneric + :: forall m e. + -- Empty map, e.g. the initial state of the output + m e + -- How to create an entry in the map based on the calculated information + -> (PackageKey -> ModuleName -> PackageConfig -> ModuleOrigin -> e) + -- How to override the origin of an entry (used for renaming) + -> (e -> ModuleOrigin -> e) + -- How to incorporate a list of entries into the map + -> (m e -> [(ModuleName, e)] -> m e) + -- The proper arguments + -> DynFlags + -> PackageConfigMap + -> InstalledPackageIdMap + -> VisibilityMap + -> m e +mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo + dflags pkg_db ipid_map vis_map = + foldl' extend_modmap emptyMap (eltsUFM pkg_db) + where + extend_modmap modmap pkg = addListTo modmap theBindings + where + theBindings :: [(ModuleName, e)] + theBindings | Just (b,rns,_) <- lookupUFM vis_map (packageConfigId pkg) + = newBindings b rns + | otherwise = newBindings False [] + + newBindings :: Bool -> [(ModuleName, ModuleName)] -> [(ModuleName, e)] + newBindings e rns = es e ++ hiddens ++ map rnBinding rns + + rnBinding :: (ModuleName, ModuleName) -> (ModuleName, e) + rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) + where origEntry = case lookupUFM esmap orig of + Just r -> r + Nothing -> throwGhcException (CmdLineError (showSDoc dflags + (text "package flag: could not find module name" <+> + ppr orig <+> text "in package" <+> ppr pk))) + + es :: Bool -> [(ModuleName, e)] + es e = + [(m, sing pk m pkg (fromExposedModules e)) | m <- exposed_mods] ++ + [(m, sing pk' m' pkg' (fromReexportedModules e pkg)) + | ModuleExport{ exportName = m + , exportCachedTrueOrig = Just (ipid', m')} <- reexported_mods + , let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map) + pkg' = pkg_lookup pk' ] + + esmap :: UniqFM e + esmap = listToUFM (es False) -- parameter here doesn't matter, orig will + -- be overwritten + + hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods] + + pk = packageConfigId pkg + pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db + + exposed_mods = exposedModules pkg + reexported_mods = reexportedModules pkg + hidden_mods = hiddenModules pkg + +-- | This is a quick and efficient module map, which only contains an entry +-- if it is specified unambiguously. +mkModuleToPkgConf + :: DynFlags + -> PackageConfigMap + -> InstalledPackageIdMap + -> VisibilityMap + -> ModuleNameMap SimpleModuleConf +mkModuleToPkgConf = + mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo + where emptyMap = emptyUFM + sing pk m pkg = SModConf (mkModule pk m) pkg + -- NB: don't put hidden entries in the map, they're not valid! + addListTo m xs = addListToUFM_C merge m (filter isVisible xs) + isVisible (_, SModConf _ _ o) = originVisible o + isVisible (_, SModConfAmbiguous) = False + merge (SModConf m pkg o) (SModConf m' _ o') + | m == m' = SModConf m pkg (o `mappend` o') + | otherwise = SModConfAmbiguous + merge _ _ = SModConfAmbiguous + setOrigins (SModConf m pkg _) os = SModConf m pkg os + setOrigins SModConfAmbiguous _ = SModConfAmbiguous + +-- | This is a slow and complete map, which includes information about +-- everything, including hidden modules +mkModuleToPkgConfAll + :: DynFlags + -> PackageConfigMap + -> InstalledPackageIdMap + -> VisibilityMap + -> ModuleToPkgConfAll +mkModuleToPkgConfAll = + mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo + where emptyMap = Map.empty + sing pk m _ = Map.singleton (mkModule pk m) + addListTo = foldl' merge + merge m (k, v) = Map.insertWith (Map.unionWith mappend) k v m + setOrigins m os = fmap (const os) m pprIPkg :: PackageConfig -> SDoc pprIPkg p = text (display (installedPackageId p)) @@ -854,7 +1123,7 @@ pprIPkg p = text (display (installedPackageId p)) -- use. -- | Find all the include directories in these and the preload packages -getPackageIncludePath :: DynFlags -> [PackageId] -> IO [String] +getPackageIncludePath :: DynFlags -> [PackageKey] -> IO [String] getPackageIncludePath dflags pkgs = collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs @@ -862,7 +1131,7 @@ collectIncludeDirs :: [PackageConfig] -> [FilePath] collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps)) -- | Find all the library paths in these and the preload packages -getPackageLibraryPath :: DynFlags -> [PackageId] -> IO [String] +getPackageLibraryPath :: DynFlags -> [PackageKey] -> IO [String] getPackageLibraryPath dflags pkgs = collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs @@ -871,7 +1140,7 @@ collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps)) -- | Find all the link options in these and the preload packages, -- returning (package hs lib options, extra library options, other flags) -getPackageLinkOpts :: DynFlags -> [PackageId] -> IO ([String], [String], [String]) +getPackageLinkOpts :: DynFlags -> [PackageKey] -> IO ([String], [String], [String]) getPackageLinkOpts dflags pkgs = collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs @@ -919,19 +1188,19 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) | otherwise = '_':t -- | Find all the C-compiler options in these and the preload packages -getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String] +getPackageExtraCcOpts :: DynFlags -> [PackageKey] -> IO [String] getPackageExtraCcOpts dflags pkgs = do ps <- getPreloadPackagesAnd dflags pkgs return (concatMap ccOptions ps) -- | Find all the package framework paths in these and the preload packages -getPackageFrameworkPath :: DynFlags -> [PackageId] -> IO [String] +getPackageFrameworkPath :: DynFlags -> [PackageKey] -> IO [String] getPackageFrameworkPath dflags pkgs = do ps <- getPreloadPackagesAnd dflags pkgs return (nub (filter notNull (concatMap frameworkDirs ps))) -- | Find all the package frameworks in these and the preload packages -getPackageFrameworks :: DynFlags -> [PackageId] -> IO [String] +getPackageFrameworks :: DynFlags -> [PackageKey] -> IO [String] getPackageFrameworks dflags pkgs = do ps <- getPreloadPackagesAnd dflags pkgs return (concatMap frameworks ps) @@ -939,41 +1208,114 @@ getPackageFrameworks dflags pkgs = do -- ----------------------------------------------------------------------------- -- Package Utils --- | Takes a 'Module', and if the module is in a package returns --- @(pkgconf, exposed)@ where pkgconf is the PackageConfig for that package, --- and exposed is @True@ if the package exposes the module. -lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(PackageConfig,Bool)] +-- | Takes a 'ModuleName', and if the module is in any package returns +-- list of modules which take that name. +lookupModuleInAllPackages :: DynFlags + -> ModuleName + -> [(Module, PackageConfig)] lookupModuleInAllPackages dflags m - = case lookupModuleWithSuggestions dflags m of - Right pbs -> pbs - Left _ -> [] - -lookupModuleWithSuggestions - :: DynFlags -> ModuleName - -> Either [Module] [(PackageConfig,Bool)] - -- Lookup module in all packages - -- Right pbs => found in pbs - -- Left ms => not found; but here are sugestions -lookupModuleWithSuggestions dflags m - = case lookupUFM (moduleToPkgConfAll pkg_state) m of - Nothing -> Left suggestions - Just ps -> Right ps + = case lookupModuleWithSuggestions dflags m Nothing of + LookupFound a b -> [(a,b)] + LookupMultiple rs -> map f rs + where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags + (modulePackageKey m))) + _ -> [] + +-- | The result of performing a lookup +data LookupResult = + -- | Found the module uniquely, nothing else to do + LookupFound Module PackageConfig + -- | Multiple modules with the same name in scope + | LookupMultiple [(Module, ModuleOrigin)] + -- | No modules found, but there were some hidden ones with + -- an exact name match. First is due to package hidden, second + -- is due to module being hidden + | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)] + -- | Nothing found, here are some suggested different names + | LookupNotFound [ModuleSuggestion] -- suggestions + +data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin + | SuggestHidden ModuleName Module ModuleOrigin + +lookupModuleWithSuggestions :: DynFlags + -> ModuleName + -> Maybe FastString + -> LookupResult +lookupModuleWithSuggestions dflags m mb_pn + = case lookupUFM (moduleToPkgConf pkg_state) m of + Just (SModConf m pkg o) | matches mb_pn pkg o -> + ASSERT( originVisible o ) LookupFound m pkg + _ -> case Map.lookup m (moduleToPkgConfAll pkg_state) of + Nothing -> LookupNotFound suggestions + Just xs -> + case foldl' classify ([],[],[]) (Map.toList xs) of + ([], [], []) -> LookupNotFound suggestions + -- NB: Yes, we have to check this case too, since package qualified + -- imports could cause the main lookup to fail due to ambiguity, + -- but the second lookup to succeed. + (_, _, [(m, _)]) -> LookupFound m (mod_pkg m) + (_, _, exposed@(_:_)) -> LookupMultiple exposed + (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod where + classify (hidden_pkg, hidden_mod, exposed) (m, origin0) = + let origin = filterOrigin mb_pn (mod_pkg m) origin0 + x = (m, origin) + in case origin of + ModHidden -> (hidden_pkg, x:hidden_mod, exposed) + _ | originEmpty origin -> (hidden_pkg, hidden_mod, exposed) + | originVisible origin -> (hidden_pkg, hidden_mod, x:exposed) + | otherwise -> (x:hidden_pkg, hidden_mod, exposed) + + pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags pkg_state = pkgState dflags + mod_pkg = pkg_lookup . modulePackageKey + + matches Nothing _ _ = True -- shortcut for efficiency + matches mb_pn pkg o = originVisible (filterOrigin mb_pn pkg o) + + -- Filters out origins which are not associated with the given package + -- qualifier. No-op if there is no package qualifier. Test if this + -- excluded all origins with 'originEmpty'. + filterOrigin :: Maybe FastString + -> PackageConfig + -> ModuleOrigin + -> ModuleOrigin + filterOrigin Nothing _ o = o + filterOrigin (Just pn) pkg o = + case o of + ModHidden -> if go pkg then ModHidden else mempty + ModOrigin { fromOrigPackage = e, fromExposedReexport = res, + fromHiddenReexport = rhs } + -> ModOrigin { + fromOrigPackage = if go pkg then e else Nothing + , fromExposedReexport = filter go res + , fromHiddenReexport = filter go rhs + , fromPackageFlag = False -- always excluded + } + where go pkg = pn == fsPackageName pkg + suggestions | gopt Opt_HelpfulErrors dflags = fuzzyLookup (moduleNameString m) all_mods | otherwise = [] - all_mods :: [(String, Module)] -- All modules - all_mods = [ (moduleNameString mod_nm, mkModule pkg_id mod_nm) - | pkg_config <- eltsUFM (pkgIdMap pkg_state) - , let pkg_id = packageConfigId pkg_config - , mod_nm <- exposedModules pkg_config ] + all_mods :: [(String, ModuleSuggestion)] -- All modules + all_mods = sortBy (comparing fst) $ + [ (moduleNameString m, suggestion) + | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags)) + , suggestion <- map (getSuggestion m) (Map.toList e) + ] + getSuggestion name (mod, origin) = + (if originVisible origin then SuggestVisible else SuggestHidden) + name mod origin + +listVisibleModuleNames :: DynFlags -> [ModuleName] +listVisibleModuleNames dflags = + Map.keys (moduleToPkgConfAll (pkgState dflags)) -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of -- 'PackageConfig's -getPreloadPackagesAnd :: DynFlags -> [PackageId] -> IO [PackageConfig] +getPreloadPackagesAnd :: DynFlags -> [PackageKey] -> IO [PackageConfig] getPreloadPackagesAnd dflags pkgids = let state = pkgState dflags @@ -983,15 +1325,15 @@ getPreloadPackagesAnd dflags pkgids = pairs = zip pkgids (repeat Nothing) in do all_pkgs <- throwErr dflags (foldM (add_package pkg_map ipid_map) preload pairs) - return (map (getPackageDetails state) all_pkgs) + return (map (getPackageDetails dflags) all_pkgs) -- Takes a list of packages, and returns the list with dependencies included, -- in reverse dependency order (a package appears before those it depends on). closeDeps :: DynFlags -> PackageConfigMap - -> Map InstalledPackageId PackageId - -> [(PackageId, Maybe PackageId)] - -> IO [PackageId] + -> Map InstalledPackageId PackageKey + -> [(PackageKey, Maybe PackageKey)] + -> IO [PackageKey] closeDeps dflags pkg_map ipid_map ps = throwErr dflags (closeDepsErr pkg_map ipid_map ps) @@ -1002,22 +1344,22 @@ throwErr dflags m Succeeded r -> return r closeDepsErr :: PackageConfigMap - -> Map InstalledPackageId PackageId - -> [(PackageId,Maybe PackageId)] - -> MaybeErr MsgDoc [PackageId] + -> Map InstalledPackageId PackageKey + -> [(PackageKey,Maybe PackageKey)] + -> MaybeErr MsgDoc [PackageKey] closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps -- internal helper add_package :: PackageConfigMap - -> Map InstalledPackageId PackageId - -> [PackageId] - -> (PackageId,Maybe PackageId) - -> MaybeErr MsgDoc [PackageId] + -> Map InstalledPackageId PackageKey + -> [PackageKey] + -> (PackageKey,Maybe PackageKey) + -> MaybeErr MsgDoc [PackageKey] add_package pkg_db ipid_map ps (p, mb_parent) | p `elem` ps = return ps -- Check if we've already added this package | otherwise = - case lookupPackage pkg_db p of - Nothing -> Failed (missingPackageMsg (packageIdString p) <> + case lookupPackage' pkg_db p of + Nothing -> Failed (missingPackageMsg (packageKeyString p) <> missingDependencyMsg mb_parent) Just pkg -> do -- Add the package's dependents also @@ -1037,15 +1379,22 @@ missingPackageErr dflags p missingPackageMsg :: String -> SDoc missingPackageMsg p = ptext (sLit "unknown package:") <+> text p -missingDependencyMsg :: Maybe PackageId -> SDoc +missingDependencyMsg :: Maybe PackageKey -> SDoc missingDependencyMsg Nothing = empty missingDependencyMsg (Just parent) - = space <> parens (ptext (sLit "dependency of") <+> ftext (packageIdFS parent)) + = space <> parens (ptext (sLit "dependency of") <+> ftext (packageKeyFS parent)) -- ----------------------------------------------------------------------------- +packageKeyPackageIdString :: DynFlags -> PackageKey -> String +packageKeyPackageIdString dflags pkg_key + | pkg_key == mainPackageKey = "main" + | otherwise = maybe "(unknown)" + (display . sourcePackageId) + (lookupPackage dflags pkg_key) + -- | Will the 'Name' come from a dynamically linked library? -isDllName :: DynFlags -> PackageId -> Module -> Name -> Bool +isDllName :: DynFlags -> PackageKey -> 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 @@ -1086,11 +1435,10 @@ dumpPackages = dumpPackages' showInstalledPackageInfo dumpPackages' :: (InstalledPackageInfo -> String) -> DynFlags -> IO () dumpPackages' showIPI dflags - = do let pkg_map = pkgIdMap (pkgState dflags) - putMsg dflags $ + = do putMsg dflags $ vcat (map (text . showIPI . packageConfigToInstalledPackageInfo) - (eltsUFM pkg_map)) + (listPackageConfigMap dflags)) -- | Show simplified package info on console, if verbosity == 4. -- The idea is to only print package id, and any information that might @@ -1102,4 +1450,18 @@ simpleDumpPackages = dumpPackages' showIPI t = if trusted ipi then "T" else " " in e ++ t ++ " " ++ i +-- | Show the mapping of modules to where they come from. +pprModuleMap :: DynFlags -> SDoc +pprModuleMap dflags = + vcat (map pprLine (Map.toList (moduleToPkgConfAll (pkgState dflags)))) + where + pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e))) + pprEntry m (m',o) + | m == moduleName m' = ppr (modulePackageKey m') <+> parens (ppr o) + | otherwise = ppr m' <+> parens (ppr o) + +fsPackageName :: PackageConfig -> FastString +fsPackageName pkg = case packageName (sourcePackageId pkg) of + PackageName n -> mkFastString n + \end{code} diff --git a/compiler/main/Packages.lhs-boot b/compiler/main/Packages.lhs-boot index 3a1712e2da..3fd0fd5422 100644 --- a/compiler/main/Packages.lhs-boot +++ b/compiler/main/Packages.lhs-boot @@ -1,4 +1,8 @@ \begin{code} module Packages where +-- Well, this is kind of stupid... +import {-# SOURCE #-} Module (PackageKey) +import {-# SOURCE #-} DynFlags (DynFlags) data PackageState +packageKeyPackageIdString :: DynFlags -> PackageKey -> String \end{code} diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index d993ab87c8..eed4671b67 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -7,19 +7,12 @@ ----------------------------------------------------------------------------- {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module PprTyThing ( - pprTyThing, - pprTyThingInContext, - pprTyThingLoc, - pprTyThingInContextLoc, - pprTyThingHdr, + pprTyThing, + pprTyThingInContext, + pprTyThingLoc, + pprTyThingInContextLoc, + pprTyThingHdr, pprTypeForUser, pprFamInst ) where @@ -159,9 +152,9 @@ pprTypeForUser :: Type -> SDoc -- b) Swizzle the foralls to the top, so that without -- -fprint-explicit-foralls we'll suppress all the foralls -- Prime example: a class op might have type --- forall a. C a => forall b. Ord b => stuff +-- forall a. C a => forall b. Ord b => stuff -- Then we want to display --- (C a, Ord b) => stuff +-- (C a, Ord b) => stuff pprTypeForUser ty = pprSigmaType (mkSigmaTy tvs ctxt tau) where @@ -175,6 +168,6 @@ pprTypeForUser ty showWithLoc :: SDoc -> SDoc -> SDoc showWithLoc loc doc = hang doc 2 (char '\t' <> comment <+> loc) - -- The tab tries to make them line up a bit + -- The tab tries to make them line up a bit where comment = ptext (sLit "--") diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 51d5af137c..1c1c52cd1f 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -235,6 +235,8 @@ initSysTools mbMinusB -- to make that possible, so for now you can't. gcc_prog <- getSetting "C compiler command" gcc_args_str <- getSetting "C compiler flags" + cpp_prog <- getSetting "Haskell CPP command" + cpp_args_str <- getSetting "Haskell CPP flags" let unreg_gcc_args = if targetUnregisterised then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] else [] @@ -243,6 +245,7 @@ initSysTools mbMinusB | mkTablesNextToCode targetUnregisterised = ["-DTABLES_NEXT_TO_CODE"] | otherwise = [] + cpp_args= map Option (words cpp_args_str) gcc_args = map Option (words gcc_args_str ++ unreg_gcc_args ++ tntc_gcc_args) @@ -285,10 +288,7 @@ initSysTools mbMinusB -- cpp is derived from gcc on all platforms -- HACK, see setPgmP below. We keep 'words' here to remember to fix -- Config.hs one day. - let cpp_prog = gcc_prog - cpp_args = Option "-E" - : map Option (words cRAWCPP_FLAGS) - ++ gcc_args + -- Other things being equal, as and ld are simply gcc gcc_link_args_str <- getSetting "C compiler link flags" @@ -825,7 +825,57 @@ runLink dflags args = do args1 = map Option (getOpts dflags opt_l) args2 = args0 ++ args1 ++ args ++ linkargs mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "Linker" p args2 mb_env + runSomethingFiltered dflags ld_filter "Linker" p args2 mb_env + where + ld_filter = case (platformOS (targetPlatform dflags)) of + OSSolaris2 -> sunos_ld_filter + _ -> id +{- + SunOS/Solaris ld emits harmless warning messages about unresolved + symbols in case of compiling into shared library when we do not + link against all the required libs. That is the case of GHC which + does not link against RTS library explicitly in order to be able to + choose the library later based on binary application linking + parameters. The warnings look like: + +Undefined first referenced + symbol in file +stg_ap_n_fast ./T2386_Lib.o +stg_upd_frame_info ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o +newCAF ./T2386_Lib.o +stg_bh_upd_frame_info ./T2386_Lib.o +stg_ap_ppp_fast ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o +stg_ap_p_fast ./T2386_Lib.o +stg_ap_pp_fast ./T2386_Lib.o +ld: warning: symbol referencing errors + + this is actually coming from T2386 testcase. The emitting of those + warnings is also a reason why so many TH testcases fail on Solaris. + + Following filter code is SunOS/Solaris linker specific and should + filter out only linker warnings. Please note that the logic is a + little bit more complex due to the simple reason that we need to preserve + any other linker emitted messages. If there are any. Simply speaking + if we see "Undefined" and later "ld: warning:..." then we omit all + text between (including) the marks. Otherwise we copy the whole output. +-} + sunos_ld_filter :: String -> String + sunos_ld_filter = unlines . sunos_ld_filter' . lines + sunos_ld_filter' x = if (undefined_found x && ld_warning_found x) + then (ld_prefix x) ++ (ld_postfix x) + else x + breakStartsWith x y = break (isPrefixOf x) y + ld_prefix = fst . breakStartsWith "Undefined" + undefined_found = not . null . snd . breakStartsWith "Undefined" + ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors" + ld_postfix = tail . snd . ld_warn_break + ld_warning_found = not . null . snd . ld_warn_break + runLibtool :: DynFlags -> [Option] -> IO () runLibtool dflags args = do @@ -1316,7 +1366,7 @@ linesPlatform xs = #endif -linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () +linkDynLib :: DynFlags -> [String] -> [PackageKey] -> IO () linkDynLib dflags0 o_files dep_packages = do let -- This is a rather ugly hack to fix dynamically linked @@ -1362,7 +1412,7 @@ linkDynLib dflags0 o_files dep_packages OSMinGW32 -> pkgs _ -> - filter ((/= rtsPackageId) . packageConfigId) pkgs + filter ((/= rtsPackageKey) . packageConfigId) pkgs let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts in package_hs_libs ++ extra_libs ++ other_flags @@ -1464,7 +1514,7 @@ linkDynLib dflags0 o_files dep_packages ------------------------------------------------------------------- let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - let buildingRts = thisPackage dflags == rtsPackageId + let buildingRts = thisPackage dflags == rtsPackageKey let bsymbolicFlag = if buildingRts then -- -Bsymbolic breaks the way we implement -- hooks in the RTS diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 7d47330044..6f24e3afb8 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -1019,7 +1019,7 @@ tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds ------------------------ tidyTopBind :: DynFlags - -> PackageId + -> PackageKey -> Module -> Id -> UnfoldEnv @@ -1189,7 +1189,7 @@ 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 -> Module +hasCafRefs :: DynFlags -> PackageKey -> Module -> (Id, VarEnv Var) -> Arity -> CoreExpr -> CafInfo hasCafRefs dflags this_pkg this_mod p arity expr diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index e53bb11cc3..3c4a551df3 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -1025,15 +1025,15 @@ cmmExprNative referenceKind expr = do CmmReg (CmmGlobal EagerBlackholeInfo) | arch == ArchPPC && not (gopt Opt_PIC dflags) -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info"))) + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit "__stg_EAGER_BLACKHOLE_info"))) CmmReg (CmmGlobal GCEnter1) | arch == ArchPPC && not (gopt Opt_PIC dflags) -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit "__stg_gc_enter_1"))) CmmReg (CmmGlobal GCFun) | arch == ArchPPC && not (gopt Opt_PIC dflags) -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun"))) + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit "__stg_gc_fun"))) other -> return other diff --git a/compiler/nativeGen/CPrim.hs b/compiler/nativeGen/CPrim.hs index a6f4cab7bd..34782dfc1c 100644 --- a/compiler/nativeGen/CPrim.hs +++ b/compiler/nativeGen/CPrim.hs @@ -1,11 +1,16 @@ -- | Generating C symbol names emitted by the compiler. module CPrim - ( popCntLabel + ( atomicReadLabel + , atomicWriteLabel + , atomicRMWLabel + , cmpxchgLabel + , popCntLabel , bSwapLabel , word2FloatLabel ) where import CmmType +import CmmMachOp import Outputable popCntLabel :: Width -> String @@ -31,3 +36,46 @@ word2FloatLabel w = "hs_word2float" ++ pprWidth w pprWidth W32 = "32" pprWidth W64 = "64" pprWidth w = pprPanic "word2FloatLabel: Unsupported word width " (ppr w) + +atomicRMWLabel :: Width -> AtomicMachOp -> String +atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) + + pprFunName AMO_Add = "add" + pprFunName AMO_Sub = "sub" + pprFunName AMO_And = "and" + pprFunName AMO_Nand = "nand" + pprFunName AMO_Or = "or" + pprFunName AMO_Xor = "xor" + +cmpxchgLabel :: Width -> String +cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "cmpxchgLabel: Unsupported word width " (ppr w) + +atomicReadLabel :: Width -> String +atomicReadLabel w = "hs_atomicread" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "atomicReadLabel: Unsupported word width " (ppr w) + +atomicWriteLabel :: Width -> String +atomicWriteLabel w = "hs_atomicwrite" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "atomicWriteLabel: Unsupported word width " (ppr w) diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 91651e6065..014117dd4c 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -813,15 +813,6 @@ genBranch = return . toOL . mkJumpInstr Conditional jumps are always to local labels, so we can use branch instructions. We peek at the arguments to decide what kind of comparison to do. - -SPARC: First, we have to ensure that the condition codes are set -according to the supplied comparison operation. We generate slightly -different code for floating point comparisons, because a floating -point operation cannot directly precede a @BF@. We assume the worst -and fill that slot with a @NOP@. - -SPARC: Do not fill the delay slots here; you will confuse the register -allocator. -} @@ -1160,6 +1151,10 @@ genCCall' dflags gcp target dest_regs args0 MO_BSwap w -> (fsLit $ bSwapLabel w, False) MO_PopCnt w -> (fsLit $ popCntLabel w, False) + MO_AtomicRMW w amop -> (fsLit $ atomicRMWLabel w amop, False) + MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False) + MO_AtomicRead w -> (fsLit $ atomicReadLabel w, False) + MO_AtomicWrite w -> (fsLit $ atomicWriteLabel w, False) MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported diff --git a/compiler/nativeGen/PPC/Cond.hs b/compiler/nativeGen/PPC/Cond.hs index 2568da5249..0e4b1fd701 100644 --- a/compiler/nativeGen/PPC/Cond.hs +++ b/compiler/nativeGen/PPC/Cond.hs @@ -1,17 +1,9 @@ - -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module PPC.Cond ( - Cond(..), - condNegate, - condUnsigned, - condToSigned, - condToUnsigned, + Cond(..), + condNegate, + condUnsigned, + condToSigned, + condToUnsigned, ) where @@ -19,18 +11,18 @@ where import Panic data Cond - = ALWAYS - | EQQ - | GE - | GEU - | GTT - | GU - | LE - | LEU - | LTT - | LU - | NE - deriving Eq + = ALWAYS + | EQQ + | GE + | GEU + | GTT + | GU + | LE + | LEU + | LTT + | LU + | NE + deriving Eq condNegate :: Cond -> Cond diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs index bffa9ea63f..c4724d4193 100644 --- a/compiler/nativeGen/PPC/RegInfo.hs +++ b/compiler/nativeGen/PPC/RegInfo.hs @@ -7,20 +7,12 @@ -- (c) The University of Glasgow 1996-2004 -- ----------------------------------------------------------------------------- - -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module PPC.RegInfo ( JumpDest( DestBlockId ), getJumpDestBlockId, - canShortcut, - shortcutJump, + canShortcut, + shortcutJump, - shortcutStatics + shortcutStatics ) where @@ -70,14 +62,13 @@ shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) shortcutStatic _ other_static = other_static -shortBlockId - :: (BlockId -> Maybe JumpDest) - -> BlockId - -> CLabel +shortBlockId + :: (BlockId -> Maybe JumpDest) + -> BlockId + -> CLabel shortBlockId fn blockid = case fn blockid of Nothing -> mkAsmTempLabel uq Just (DestBlockId blockid') -> shortBlockId fn blockid' where uq = getUnique blockid - diff --git a/compiler/nativeGen/Reg.hs b/compiler/nativeGen/Reg.hs index 77ca7480d6..862306f0bb 100644 --- a/compiler/nativeGen/Reg.hs +++ b/compiler/nativeGen/Reg.hs @@ -1,36 +1,27 @@ - -- | An architecture independent description of a register. --- This needs to stay architecture independent because it is used --- by NCGMonad and the register allocators, which are shared --- by all architectures. +-- This needs to stay architecture independent because it is used +-- by NCGMonad and the register allocators, which are shared +-- by all architectures. -- - -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Reg ( - RegNo, - Reg(..), - regPair, - regSingle, - isRealReg, takeRealReg, - isVirtualReg, takeVirtualReg, - - VirtualReg(..), - renameVirtualReg, - classOfVirtualReg, - getHiVirtualRegFromLo, - getHiVRegFromLo, - - RealReg(..), - regNosOfRealReg, - realRegsAlias, - - liftPatchFnToRegReg + RegNo, + Reg(..), + regPair, + regSingle, + isRealReg, takeRealReg, + isVirtualReg, takeVirtualReg, + + VirtualReg(..), + renameVirtualReg, + classOfVirtualReg, + getHiVirtualRegFromLo, + getHiVRegFromLo, + + RealReg(..), + regNosOfRealReg, + realRegsAlias, + + liftPatchFnToRegReg ) where @@ -41,68 +32,68 @@ import RegClass import Data.List -- | An identifier for a primitive real machine register. -type RegNo - = Int +type RegNo + = Int -- VirtualRegs are virtual registers. The register allocator will --- eventually have to map them into RealRegs, or into spill slots. +-- eventually have to map them into RealRegs, or into spill slots. -- --- VirtualRegs are allocated on the fly, usually to represent a single --- value in the abstract assembly code (i.e. dynamic registers are --- usually single assignment). +-- VirtualRegs are allocated on the fly, usually to represent a single +-- value in the abstract assembly code (i.e. dynamic registers are +-- usually single assignment). -- --- The single assignment restriction isn't necessary to get correct code, --- although a better register allocation will result if single --- assignment is used -- because the allocator maps a VirtualReg into --- a single RealReg, even if the VirtualReg has multiple live ranges. +-- The single assignment restriction isn't necessary to get correct code, +-- although a better register allocation will result if single +-- assignment is used -- because the allocator maps a VirtualReg into +-- a single RealReg, even if the VirtualReg has multiple live ranges. -- --- Virtual regs can be of either class, so that info is attached. +-- Virtual regs can be of either class, so that info is attached. -- data VirtualReg - = VirtualRegI {-# UNPACK #-} !Unique - | VirtualRegHi {-# UNPACK #-} !Unique -- High part of 2-word register - | VirtualRegF {-# UNPACK #-} !Unique - | VirtualRegD {-# UNPACK #-} !Unique - | VirtualRegSSE {-# UNPACK #-} !Unique - deriving (Eq, Show, Ord) + = VirtualRegI {-# UNPACK #-} !Unique + | VirtualRegHi {-# UNPACK #-} !Unique -- High part of 2-word register + | VirtualRegF {-# UNPACK #-} !Unique + | VirtualRegD {-# UNPACK #-} !Unique + | VirtualRegSSE {-# UNPACK #-} !Unique + deriving (Eq, Show, Ord) instance Uniquable VirtualReg where - getUnique reg - = case reg of - VirtualRegI u -> u - VirtualRegHi u -> u - VirtualRegF u -> u - VirtualRegD u -> u - VirtualRegSSE u -> u + getUnique reg + = case reg of + VirtualRegI u -> u + VirtualRegHi u -> u + VirtualRegF u -> u + VirtualRegD u -> u + VirtualRegSSE u -> u instance Outputable VirtualReg where - ppr reg - = case reg of - VirtualRegI u -> text "%vI_" <> pprUnique u - VirtualRegHi u -> text "%vHi_" <> pprUnique u - VirtualRegF u -> text "%vF_" <> pprUnique u - VirtualRegD u -> text "%vD_" <> pprUnique u - VirtualRegSSE u -> text "%vSSE_" <> pprUnique u + ppr reg + = case reg of + VirtualRegI u -> text "%vI_" <> pprUnique u + VirtualRegHi u -> text "%vHi_" <> pprUnique u + VirtualRegF u -> text "%vF_" <> pprUnique u + VirtualRegD u -> text "%vD_" <> pprUnique u + VirtualRegSSE u -> text "%vSSE_" <> pprUnique u renameVirtualReg :: Unique -> VirtualReg -> VirtualReg renameVirtualReg u r = case r of - VirtualRegI _ -> VirtualRegI u - VirtualRegHi _ -> VirtualRegHi u - VirtualRegF _ -> VirtualRegF u - VirtualRegD _ -> VirtualRegD u - VirtualRegSSE _ -> VirtualRegSSE u + VirtualRegI _ -> VirtualRegI u + VirtualRegHi _ -> VirtualRegHi u + VirtualRegF _ -> VirtualRegF u + VirtualRegD _ -> VirtualRegD u + VirtualRegSSE _ -> VirtualRegSSE u classOfVirtualReg :: VirtualReg -> RegClass classOfVirtualReg vr = case vr of - VirtualRegI{} -> RcInteger - VirtualRegHi{} -> RcInteger - VirtualRegF{} -> RcFloat - VirtualRegD{} -> RcDouble - VirtualRegSSE{} -> RcDoubleSSE + VirtualRegI{} -> RcInteger + VirtualRegHi{} -> RcInteger + VirtualRegF{} -> RcFloat + VirtualRegD{} -> RcDouble + VirtualRegSSE{} -> RcDoubleSSE -- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform @@ -111,118 +102,116 @@ classOfVirtualReg vr getHiVirtualRegFromLo :: VirtualReg -> VirtualReg getHiVirtualRegFromLo reg = case reg of - -- makes a pseudo-unique with tag 'H' - VirtualRegI u -> VirtualRegHi (newTagUnique u 'H') - _ -> panic "Reg.getHiVirtualRegFromLo" + -- makes a pseudo-unique with tag 'H' + VirtualRegI u -> VirtualRegHi (newTagUnique u 'H') + _ -> panic "Reg.getHiVirtualRegFromLo" getHiVRegFromLo :: Reg -> Reg getHiVRegFromLo reg = case reg of - RegVirtual vr -> RegVirtual (getHiVirtualRegFromLo vr) - RegReal _ -> panic "Reg.getHiVRegFromLo" - + RegVirtual vr -> RegVirtual (getHiVirtualRegFromLo vr) + RegReal _ -> panic "Reg.getHiVRegFromLo" + ------------------------------------------------------------------------------------ -- | RealRegs are machine regs which are available for allocation, in --- the usual way. We know what class they are, because that's part of --- the processor's architecture. +-- the usual way. We know what class they are, because that's part of +-- the processor's architecture. -- --- RealRegPairs are pairs of real registers that are allocated together --- to hold a larger value, such as with Double regs on SPARC. +-- RealRegPairs are pairs of real registers that are allocated together +-- to hold a larger value, such as with Double regs on SPARC. -- data RealReg - = RealRegSingle {-# UNPACK #-} !RegNo - | RealRegPair {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo - deriving (Eq, Show, Ord) + = RealRegSingle {-# UNPACK #-} !RegNo + | RealRegPair {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo + deriving (Eq, Show, Ord) instance Uniquable RealReg where - getUnique reg - = case reg of - RealRegSingle i -> mkRegSingleUnique i - RealRegPair r1 r2 -> mkRegPairUnique (r1 * 65536 + r2) + getUnique reg + = case reg of + RealRegSingle i -> mkRegSingleUnique i + RealRegPair r1 r2 -> mkRegPairUnique (r1 * 65536 + r2) instance Outputable RealReg where - ppr reg - = case reg of - RealRegSingle i -> text "%r" <> int i - RealRegPair r1 r2 -> text "%r(" <> int r1 <> text "|" <> int r2 <> text ")" + ppr reg + = case reg of + RealRegSingle i -> text "%r" <> int i + RealRegPair r1 r2 -> text "%r(" <> int r1 <> text "|" <> int r2 <> text ")" regNosOfRealReg :: RealReg -> [RegNo] regNosOfRealReg rr = case rr of - RealRegSingle r1 -> [r1] - RealRegPair r1 r2 -> [r1, r2] - + RealRegSingle r1 -> [r1] + RealRegPair r1 r2 -> [r1, r2] + realRegsAlias :: RealReg -> RealReg -> Bool realRegsAlias rr1 rr2 - = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2) + = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2) -------------------------------------------------------------------------------- -- | A register, either virtual or real data Reg - = RegVirtual !VirtualReg - | RegReal !RealReg - deriving (Eq, Ord) + = RegVirtual !VirtualReg + | RegReal !RealReg + deriving (Eq, Ord) regSingle :: RegNo -> Reg -regSingle regNo = RegReal $ RealRegSingle regNo +regSingle regNo = RegReal $ RealRegSingle regNo regPair :: RegNo -> RegNo -> Reg -regPair regNo1 regNo2 = RegReal $ RealRegPair regNo1 regNo2 +regPair regNo1 regNo2 = RegReal $ RealRegPair regNo1 regNo2 --- We like to have Uniques for Reg so that we can make UniqFM and UniqSets +-- We like to have Uniques for Reg so that we can make UniqFM and UniqSets -- in the register allocator. instance Uniquable Reg where - getUnique reg - = case reg of - RegVirtual vr -> getUnique vr - RegReal rr -> getUnique rr - + getUnique reg + = case reg of + RegVirtual vr -> getUnique vr + RegReal rr -> getUnique rr + -- | Print a reg in a generic manner --- If you want the architecture specific names, then use the pprReg --- function from the appropriate Ppr module. +-- If you want the architecture specific names, then use the pprReg +-- function from the appropriate Ppr module. instance Outputable Reg where - ppr reg - = case reg of - RegVirtual vr -> ppr vr - RegReal rr -> ppr rr + ppr reg + = case reg of + RegVirtual vr -> ppr vr + RegReal rr -> ppr rr isRealReg :: Reg -> Bool -isRealReg reg +isRealReg reg = case reg of - RegReal _ -> True - RegVirtual _ -> False + RegReal _ -> True + RegVirtual _ -> False takeRealReg :: Reg -> Maybe RealReg takeRealReg reg = case reg of - RegReal rr -> Just rr - _ -> Nothing + RegReal rr -> Just rr + _ -> Nothing isVirtualReg :: Reg -> Bool isVirtualReg reg = case reg of - RegReal _ -> False - RegVirtual _ -> True + RegReal _ -> False + RegVirtual _ -> True takeVirtualReg :: Reg -> Maybe VirtualReg takeVirtualReg reg = case reg of - RegReal _ -> Nothing - RegVirtual vr -> Just vr + RegReal _ -> Nothing + RegVirtual vr -> Just vr -- | The patch function supplied by the allocator maps VirtualReg to RealReg --- regs, but sometimes we want to apply it to plain old Reg. +-- regs, but sometimes we want to apply it to plain old Reg. -- liftPatchFnToRegReg :: (VirtualReg -> RealReg) -> (Reg -> Reg) liftPatchFnToRegReg patchF reg = case reg of - RegVirtual vr -> RegReal (patchF vr) - RegReal _ -> reg - - + RegVirtual vr -> RegReal (patchF vr) + RegReal _ -> reg diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index ee43d25aa3..fa47a17ac0 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -158,11 +158,11 @@ regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live []) , Nothing ) regAlloc dflags (CmmProc static lbl live sccs) - | LiveInfo info (Just first_id) (Just block_live) _ <- static + | LiveInfo info entry_ids@(first_id:_) (Just block_live) _ <- static = do -- do register allocation on each component. (final_blocks, stats, stack_use) - <- linearRegAlloc dflags first_id block_live sccs + <- linearRegAlloc dflags entry_ids block_live sccs -- make sure the block that was first in the input list -- stays at the front of the output @@ -196,46 +196,50 @@ regAlloc _ (CmmProc _ _ _ _) linearRegAlloc :: (Outputable instr, Instruction instr) => DynFlags - -> BlockId -- ^ the first block - -> BlockMap RegSet -- ^ live regs on entry to each basic block - -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" + -> [BlockId] -- ^ entry points + -> BlockMap RegSet + -- ^ live regs on entry to each basic block + -> [SCC (LiveBasicBlock instr)] + -- ^ instructions annotated with "deaths" -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) -linearRegAlloc dflags first_id block_live sccs - = let platform = targetPlatform dflags - in case platformArch platform of - ArchX86 -> linearRegAlloc' dflags (frInitFreeRegs platform :: X86.FreeRegs) first_id block_live sccs - ArchX86_64 -> linearRegAlloc' dflags (frInitFreeRegs platform :: X86_64.FreeRegs) first_id block_live sccs - ArchSPARC -> linearRegAlloc' dflags (frInitFreeRegs platform :: SPARC.FreeRegs) first_id block_live sccs - ArchPPC -> linearRegAlloc' dflags (frInitFreeRegs platform :: PPC.FreeRegs) first_id block_live sccs - ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" - ArchARM64 -> panic "linearRegAlloc ArchARM64" - ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" - ArchAlpha -> panic "linearRegAlloc ArchAlpha" - ArchMipseb -> panic "linearRegAlloc ArchMipseb" - ArchMipsel -> panic "linearRegAlloc ArchMipsel" +linearRegAlloc dflags entry_ids block_live sccs + = case platformArch platform of + ArchX86 -> go $ (frInitFreeRegs platform :: X86.FreeRegs) + ArchX86_64 -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs) + ArchSPARC -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs) + ArchPPC -> go $ (frInitFreeRegs platform :: PPC.FreeRegs) + ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" + ArchARM64 -> panic "linearRegAlloc ArchARM64" + ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" + ArchAlpha -> panic "linearRegAlloc ArchAlpha" + ArchMipseb -> panic "linearRegAlloc ArchMipseb" + ArchMipsel -> panic "linearRegAlloc ArchMipsel" ArchJavaScript -> panic "linearRegAlloc ArchJavaScript" - ArchUnknown -> panic "linearRegAlloc ArchUnknown" + ArchUnknown -> panic "linearRegAlloc ArchUnknown" + where + go f = linearRegAlloc' dflags f entry_ids block_live sccs + platform = targetPlatform dflags linearRegAlloc' :: (FR freeRegs, Outputable instr, Instruction instr) => DynFlags -> freeRegs - -> BlockId -- ^ the first block + -> [BlockId] -- ^ entry points -> BlockMap RegSet -- ^ live regs on entry to each basic block -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) -linearRegAlloc' dflags initFreeRegs first_id block_live sccs +linearRegAlloc' dflags initFreeRegs entry_ids block_live sccs = do us <- getUs let (_, stack, stats, blocks) = runR dflags emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap dflags) us - $ linearRA_SCCs first_id block_live [] sccs + $ linearRA_SCCs entry_ids block_live [] sccs return (blocks, stats, getStackUse stack) linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockId + => [BlockId] -> BlockMap RegSet -> [NatBasicBlock instr] -> [SCC (LiveBasicBlock instr)] @@ -244,16 +248,16 @@ linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) linearRA_SCCs _ _ blocksAcc [] = return $ reverse blocksAcc -linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs) +linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs) = do blocks' <- processBlock block_live block - linearRA_SCCs first_id block_live + linearRA_SCCs entry_ids block_live ((reverse blocks') ++ blocksAcc) sccs -linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) +linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs) = do - blockss' <- process first_id block_live blocks [] (return []) False - linearRA_SCCs first_id block_live + blockss' <- process entry_ids block_live blocks [] (return []) False + linearRA_SCCs entry_ids block_live (reverse (concat blockss') ++ blocksAcc) sccs @@ -270,7 +274,7 @@ linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) -} process :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockId + => [BlockId] -> BlockMap RegSet -> [GenBasicBlock (LiveInstr instr)] -> [GenBasicBlock (LiveInstr instr)] @@ -281,7 +285,7 @@ process :: (FR freeRegs, Instruction instr, Outputable instr) process _ _ [] [] accum _ = return $ reverse accum -process first_id block_live [] next_round accum madeProgress +process entry_ids block_live [] next_round accum madeProgress | not madeProgress {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming. @@ -291,22 +295,22 @@ process first_id block_live [] next_round accum madeProgress = return $ reverse accum | otherwise - = process first_id block_live + = process entry_ids block_live next_round [] accum False -process first_id block_live (b@(BasicBlock id _) : blocks) +process entry_ids block_live (b@(BasicBlock id _) : blocks) next_round accum madeProgress = do block_assig <- getBlockAssigR if isJust (mapLookup id block_assig) - || id == first_id + || id `elem` entry_ids then do b' <- processBlock block_live b - process first_id block_live blocks + process entry_ids block_live blocks next_round (b' : accum) True - else process first_id block_live blocks + else process entry_ids block_live blocks (b : next_round) accum madeProgress diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 1cb6dc8268..d7fd8bdcb4 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -169,10 +169,11 @@ data Liveness -- | Stash regs live on entry to each basic block in the info part of the cmm code. data LiveInfo = LiveInfo - (BlockEnv CmmStatics) -- cmm info table static stuff - (Maybe BlockId) -- id of the first block - (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block - (Map BlockId (Set Int)) -- stack slots live on entry to this block + (BlockEnv CmmStatics) -- cmm info table static stuff + [BlockId] -- entry points (first one is the + -- entry point for the proc). + (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block + (Map BlockId (Set Int)) -- stack slots live on entry to this block -- | A basic block with liveness information. @@ -223,9 +224,9 @@ instance Outputable instr | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs) instance Outputable LiveInfo where - ppr (LiveInfo mb_static firstId liveVRegsOnEntry liveSlotsOnEntry) + ppr (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry) = (ppr mb_static) - $$ text "# firstId = " <> ppr firstId + $$ text "# entryIds = " <> ppr entryIds $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) @@ -480,7 +481,7 @@ stripLive dflags live where stripCmm :: (Outputable statics, Outputable instr, Instruction instr) => LiveCmmDecl statics instr -> NatCmmDecl statics instr stripCmm (CmmData sec ds) = CmmData sec ds - stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label live sccs) + stripCmm (CmmProc (LiveInfo info (first_id:_) _ _) label live sccs) = let final_blocks = flattenSCCs sccs -- make sure the block that was first in the input list @@ -493,7 +494,7 @@ stripLive dflags live (ListGraph $ map (stripLiveBlock dflags) $ first' : rest') -- procs used for stg_split_markers don't contain any blocks, and have no first_id. - stripCmm (CmmProc (LiveInfo info Nothing _ _) label live []) + stripCmm (CmmProc (LiveInfo info [] _ _) label live []) = CmmProc info label live (ListGraph []) -- If the proc has blocks but we don't know what the first one was, then we're dead. @@ -641,16 +642,19 @@ natCmmTopToLive (CmmData i d) = CmmData i d natCmmTopToLive (CmmProc info lbl live (ListGraph [])) - = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl live [] + = CmmProc (LiveInfo info [] Nothing Map.empty) lbl live [] natCmmTopToLive proc@(CmmProc info lbl live (ListGraph blocks@(first : _))) = let first_id = blockId first - sccs = sccBlocks blocks (entryBlocks proc) + all_entry_ids = entryBlocks proc + sccs = sccBlocks blocks all_entry_ids + entry_ids = filter (/= first_id) all_entry_ids sccsLive = map (fmap (\(BasicBlock l instrs) -> BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) $ sccs - in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl live sccsLive + in CmmProc (LiveInfo info (first_id : entry_ids) Nothing Map.empty) + lbl live sccsLive -- diff --git a/compiler/nativeGen/RegClass.hs b/compiler/nativeGen/RegClass.hs index cac4e64221..0c793173cb 100644 --- a/compiler/nativeGen/RegClass.hs +++ b/compiler/nativeGen/RegClass.hs @@ -1,41 +1,33 @@ -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - - -- | An architecture independent description of a register's class. -module RegClass - ( RegClass (..) ) +module RegClass + ( RegClass (..) ) where -import Outputable -import Unique +import Outputable +import Unique --- | The class of a register. --- Used in the register allocator. --- We treat all registers in a class as being interchangable. +-- | The class of a register. +-- Used in the register allocator. +-- We treat all registers in a class as being interchangable. -- -data RegClass - = RcInteger - | RcFloat - | RcDouble - | RcDoubleSSE -- x86 only: the SSE regs are a separate class - deriving Eq +data RegClass + = RcInteger + | RcFloat + | RcDouble + | RcDoubleSSE -- x86 only: the SSE regs are a separate class + deriving Eq instance Uniquable RegClass where - getUnique RcInteger = mkRegClassUnique 0 - getUnique RcFloat = mkRegClassUnique 1 - getUnique RcDouble = mkRegClassUnique 2 + getUnique RcInteger = mkRegClassUnique 0 + getUnique RcFloat = mkRegClassUnique 1 + getUnique RcDouble = mkRegClassUnique 2 getUnique RcDoubleSSE = mkRegClassUnique 3 instance Outputable RegClass where - ppr RcInteger = Outputable.text "I" - ppr RcFloat = Outputable.text "F" - ppr RcDouble = Outputable.text "D" - ppr RcDoubleSSE = Outputable.text "S" + ppr RcInteger = Outputable.text "I" + ppr RcFloat = Outputable.text "F" + ppr RcDouble = Outputable.text "D" + ppr RcDoubleSSE = Outputable.text "S" diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index f5e61d0a8f..51f89d629f 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -654,6 +654,10 @@ outOfLineMachOp_table mop MO_BSwap w -> fsLit $ bSwapLabel w MO_PopCnt w -> fsLit $ popCntLabel w + MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop + MO_Cmpxchg w -> fsLit $ cmpxchgLabel w + MO_AtomicRead w -> fsLit $ atomicReadLabel w + MO_AtomicWrite w -> fsLit $ atomicWriteLabel w MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported diff --git a/compiler/nativeGen/SPARC/CodeGen/Amode.hs b/compiler/nativeGen/SPARC/CodeGen/Amode.hs index f0aed0d02e..8d9a303f2f 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Amode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Amode.hs @@ -1,13 +1,5 @@ - -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.CodeGen.Amode ( - getAmode + getAmode ) where @@ -28,11 +20,11 @@ import OrdList -- | Generate code to reference a memory address. -getAmode - :: CmmExpr -- ^ expr producing an address - -> NatM Amode +getAmode + :: CmmExpr -- ^ expr producing an address + -> NatM Amode -getAmode tree@(CmmRegOff _ _) +getAmode tree@(CmmRegOff _ _) = do dflags <- getDynFlags getAmode (mangleIndexTree dflags tree) @@ -50,7 +42,7 @@ getAmode (CmmMachOp (MO_Add _) [x, CmmLit (CmmInt i _)]) = do (reg, code) <- getSomeReg x let - off = ImmInt (fromInteger i) + off = ImmInt (fromInteger i) return (Amode (AddrRegImm reg off) code) getAmode (CmmMachOp (MO_Add _) [x, y]) @@ -58,23 +50,23 @@ getAmode (CmmMachOp (MO_Add _) [x, y]) (regX, codeX) <- getSomeReg x (regY, codeY) <- getSomeReg y let - code = codeX `appOL` codeY + code = codeX `appOL` codeY return (Amode (AddrRegReg regX regY) code) getAmode (CmmLit lit) = do - let imm__2 = litToImm lit - tmp1 <- getNewRegNat II32 - tmp2 <- getNewRegNat II32 + let imm__2 = litToImm lit + tmp1 <- getNewRegNat II32 + tmp2 <- getNewRegNat II32 + + let code = toOL [ SETHI (HI imm__2) tmp1 + , OR False tmp1 (RIImm (LO imm__2)) tmp2] - let code = toOL [ SETHI (HI imm__2) tmp1 - , OR False tmp1 (RIImm (LO imm__2)) tmp2] - - return (Amode (AddrRegReg tmp2 g0) code) + return (Amode (AddrRegReg tmp2 g0) code) getAmode other = do (reg, code) <- getSomeReg other let - off = ImmInt 0 + off = ImmInt 0 return (Amode (AddrRegImm reg off) code) diff --git a/compiler/nativeGen/SPARC/CodeGen/Base.hs b/compiler/nativeGen/SPARC/CodeGen/Base.hs index 45b7801960..270fd699b0 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Base.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Base.hs @@ -1,22 +1,14 @@ +module SPARC.CodeGen.Base ( + InstrBlock, + CondCode(..), + ChildCode64(..), + Amode(..), -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details + Register(..), + setSizeOfRegister, -module SPARC.CodeGen.Base ( - InstrBlock, - CondCode(..), - ChildCode64(..), - Amode(..), - - Register(..), - setSizeOfRegister, - - getRegisterReg, - mangleIndexTree + getRegisterReg, + mangleIndexTree ) where @@ -39,63 +31,63 @@ import OrdList -------------------------------------------------------------------------------- -- | 'InstrBlock's are the insn sequences generated by the insn selectors. --- They are really trees of insns to facilitate fast appending, where a --- left-to-right traversal yields the insns in the correct order. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. -- -type InstrBlock - = OrdList Instr +type InstrBlock + = OrdList Instr -- | Condition codes passed up the tree. -- -data CondCode - = CondCode Bool Cond InstrBlock +data CondCode + = CondCode Bool Cond InstrBlock -- | a.k.a "Register64" --- Reg is the lower 32-bit temporary which contains the result. --- Use getHiVRegFromLo to find the other VRegUnique. +-- Reg is the lower 32-bit temporary which contains the result. +-- Use getHiVRegFromLo to find the other VRegUnique. -- --- Rules of this simplified insn selection game are therefore that --- the returned Reg may be modified +-- Rules of this simplified insn selection game are therefore that +-- the returned Reg may be modified -- -data ChildCode64 - = ChildCode64 +data ChildCode64 + = ChildCode64 InstrBlock - Reg + Reg -- | Holds code that references a memory address. -data Amode - = Amode - -- the AddrMode we can use in the instruction - -- that does the real load\/store. - AddrMode +data Amode + = Amode + -- the AddrMode we can use in the instruction + -- that does the real load\/store. + AddrMode - -- other setup code we have to run first before we can use the - -- above AddrMode. - InstrBlock + -- other setup code we have to run first before we can use the + -- above AddrMode. + InstrBlock -------------------------------------------------------------------------------- -- | Code to produce a result into a register. --- If the result must go in a specific register, it comes out as Fixed. --- Otherwise, the parent can decide which register to put it in. +-- If the result must go in a specific register, it comes out as Fixed. +-- Otherwise, the parent can decide which register to put it in. -- data Register - = Fixed Size Reg InstrBlock - | Any Size (Reg -> InstrBlock) + = Fixed Size Reg InstrBlock + | Any Size (Reg -> InstrBlock) -- | Change the size field in a Register. setSizeOfRegister - :: Register -> Size -> Register + :: Register -> Size -> Register setSizeOfRegister reg size = case reg of - Fixed _ reg code -> Fixed size reg code - Any _ codefn -> Any size codefn + Fixed _ reg code -> Fixed size reg code + Any _ codefn -> Any size codefn -------------------------------------------------------------------------------- @@ -103,7 +95,7 @@ setSizeOfRegister reg size getRegisterReg :: Platform -> CmmReg -> Reg getRegisterReg _ (CmmLocal (LocalReg u pk)) - = RegVirtual $ mkVirtualReg u (cmmTypeSize pk) + = RegVirtual $ mkVirtualReg u (cmmTypeSize pk) getRegisterReg platform (CmmGlobal mid) = case globalRegMaybe platform mid of @@ -118,12 +110,8 @@ getRegisterReg platform (CmmGlobal mid) mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr mangleIndexTree dflags (CmmRegOff reg off) - = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType dflags reg) + = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] + where width = typeWidth (cmmRegType dflags reg) mangleIndexTree _ _ - = panic "SPARC.CodeGen.Base.mangleIndexTree: no match" - - - - + = panic "SPARC.CodeGen.Base.mangleIndexTree: no match" diff --git a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs index 2c3dbe6fc0..cb10830f46 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs @@ -1,15 +1,7 @@ - -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.CodeGen.CondCode ( - getCondCode, - condIntCode, - condFltCode + getCondCode, + condIntCode, + condFltCode ) where @@ -32,7 +24,7 @@ import Outputable getCondCode :: CmmExpr -> NatM CondCode getCondCode (CmmMachOp mop [x, y]) - = + = case mop of MO_F_Eq W32 -> condFltCode EQQ x y MO_F_Ne W32 -> condFltCode NE x y @@ -86,8 +78,8 @@ condIntCode cond x y = do (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y let - code__2 = code1 `appOL` code2 `snocOL` - SUB False True src1 (RIReg src2) g0 + code__2 = code1 `appOL` code2 `snocOL` + SUB False True src1 (RIReg src2) g0 return (CondCode False cond code__2) @@ -98,19 +90,19 @@ condFltCode cond x y = do (src2, code2) <- getSomeReg y tmp <- getNewRegNat FF64 let - promote x = FxTOy FF32 FF64 x tmp - - pk1 = cmmExprType dflags x - pk2 = cmmExprType dflags y - - code__2 = - if pk1 `cmmEqType` pk2 then - code1 `appOL` code2 `snocOL` - FCMP True (cmmTypeSize pk1) src1 src2 - else if typeWidth pk1 == W32 then - code1 `snocOL` promote src1 `appOL` code2 `snocOL` - FCMP True FF64 tmp src2 - else - code1 `appOL` code2 `snocOL` promote src2 `snocOL` - FCMP True FF64 src1 tmp + promote x = FxTOy FF32 FF64 x tmp + + pk1 = cmmExprType dflags x + pk2 = cmmExprType dflags y + + code__2 = + if pk1 `cmmEqType` pk2 then + code1 `appOL` code2 `snocOL` + FCMP True (cmmTypeSize pk1) src1 src2 + else if typeWidth pk1 == W32 then + code1 `snocOL` promote src1 `appOL` code2 `snocOL` + FCMP True FF64 tmp src2 + else + code1 `appOL` code2 `snocOL` promote src2 `snocOL` + FCMP True FF64 src1 tmp return (CondCode True cond code__2) diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs index 7ebc2f6630..1d4d1379a5 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -1,14 +1,6 @@ - -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Expand out synthetic instructions into single machine instrs. module SPARC.CodeGen.Expand ( - expandTop + expandTop ) where @@ -17,7 +9,7 @@ import SPARC.Instr import SPARC.Imm import SPARC.AddrMode import SPARC.Regs -import SPARC.Ppr () +import SPARC.Ppr () import Instruction import Reg import Size @@ -30,139 +22,132 @@ import OrdList -- | Expand out synthetic instructions in this top level thing expandTop :: NatCmmDecl CmmStatics Instr -> NatCmmDecl CmmStatics Instr expandTop top@(CmmData{}) - = top + = top expandTop (CmmProc info lbl live (ListGraph blocks)) - = CmmProc info lbl live (ListGraph $ map expandBlock blocks) + = CmmProc info lbl live (ListGraph $ map expandBlock blocks) -- | Expand out synthetic instructions in this block expandBlock :: NatBasicBlock Instr -> NatBasicBlock Instr expandBlock (BasicBlock label instrs) - = let instrs_ol = expandBlockInstrs instrs - instrs' = fromOL instrs_ol - in BasicBlock label instrs' + = let instrs_ol = expandBlockInstrs instrs + instrs' = fromOL instrs_ol + in BasicBlock label instrs' -- | Expand out some instructions expandBlockInstrs :: [Instr] -> OrdList Instr -expandBlockInstrs [] = nilOL - +expandBlockInstrs [] = nilOL + expandBlockInstrs (ii:is) - = let ii_doubleRegs = remapRegPair ii - is_misaligned = expandMisalignedDoubles ii_doubleRegs + = let ii_doubleRegs = remapRegPair ii + is_misaligned = expandMisalignedDoubles ii_doubleRegs + + in is_misaligned `appOL` expandBlockInstrs is - in is_misaligned `appOL` expandBlockInstrs is - -- | In the SPARC instruction set the FP register pairs that are used --- to hold 64 bit floats are refered to by just the first reg --- of the pair. Remap our internal reg pairs to the appropriate reg. +-- to hold 64 bit floats are refered to by just the first reg +-- of the pair. Remap our internal reg pairs to the appropriate reg. -- --- For example: --- ldd [%l1], (%f0 | %f1) +-- For example: +-- ldd [%l1], (%f0 | %f1) -- --- gets mapped to --- ldd [$l1], %f0 +-- gets mapped to +-- ldd [$l1], %f0 -- remapRegPair :: Instr -> Instr remapRegPair instr - = let patchF reg - = case reg of - RegReal (RealRegSingle _) - -> reg + = let patchF reg + = case reg of + RegReal (RealRegSingle _) + -> reg - RegReal (RealRegPair r1 r2) + RegReal (RealRegPair r1 r2) - -- sanity checking - | r1 >= 32 - , r1 <= 63 - , r1 `mod` 2 == 0 - , r2 == r1 + 1 - -> RegReal (RealRegSingle r1) + -- sanity checking + | r1 >= 32 + , r1 <= 63 + , r1 `mod` 2 == 0 + , r2 == r1 + 1 + -> RegReal (RealRegSingle r1) - | otherwise - -> pprPanic "SPARC.CodeGen.Expand: not remapping dodgy looking reg pair " (ppr reg) + | otherwise + -> pprPanic "SPARC.CodeGen.Expand: not remapping dodgy looking reg pair " (ppr reg) - RegVirtual _ - -> pprPanic "SPARC.CodeGen.Expand: not remapping virtual reg " (ppr reg) - - in patchRegsOfInstr instr patchF + RegVirtual _ + -> pprPanic "SPARC.CodeGen.Expand: not remapping virtual reg " (ppr reg) + + in patchRegsOfInstr instr patchF -- Expand out 64 bit load/stores into individual instructions to handle --- possible double alignment problems. +-- possible double alignment problems. -- --- TODO: It'd be better to use a scratch reg instead of the add/sub thing. --- We might be able to do this faster if we use the UA2007 instr set --- instead of restricting ourselves to SPARC V9. +-- TODO: It'd be better to use a scratch reg instead of the add/sub thing. +-- We might be able to do this faster if we use the UA2007 instr set +-- instead of restricting ourselves to SPARC V9. -- expandMisalignedDoubles :: Instr -> OrdList Instr expandMisalignedDoubles instr - -- Translate to: - -- add g1,g2,g1 - -- ld [g1],%fn - -- ld [g1+4],%f(n+1) - -- sub g1,g2,g1 -- to restore g1 - | LD FF64 (AddrRegReg r1 r2) fReg <- instr - = toOL [ ADD False False r1 (RIReg r2) r1 - , LD FF32 (AddrRegReg r1 g0) fReg - , LD FF32 (AddrRegImm r1 (ImmInt 4)) (fRegHi fReg) - , SUB False False r1 (RIReg r2) r1 ] - - -- Translate to - -- ld [addr],%fn - -- ld [addr+4],%f(n+1) - | LD FF64 addr fReg <- instr - = let Just addr' = addrOffset addr 4 - in toOL [ LD FF32 addr fReg - , LD FF32 addr' (fRegHi fReg) ] - - -- Translate to: - -- add g1,g2,g1 - -- st %fn,[g1] - -- st %f(n+1),[g1+4] - -- sub g1,g2,g1 -- to restore g1 - | ST FF64 fReg (AddrRegReg r1 r2) <- instr - = toOL [ ADD False False r1 (RIReg r2) r1 - , ST FF32 fReg (AddrRegReg r1 g0) - , ST FF32 (fRegHi fReg) (AddrRegImm r1 (ImmInt 4)) - , SUB False False r1 (RIReg r2) r1 ] - - -- Translate to - -- ld [addr],%fn - -- ld [addr+4],%f(n+1) - | ST FF64 fReg addr <- instr - = let Just addr' = addrOffset addr 4 - in toOL [ ST FF32 fReg addr - , ST FF32 (fRegHi fReg) addr' ] - - -- some other instr - | otherwise - = unitOL instr - - - --- | The the high partner for this float reg. + -- Translate to: + -- add g1,g2,g1 + -- ld [g1],%fn + -- ld [g1+4],%f(n+1) + -- sub g1,g2,g1 -- to restore g1 + | LD FF64 (AddrRegReg r1 r2) fReg <- instr + = toOL [ ADD False False r1 (RIReg r2) r1 + , LD FF32 (AddrRegReg r1 g0) fReg + , LD FF32 (AddrRegImm r1 (ImmInt 4)) (fRegHi fReg) + , SUB False False r1 (RIReg r2) r1 ] + + -- Translate to + -- ld [addr],%fn + -- ld [addr+4],%f(n+1) + | LD FF64 addr fReg <- instr + = let Just addr' = addrOffset addr 4 + in toOL [ LD FF32 addr fReg + , LD FF32 addr' (fRegHi fReg) ] + + -- Translate to: + -- add g1,g2,g1 + -- st %fn,[g1] + -- st %f(n+1),[g1+4] + -- sub g1,g2,g1 -- to restore g1 + | ST FF64 fReg (AddrRegReg r1 r2) <- instr + = toOL [ ADD False False r1 (RIReg r2) r1 + , ST FF32 fReg (AddrRegReg r1 g0) + , ST FF32 (fRegHi fReg) (AddrRegImm r1 (ImmInt 4)) + , SUB False False r1 (RIReg r2) r1 ] + + -- Translate to + -- ld [addr],%fn + -- ld [addr+4],%f(n+1) + | ST FF64 fReg addr <- instr + = let Just addr' = addrOffset addr 4 + in toOL [ ST FF32 fReg addr + , ST FF32 (fRegHi fReg) addr' ] + + -- some other instr + | otherwise + = unitOL instr + + + +-- | The the high partner for this float reg. fRegHi :: Reg -> Reg fRegHi (RegReal (RealRegSingle r1)) - | r1 >= 32 - , r1 <= 63 - , r1 `mod` 2 == 0 - = (RegReal $ RealRegSingle (r1 + 1)) - + | r1 >= 32 + , r1 <= 63 + , r1 `mod` 2 == 0 + = (RegReal $ RealRegSingle (r1 + 1)) + -- Can't take high partner for non-low reg. fRegHi reg - = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg) - - - - - - - + = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg) diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs index 43a26e525a..90fb41870d 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -1,15 +1,7 @@ - -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Evaluation of 32 bit values. module SPARC.CodeGen.Gen32 ( - getSomeReg, - getRegister + getSomeReg, + getRegister ) where @@ -37,16 +29,16 @@ import OrdList import Outputable -- | The dual to getAnyReg: compute an expression into a register, but --- we don't mind which one it is. +-- we don't mind which one it is. getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) getSomeReg expr = do r <- getRegister expr case r of Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed _ reg code -> - return (reg, code) + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed _ reg code -> + return (reg, code) @@ -54,13 +46,13 @@ getSomeReg expr = do -- getRegister :: CmmExpr -> NatM Register -getRegister (CmmReg reg) +getRegister (CmmReg reg) = do dflags <- getDynFlags let platform = targetPlatform dflags return (Fixed (cmmTypeSize (cmmRegType dflags reg)) (getRegisterReg platform reg) nilOL) -getRegister tree@(CmmRegOff _ _) +getRegister tree@(CmmRegOff _ _) = do dflags <- getDynFlags getRegister (mangleIndexTree dflags tree) @@ -80,12 +72,12 @@ getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code + return $ Fixed II32 rlo code -- Load a literal float into a float register. --- The actual literal is stored in a new data area, and we load it --- at runtime. +-- The actual literal is stored in a new data area, and we load it +-- at runtime. getRegister (CmmLit (CmmFloat f W32)) = do -- a label for the new data area @@ -93,13 +85,13 @@ getRegister (CmmLit (CmmFloat f W32)) = do tmp <- getNewRegNat II32 let code dst = toOL [ - -- the data area - LDATA ReadOnlyData $ Statics lbl - [CmmStaticLit (CmmFloat f W32)], + -- the data area + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat f W32)], -- load the literal - SETHI (HI (ImmCLbl lbl)) tmp, - LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] + SETHI (HI (ImmCLbl lbl)) tmp, + LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] return (Any FF32 code) @@ -107,342 +99,342 @@ getRegister (CmmLit (CmmFloat d W64)) = do lbl <- getNewLabelNat tmp <- getNewRegNat II32 let code dst = toOL [ - LDATA ReadOnlyData $ Statics lbl - [CmmStaticLit (CmmFloat d W64)], - SETHI (HI (ImmCLbl lbl)) tmp, - LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat d W64)], + SETHI (HI (ImmCLbl lbl)) tmp, + LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] return (Any FF64 code) -- Unary machine ops getRegister (CmmMachOp mop [x]) = case mop of - -- Floating point negation ------------------------- - MO_F_Neg W32 -> trivialUFCode FF32 (FNEG FF32) x - MO_F_Neg W64 -> trivialUFCode FF64 (FNEG FF64) x + -- Floating point negation ------------------------- + MO_F_Neg W32 -> trivialUFCode FF32 (FNEG FF32) x + MO_F_Neg W64 -> trivialUFCode FF64 (FNEG FF64) x - -- Integer negation -------------------------------- - MO_S_Neg rep -> trivialUCode (intSize rep) (SUB False False g0) x - MO_Not rep -> trivialUCode (intSize rep) (XNOR False g0) x + -- Integer negation -------------------------------- + MO_S_Neg rep -> trivialUCode (intSize rep) (SUB False False g0) x + MO_Not rep -> trivialUCode (intSize rep) (XNOR False g0) x - -- Float word size conversion ---------------------- - MO_FF_Conv W64 W32 -> coerceDbl2Flt x - MO_FF_Conv W32 W64 -> coerceFlt2Dbl x + -- Float word size conversion ---------------------- + MO_FF_Conv W64 W32 -> coerceDbl2Flt x + MO_FF_Conv W32 W64 -> coerceFlt2Dbl x - -- Float <-> Signed Int conversion ----------------- - MO_FS_Conv from to -> coerceFP2Int from to x - MO_SF_Conv from to -> coerceInt2FP from to x + -- Float <-> Signed Int conversion ----------------- + MO_FS_Conv from to -> coerceFP2Int from to x + MO_SF_Conv from to -> coerceInt2FP from to x - -- Unsigned integer word size conversions ---------- + -- Unsigned integer word size conversions ---------- - -- If it's the same size, then nothing needs to be done. - MO_UU_Conv from to - | from == to -> conversionNop (intSize to) x + -- If it's the same size, then nothing needs to be done. + MO_UU_Conv from to + | from == to -> conversionNop (intSize to) x - -- To narrow an unsigned word, mask out the high bits to simulate what would - -- happen if we copied the value into a smaller register. - MO_UU_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - MO_UU_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) + -- To narrow an unsigned word, mask out the high bits to simulate what would + -- happen if we copied the value into a smaller register. + MO_UU_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) + MO_UU_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8 - -- case because the only way we can load it is via SETHI, which needs 2 ops. - -- Do some shifts to chop out the high bits instead. - MO_UU_Conv W32 W16 - -> do tmpReg <- getNewRegNat II32 - (xReg, xCode) <- getSomeReg x - let code dst - = xCode - `appOL` toOL - [ SLL xReg (RIImm $ ImmInt 16) tmpReg - , SRL tmpReg (RIImm $ ImmInt 16) dst] - - return $ Any II32 code - - -- trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) + -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8 + -- case because the only way we can load it is via SETHI, which needs 2 ops. + -- Do some shifts to chop out the high bits instead. + MO_UU_Conv W32 W16 + -> do tmpReg <- getNewRegNat II32 + (xReg, xCode) <- getSomeReg x + let code dst + = xCode + `appOL` toOL + [ SLL xReg (RIImm $ ImmInt 16) tmpReg + , SRL tmpReg (RIImm $ ImmInt 16) dst] - -- To widen an unsigned word we don't have to do anything. - -- Just leave it in the same register and mark the result as the new size. - MO_UU_Conv W8 W16 -> conversionNop (intSize W16) x - MO_UU_Conv W8 W32 -> conversionNop (intSize W32) x - MO_UU_Conv W16 W32 -> conversionNop (intSize W32) x + return $ Any II32 code + -- trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) - -- Signed integer word size conversions ------------ + -- To widen an unsigned word we don't have to do anything. + -- Just leave it in the same register and mark the result as the new size. + MO_UU_Conv W8 W16 -> conversionNop (intSize W16) x + MO_UU_Conv W8 W32 -> conversionNop (intSize W32) x + MO_UU_Conv W16 W32 -> conversionNop (intSize W32) x - -- Mask out high bits when narrowing them - MO_SS_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - MO_SS_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - MO_SS_Conv W32 W16 -> trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) - -- Sign extend signed words when widening them. - MO_SS_Conv W8 W16 -> integerExtend W8 W16 x - MO_SS_Conv W8 W32 -> integerExtend W8 W32 x - MO_SS_Conv W16 W32 -> integerExtend W16 W32 x + -- Signed integer word size conversions ------------ - _ -> panic ("Unknown unary mach op: " ++ show mop) + -- Mask out high bits when narrowing them + MO_SS_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) + MO_SS_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) + MO_SS_Conv W32 W16 -> trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) + + -- Sign extend signed words when widening them. + MO_SS_Conv W8 W16 -> integerExtend W8 W16 x + MO_SS_Conv W8 W32 -> integerExtend W8 W32 x + MO_SS_Conv W16 W32 -> integerExtend W16 W32 x + + _ -> panic ("Unknown unary mach op: " ++ show mop) -- Binary machine ops -getRegister (CmmMachOp mop [x, y]) +getRegister (CmmMachOp mop [x, y]) = case mop of - MO_Eq _ -> condIntReg EQQ x y - MO_Ne _ -> condIntReg NE x y - - MO_S_Gt _ -> condIntReg GTT x y - MO_S_Ge _ -> condIntReg GE x y - MO_S_Lt _ -> condIntReg LTT x y - MO_S_Le _ -> condIntReg LE x y - - MO_U_Gt W32 -> condIntReg GU x y - MO_U_Ge W32 -> condIntReg GEU x y - MO_U_Lt W32 -> condIntReg LU x y - MO_U_Le W32 -> condIntReg LEU x y - - MO_U_Gt W16 -> condIntReg GU x y - MO_U_Ge W16 -> condIntReg GEU x y - MO_U_Lt W16 -> condIntReg LU x y - MO_U_Le W16 -> condIntReg LEU x y - - MO_Add W32 -> trivialCode W32 (ADD False False) x y - MO_Sub W32 -> trivialCode W32 (SUB False False) x y + MO_Eq _ -> condIntReg EQQ x y + MO_Ne _ -> condIntReg NE x y + + MO_S_Gt _ -> condIntReg GTT x y + MO_S_Ge _ -> condIntReg GE x y + MO_S_Lt _ -> condIntReg LTT x y + MO_S_Le _ -> condIntReg LE x y + + MO_U_Gt W32 -> condIntReg GU x y + MO_U_Ge W32 -> condIntReg GEU x y + MO_U_Lt W32 -> condIntReg LU x y + MO_U_Le W32 -> condIntReg LEU x y + + MO_U_Gt W16 -> condIntReg GU x y + MO_U_Ge W16 -> condIntReg GEU x y + MO_U_Lt W16 -> condIntReg LU x y + MO_U_Le W16 -> condIntReg LEU x y + + MO_Add W32 -> trivialCode W32 (ADD False False) x y + MO_Sub W32 -> trivialCode W32 (SUB False False) x y MO_S_MulMayOflo rep -> imulMayOflo rep x y - MO_S_Quot W32 -> idiv True False x y - MO_U_Quot W32 -> idiv False False x y - - MO_S_Rem W32 -> irem True x y - MO_U_Rem W32 -> irem False x y - - MO_F_Eq _ -> condFltReg EQQ x y - MO_F_Ne _ -> condFltReg NE x y + MO_S_Quot W32 -> idiv True False x y + MO_U_Quot W32 -> idiv False False x y + + MO_S_Rem W32 -> irem True x y + MO_U_Rem W32 -> irem False x y + + MO_F_Eq _ -> condFltReg EQQ x y + MO_F_Ne _ -> condFltReg NE x y - MO_F_Gt _ -> condFltReg GTT x y - MO_F_Ge _ -> condFltReg GE x y - MO_F_Lt _ -> condFltReg LTT x y - MO_F_Le _ -> condFltReg LE x y + MO_F_Gt _ -> condFltReg GTT x y + MO_F_Ge _ -> condFltReg GE x y + MO_F_Lt _ -> condFltReg LTT x y + MO_F_Le _ -> condFltReg LE x y - MO_F_Add w -> trivialFCode w FADD x y - MO_F_Sub w -> trivialFCode w FSUB x y - MO_F_Mul w -> trivialFCode w FMUL x y - MO_F_Quot w -> trivialFCode w FDIV x y + MO_F_Add w -> trivialFCode w FADD x y + MO_F_Sub w -> trivialFCode w FSUB x y + MO_F_Mul w -> trivialFCode w FMUL x y + MO_F_Quot w -> trivialFCode w FDIV x y - MO_And rep -> trivialCode rep (AND False) x y - MO_Or rep -> trivialCode rep (OR False) x y - MO_Xor rep -> trivialCode rep (XOR False) x y + MO_And rep -> trivialCode rep (AND False) x y + MO_Or rep -> trivialCode rep (OR False) x y + MO_Xor rep -> trivialCode rep (XOR False) x y - MO_Mul rep -> trivialCode rep (SMUL False) x y + MO_Mul rep -> trivialCode rep (SMUL False) x y - MO_Shl rep -> trivialCode rep SLL x y - MO_U_Shr rep -> trivialCode rep SRL x y - MO_S_Shr rep -> trivialCode rep SRA x y + MO_Shl rep -> trivialCode rep SLL x y + MO_U_Shr rep -> trivialCode rep SRL x y + MO_S_Shr rep -> trivialCode rep SRA x y - _ -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop) + _ -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop) where getRegister (CmmLoad mem pk) = do Amode src code <- getAmode mem let - code__2 dst = code `snocOL` LD (cmmTypeSize pk) src dst + code__2 dst = code `snocOL` LD (cmmTypeSize pk) src dst return (Any (cmmTypeSize pk) code__2) getRegister (CmmLit (CmmInt i _)) | fits13Bits i = let - src = ImmInt (fromInteger i) - code dst = unitOL (OR False g0 (RIImm src) dst) + src = ImmInt (fromInteger i) + code dst = unitOL (OR False g0 (RIImm src) dst) in - return (Any II32 code) + return (Any II32 code) getRegister (CmmLit lit) = let imm = litToImm lit - code dst = toOL [ - SETHI (HI imm) dst, - OR False dst (RIImm (LO imm)) dst] + code dst = toOL [ + SETHI (HI imm) dst, + OR False dst (RIImm (LO imm)) dst] in return (Any II32 code) getRegister _ - = panic "SPARC.CodeGen.Gen32.getRegister: no match" + = panic "SPARC.CodeGen.Gen32.getRegister: no match" -- | sign extend and widen -integerExtend - :: Width -- ^ width of source expression - -> Width -- ^ width of result - -> CmmExpr -- ^ source expression - -> NatM Register +integerExtend + :: Width -- ^ width of source expression + -> Width -- ^ width of result + -> CmmExpr -- ^ source expression + -> NatM Register integerExtend from to expr - = do -- load the expr into some register - (reg, e_code) <- getSomeReg expr - tmp <- getNewRegNat II32 - let bitCount - = case (from, to) of - (W8, W32) -> 24 - (W16, W32) -> 16 - (W8, W16) -> 24 - _ -> panic "SPARC.CodeGen.Gen32: no match" - let code dst - = e_code - - -- local shift word left to load the sign bit - `snocOL` SLL reg (RIImm (ImmInt bitCount)) tmp - - -- arithmetic shift right to sign extend - `snocOL` SRA tmp (RIImm (ImmInt bitCount)) dst - - return (Any (intSize to) code) - + = do -- load the expr into some register + (reg, e_code) <- getSomeReg expr + tmp <- getNewRegNat II32 + let bitCount + = case (from, to) of + (W8, W32) -> 24 + (W16, W32) -> 16 + (W8, W16) -> 24 + _ -> panic "SPARC.CodeGen.Gen32: no match" + let code dst + = e_code + + -- local shift word left to load the sign bit + `snocOL` SLL reg (RIImm (ImmInt bitCount)) tmp + + -- arithmetic shift right to sign extend + `snocOL` SRA tmp (RIImm (ImmInt bitCount)) dst + + return (Any (intSize to) code) + -- | For nop word format conversions we set the resulting value to have the --- required size, but don't need to generate any actual code. +-- required size, but don't need to generate any actual code. -- conversionNop - :: Size -> CmmExpr -> NatM Register + :: Size -> CmmExpr -> NatM Register conversionNop new_rep expr - = do e_code <- getRegister expr - return (setSizeOfRegister e_code new_rep) + = do e_code <- getRegister expr + return (setSizeOfRegister e_code new_rep) -- | Generate an integer division instruction. idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register - --- For unsigned division with a 32 bit numerator, --- we can just clear the Y register. -idiv False cc x y + +-- For unsigned division with a 32 bit numerator, +-- we can just clear the Y register. +idiv False cc x y = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ WRY g0 g0 - , UDIV cc a_reg (RIReg b_reg) dst] - - return (Any II32 code) - + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ WRY g0 g0 + , UDIV cc a_reg (RIReg b_reg) dst] + + return (Any II32 code) + -- For _signed_ division with a 32 bit numerator, --- we have to sign extend the numerator into the Y register. -idiv True cc x y +-- we have to sign extend the numerator into the Y register. +idiv True cc x y = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - tmp <- getNewRegNat II32 - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ SRA a_reg (RIImm (ImmInt 16)) tmp -- sign extend - , SRA tmp (RIImm (ImmInt 16)) tmp - - , WRY tmp g0 - , SDIV cc a_reg (RIReg b_reg) dst] - - return (Any II32 code) + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + tmp <- getNewRegNat II32 + + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ SRA a_reg (RIImm (ImmInt 16)) tmp -- sign extend + , SRA tmp (RIImm (ImmInt 16)) tmp + + , WRY tmp g0 + , SDIV cc a_reg (RIReg b_reg) dst] + + return (Any II32 code) -- | Do an integer remainder. -- --- NOTE: The SPARC v8 architecture manual says that integer division --- instructions _may_ generate a remainder, depending on the implementation. --- If so it is _recommended_ that the remainder is placed in the Y register. +-- NOTE: The SPARC v8 architecture manual says that integer division +-- instructions _may_ generate a remainder, depending on the implementation. +-- If so it is _recommended_ that the remainder is placed in the Y register. -- -- The UltraSparc 2007 manual says Y is _undefined_ after division. -- --- The SPARC T2 doesn't store the remainder, not sure about the others. --- It's probably best not to worry about it, and just generate our own --- remainders. +-- The SPARC T2 doesn't store the remainder, not sure about the others. +-- It's probably best not to worry about it, and just generate our own +-- remainders. -- irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register --- For unsigned operands: --- Division is between a 64 bit numerator and a 32 bit denominator, --- so we still have to clear the Y register. -irem False x y +-- For unsigned operands: +-- Division is between a 64 bit numerator and a 32 bit denominator, +-- so we still have to clear the Y register. +irem False x y = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + tmp_reg <- getNewRegNat II32 - tmp_reg <- getNewRegNat II32 + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ WRY g0 g0 + , UDIV False a_reg (RIReg b_reg) tmp_reg + , UMUL False tmp_reg (RIReg b_reg) tmp_reg + , SUB False False a_reg (RIReg tmp_reg) dst] + + return (Any II32 code) - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ WRY g0 g0 - , UDIV False a_reg (RIReg b_reg) tmp_reg - , UMUL False tmp_reg (RIReg b_reg) tmp_reg - , SUB False False a_reg (RIReg tmp_reg) dst] - - return (Any II32 code) - -- For signed operands: --- Make sure to sign extend into the Y register, or the remainder --- will have the wrong sign when the numerator is negative. +-- Make sure to sign extend into the Y register, or the remainder +-- will have the wrong sign when the numerator is negative. -- --- TODO: When sign extending, GCC only shifts the a_reg right by 17 bits, --- not the full 32. Not sure why this is, something to do with overflow? --- If anyone cares enough about the speed of signed remainder they --- can work it out themselves (then tell me). -- BL 2009/01/20 -irem True x y +-- TODO: When sign extending, GCC only shifts the a_reg right by 17 bits, +-- not the full 32. Not sure why this is, something to do with overflow? +-- If anyone cares enough about the speed of signed remainder they +-- can work it out themselves (then tell me). -- BL 2009/01/20 +irem True x y = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - tmp1_reg <- getNewRegNat II32 - tmp2_reg <- getNewRegNat II32 - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ SRA a_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend - , SRA tmp1_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend - , WRY tmp1_reg g0 - - , SDIV False a_reg (RIReg b_reg) tmp2_reg - , SMUL False tmp2_reg (RIReg b_reg) tmp2_reg - , SUB False False a_reg (RIReg tmp2_reg) dst] - - return (Any II32 code) - + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + tmp1_reg <- getNewRegNat II32 + tmp2_reg <- getNewRegNat II32 + + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ SRA a_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend + , SRA tmp1_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend + , WRY tmp1_reg g0 + + , SDIV False a_reg (RIReg b_reg) tmp2_reg + , SMUL False tmp2_reg (RIReg b_reg) tmp2_reg + , SUB False False a_reg (RIReg tmp2_reg) dst] + + return (Any II32 code) + imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register -imulMayOflo rep a b +imulMayOflo rep a b = do - (a_reg, a_code) <- getSomeReg a - (b_reg, b_code) <- getSomeReg b - res_lo <- getNewRegNat II32 - res_hi <- getNewRegNat II32 - - let shift_amt = case rep of - W32 -> 31 - W64 -> 63 - _ -> panic "shift_amt" - - let code dst = a_code `appOL` b_code `appOL` + (a_reg, a_code) <- getSomeReg a + (b_reg, b_code) <- getSomeReg b + res_lo <- getNewRegNat II32 + res_hi <- getNewRegNat II32 + + let shift_amt = case rep of + W32 -> 31 + W64 -> 63 + _ -> panic "shift_amt" + + let code dst = a_code `appOL` b_code `appOL` toOL [ SMUL False a_reg (RIReg b_reg) res_lo, RDY res_hi, SRA res_lo (RIImm (ImmInt shift_amt)) res_lo, SUB False False res_lo (RIReg res_hi) dst ] - return (Any II32 code) + return (Any II32 code) -- ----------------------------------------------------------------------------- @@ -458,19 +450,19 @@ imulMayOflo rep a b -- have handled the constant-folding. trivialCode - :: Width - -> (Reg -> RI -> Reg -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register - + :: Width + -> (Reg -> RI -> Reg -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register + trivialCode _ instr x (CmmLit (CmmInt y _)) | fits13Bits y = do (src1, code) <- getSomeReg x let - src2 = ImmInt (fromInteger y) - code__2 dst = code `snocOL` instr src1 (RIImm src2) dst + src2 = ImmInt (fromInteger y) + code__2 dst = code `snocOL` instr src1 (RIImm src2) dst return (Any II32 code__2) @@ -478,17 +470,17 @@ trivialCode _ instr x y = do (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y let - code__2 dst = code1 `appOL` code2 `snocOL` - instr src1 (RIReg src2) dst + code__2 dst = code1 `appOL` code2 `snocOL` + instr src1 (RIReg src2) dst return (Any II32 code__2) -trivialFCode - :: Width - -> (Size -> Reg -> Reg -> Reg -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register +trivialFCode + :: Width + -> (Size -> Reg -> Reg -> Reg -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register trivialFCode pk instr x y = do dflags <- getDynFlags @@ -496,49 +488,49 @@ trivialFCode pk instr x y = do (src2, code2) <- getSomeReg y tmp <- getNewRegNat FF64 let - promote x = FxTOy FF32 FF64 x tmp + promote x = FxTOy FF32 FF64 x tmp - pk1 = cmmExprType dflags x - pk2 = cmmExprType dflags y + pk1 = cmmExprType dflags x + pk2 = cmmExprType dflags y - code__2 dst = - if pk1 `cmmEqType` pk2 then - code1 `appOL` code2 `snocOL` - instr (floatSize pk) src1 src2 dst - else if typeWidth pk1 == W32 then - code1 `snocOL` promote src1 `appOL` code2 `snocOL` - instr FF64 tmp src2 dst - else - code1 `appOL` code2 `snocOL` promote src2 `snocOL` - instr FF64 src1 tmp dst - return (Any (cmmTypeSize $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64) - code__2) + code__2 dst = + if pk1 `cmmEqType` pk2 then + code1 `appOL` code2 `snocOL` + instr (floatSize pk) src1 src2 dst + else if typeWidth pk1 == W32 then + code1 `snocOL` promote src1 `appOL` code2 `snocOL` + instr FF64 tmp src2 dst + else + code1 `appOL` code2 `snocOL` promote src2 `snocOL` + instr FF64 src1 tmp dst + return (Any (cmmTypeSize $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64) + code__2) trivialUCode - :: Size - -> (RI -> Reg -> Instr) - -> CmmExpr - -> NatM Register - + :: Size + -> (RI -> Reg -> Instr) + -> CmmExpr + -> NatM Register + trivialUCode size instr x = do (src, code) <- getSomeReg x let - code__2 dst = code `snocOL` instr (RIReg src) dst + code__2 dst = code `snocOL` instr (RIReg src) dst return (Any size code__2) -trivialUFCode - :: Size - -> (Reg -> Reg -> Instr) - -> CmmExpr - -> NatM Register - +trivialUFCode + :: Size + -> (Reg -> Reg -> Instr) + -> CmmExpr + -> NatM Register + trivialUFCode pk instr x = do (src, code) <- getSomeReg x let - code__2 dst = code `snocOL` instr src dst + code__2 dst = code `snocOL` instr src dst return (Any pk code__2) @@ -551,10 +543,10 @@ coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register coerceInt2FP width1 width2 x = do (src, code) <- getSomeReg x let - code__2 dst = code `appOL` toOL [ - ST (intSize width1) src (spRel (-2)), - LD (intSize width1) (spRel (-2)) dst, - FxTOy (intSize width1) (floatSize width2) dst dst] + code__2 dst = code `appOL` toOL [ + ST (intSize width1) src (spRel (-2)), + LD (intSize width1) (spRel (-2)) dst, + FxTOy (intSize width1) (floatSize width2) dst dst] return (Any (floatSize $ width2) code__2) @@ -562,37 +554,37 @@ coerceInt2FP width1 width2 x = do -- | Coerce a floating point value to integer -- -- NOTE: On sparc v9 there are no instructions to move a value from an --- FP register directly to an int register, so we have to use a load/store. +-- FP register directly to an int register, so we have to use a load/store. -- coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register -coerceFP2Int width1 width2 x - = do let fsize1 = floatSize width1 - fsize2 = floatSize width2 - - isize2 = intSize width2 +coerceFP2Int width1 width2 x + = do let fsize1 = floatSize width1 + fsize2 = floatSize width2 + + isize2 = intSize width2 + + (fsrc, code) <- getSomeReg x + fdst <- getNewRegNat fsize2 - (fsrc, code) <- getSomeReg x - fdst <- getNewRegNat fsize2 - - let code2 dst - = code - `appOL` toOL - -- convert float to int format, leaving it in a float reg. - [ FxTOy fsize1 isize2 fsrc fdst + let code2 dst + = code + `appOL` toOL + -- convert float to int format, leaving it in a float reg. + [ FxTOy fsize1 isize2 fsrc fdst - -- store the int into mem, then load it back to move - -- it into an actual int reg. - , ST fsize2 fdst (spRel (-2)) - , LD isize2 (spRel (-2)) dst] + -- store the int into mem, then load it back to move + -- it into an actual int reg. + , ST fsize2 fdst (spRel (-2)) + , LD isize2 (spRel (-2)) dst] - return (Any isize2 code2) + return (Any isize2 code2) -- | Coerce a double precision floating point value to single precision. coerceDbl2Flt :: CmmExpr -> NatM Register coerceDbl2Flt x = do (src, code) <- getSomeReg x - return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst)) + return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst)) -- | Coerce a single precision floating point value to double precision @@ -607,44 +599,44 @@ coerceFlt2Dbl x = do -- Condition Codes ------------------------------------------------------------- -- -- Evaluate a comparison, and get the result into a register. --- +-- -- Do not fill the delay slots here. you will confuse the register allocator. -- condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register condIntReg EQQ x (CmmLit (CmmInt 0 _)) = do (src, code) <- getSomeReg x let - code__2 dst = code `appOL` toOL [ - SUB False True g0 (RIReg src) g0, - SUB True False g0 (RIImm (ImmInt (-1))) dst] + code__2 dst = code `appOL` toOL [ + SUB False True g0 (RIReg src) g0, + SUB True False g0 (RIImm (ImmInt (-1))) dst] return (Any II32 code__2) condIntReg EQQ x y = do (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y let - code__2 dst = code1 `appOL` code2 `appOL` toOL [ - XOR False src1 (RIReg src2) dst, - SUB False True g0 (RIReg dst) g0, - SUB True False g0 (RIImm (ImmInt (-1))) dst] + code__2 dst = code1 `appOL` code2 `appOL` toOL [ + XOR False src1 (RIReg src2) dst, + SUB False True g0 (RIReg dst) g0, + SUB True False g0 (RIImm (ImmInt (-1))) dst] return (Any II32 code__2) condIntReg NE x (CmmLit (CmmInt 0 _)) = do (src, code) <- getSomeReg x let - code__2 dst = code `appOL` toOL [ - SUB False True g0 (RIReg src) g0, - ADD True False g0 (RIImm (ImmInt 0)) dst] + code__2 dst = code `appOL` toOL [ + SUB False True g0 (RIReg src) g0, + ADD True False g0 (RIImm (ImmInt 0)) dst] return (Any II32 code__2) condIntReg NE x y = do (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y let - code__2 dst = code1 `appOL` code2 `appOL` toOL [ - XOR False src1 (RIReg src2) dst, - SUB False True g0 (RIReg dst) g0, - ADD True False g0 (RIImm (ImmInt 0)) dst] + code__2 dst = code1 `appOL` code2 `appOL` toOL [ + XOR False src1 (RIReg src2) dst, + SUB False True g0 (RIReg dst) g0, + ADD True False g0 (RIImm (ImmInt 0)) dst] return (Any II32 code__2) condIntReg cond x y = do @@ -652,22 +644,22 @@ condIntReg cond x y = do bid2 <- liftM (\a -> seq a a) getBlockIdNat CondCode _ cond cond_code <- condIntCode cond x y let - code__2 dst - = cond_code - `appOL` toOL - [ BI cond False bid1 - , NOP + code__2 dst + = cond_code + `appOL` toOL + [ BI cond False bid1 + , NOP - , OR False g0 (RIImm (ImmInt 0)) dst - , BI ALWAYS False bid2 - , NOP + , OR False g0 (RIImm (ImmInt 0)) dst + , BI ALWAYS False bid2 + , NOP - , NEWBLOCK bid1 - , OR False g0 (RIImm (ImmInt 1)) dst - , BI ALWAYS False bid2 - , NOP + , NEWBLOCK bid1 + , OR False g0 (RIImm (ImmInt 1)) dst + , BI ALWAYS False bid2 + , NOP - , NEWBLOCK bid2] + , NEWBLOCK bid2] return (Any II32 code__2) @@ -679,26 +671,22 @@ condFltReg cond x y = do CondCode _ cond cond_code <- condFltCode cond x y let - code__2 dst - = cond_code - `appOL` toOL - [ NOP - , BF cond False bid1 - , NOP + code__2 dst + = cond_code + `appOL` toOL + [ NOP + , BF cond False bid1 + , NOP - , OR False g0 (RIImm (ImmInt 0)) dst - , BI ALWAYS False bid2 - , NOP + , OR False g0 (RIImm (ImmInt 0)) dst + , BI ALWAYS False bid2 + , NOP - , NEWBLOCK bid1 - , OR False g0 (RIImm (ImmInt 1)) dst - , BI ALWAYS False bid2 - , NOP + , NEWBLOCK bid1 + , OR False g0 (RIImm (ImmInt 1)) dst + , BI ALWAYS False bid2 + , NOP - , NEWBLOCK bid2 ] + , NEWBLOCK bid2 ] return (Any II32 code__2) - - - - diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs index 5dff9ce704..81641326f2 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs @@ -1,22 +1,13 @@ - -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - --- | One ounce of sanity checking is worth 10000000000000000 ounces --- of staring blindly at assembly code trying to find the problem.. --- +-- | One ounce of sanity checking is worth 10000000000000000 ounces +-- of staring blindly at assembly code trying to find the problem.. module SPARC.CodeGen.Sanity ( - checkBlock + checkBlock ) where import SPARC.Instr -import SPARC.Ppr () +import SPARC.Ppr () import Instruction import Cmm @@ -31,48 +22,46 @@ checkBlock :: CmmBlock -> NatBasicBlock Instr checkBlock cmm block@(BasicBlock _ instrs) - | checkBlockInstrs instrs - = block - - | otherwise - = pprPanic - ("SPARC.CodeGen: bad block\n") - ( vcat [ text " -- cmm -----------------\n" - , ppr cmm - , text " -- native code ---------\n" - , ppr block ]) + | checkBlockInstrs instrs + = block + + | otherwise + = pprPanic + ("SPARC.CodeGen: bad block\n") + ( vcat [ text " -- cmm -----------------\n" + , ppr cmm + , text " -- native code ---------\n" + , ppr block ]) checkBlockInstrs :: [Instr] -> Bool checkBlockInstrs ii - -- An unconditional jumps end the block. - -- There must be an unconditional jump in the block, otherwise - -- the register liveness determinator will get the liveness - -- information wrong. - -- - -- If the block ends with a cmm call that never returns - -- then there can be unreachable instructions after the jump, - -- but we don't mind here. - -- - | instr : NOP : _ <- ii - , isUnconditionalJump instr - = True - - -- All jumps must have a NOP in their branch delay slot. - -- The liveness determinator and register allocators aren't smart - -- enough to handle branch delay slots. - -- - | instr : NOP : is <- ii - , isJumpishInstr instr - = checkBlockInstrs is - - -- keep checking - | _:i2:is <- ii - = checkBlockInstrs (i2:is) - - -- this block is no good - | otherwise - = False - - + -- An unconditional jumps end the block. + -- There must be an unconditional jump in the block, otherwise + -- the register liveness determinator will get the liveness + -- information wrong. + -- + -- If the block ends with a cmm call that never returns + -- then there can be unreachable instructions after the jump, + -- but we don't mind here. + -- + | instr : NOP : _ <- ii + , isUnconditionalJump instr + = True + + -- All jumps must have a NOP in their branch delay slot. + -- The liveness determinator and register allocators aren't smart + -- enough to handle branch delay slots. + -- + | instr : NOP : is <- ii + , isJumpishInstr instr + = checkBlockInstrs is + + -- keep checking + | _:i2:is <- ii + = checkBlockInstrs (i2:is) + + -- this block is no good + | otherwise + = False diff --git a/compiler/nativeGen/SPARC/Cond.hs b/compiler/nativeGen/SPARC/Cond.hs index 198e4a7627..da41457950 100644 --- a/compiler/nativeGen/SPARC/Cond.hs +++ b/compiler/nativeGen/SPARC/Cond.hs @@ -1,39 +1,31 @@ - -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.Cond ( - Cond(..), - condUnsigned, - condToSigned, - condToUnsigned + Cond(..), + condUnsigned, + condToSigned, + condToUnsigned ) where -- | Branch condition codes. data Cond - = ALWAYS - | EQQ - | GE - | GEU - | GTT - | GU - | LE - | LEU - | LTT - | LU - | NE - | NEG - | NEVER - | POS - | VC - | VS - deriving Eq + = ALWAYS + | EQQ + | GE + | GEU + | GTT + | GU + | LE + | LEU + | LTT + | LU + | NE + | NEG + | NEVER + | POS + | VC + | VS + deriving Eq condUnsigned :: Cond -> Bool diff --git a/compiler/nativeGen/SPARC/Imm.hs b/compiler/nativeGen/SPARC/Imm.hs index 844a08824b..cb53ba411c 100644 --- a/compiler/nativeGen/SPARC/Imm.hs +++ b/compiler/nativeGen/SPARC/Imm.hs @@ -1,16 +1,8 @@ - -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.Imm ( - -- immediate values - Imm(..), - strImmLit, - litToImm + -- immediate values + Imm(..), + strImmLit, + litToImm ) where @@ -21,29 +13,29 @@ import CLabel import Outputable -- | An immediate value. --- Not all of these are directly representable by the machine. --- Things like ImmLit are slurped out and put in a data segment instead. +-- Not all of these are directly representable by the machine. +-- Things like ImmLit are slurped out and put in a data segment instead. -- data Imm - = ImmInt Int + = ImmInt Int - -- Sigh. - | ImmInteger Integer + -- Sigh. + | ImmInteger Integer - -- AbstractC Label (with baggage) - | ImmCLbl CLabel + -- AbstractC Label (with baggage) + | ImmCLbl CLabel - -- Simple string - | ImmLit SDoc - | ImmIndex CLabel Int - | ImmFloat Rational - | ImmDouble Rational + -- Simple string + | ImmLit SDoc + | ImmIndex CLabel Int + | ImmFloat Rational + | ImmDouble Rational - | ImmConstantSum Imm Imm - | ImmConstantDiff Imm Imm + | ImmConstantSum Imm Imm + | ImmConstantDiff Imm Imm - | LO Imm - | HI Imm + | LO Imm + | HI Imm -- | Create a ImmLit containing this string. @@ -52,24 +44,22 @@ strImmLit s = ImmLit (text s) -- | Convert a CmmLit to an Imm. --- Narrow to the width: a CmmInt might be out of --- range, but we assume that ImmInteger only contains --- in-range values. A signed value should be fine here. +-- Narrow to the width: a CmmInt might be out of +-- range, but we assume that ImmInteger only contains +-- in-range values. A signed value should be fine here. -- litToImm :: CmmLit -> Imm litToImm lit = case lit of - CmmInt i w -> ImmInteger (narrowS w i) - CmmFloat f W32 -> ImmFloat f - CmmFloat f W64 -> ImmDouble f - CmmLabel l -> ImmCLbl l - CmmLabelOff l off -> ImmIndex l off + CmmInt i w -> ImmInteger (narrowS w i) + CmmFloat f W32 -> ImmFloat f + CmmFloat f W64 -> ImmDouble f + CmmLabel l -> ImmCLbl l + CmmLabelOff l off -> ImmIndex l off - CmmLabelDiffOff l1 l2 off - -> ImmConstantSum - (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) - (ImmInt off) + CmmLabelDiffOff l1 l2 off + -> ImmConstantSum + (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) + (ImmInt off) _ -> panic "SPARC.Regs.litToImm: no match" - - diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 8e4a2b32df..fb8cc0cadc 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -7,28 +7,20 @@ -- (c) The University of Glasgow 1993-2004 -- ----------------------------------------------------------------------------- - -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - #include "HsVersions.h" #include "nativeGen/NCG.h" module SPARC.Instr ( - RI(..), - riZero, - - fpRelEA, - moveSp, - - isUnconditionalJump, - - Instr(..), - maxSpillSlots + RI(..), + riZero, + + fpRelEA, + moveSp, + + isUnconditionalJump, + + Instr(..), + maxSpillSlots ) where @@ -57,23 +49,23 @@ import Platform -- | Register or immediate -data RI - = RIReg Reg - | RIImm Imm +data RI + = RIReg Reg + | RIImm Imm -- | Check if a RI represents a zero value. --- - a literal zero --- - register %g0, which is always zero. +-- - a literal zero +-- - register %g0, which is always zero. -- -riZero :: RI -> Bool -riZero (RIImm (ImmInt 0)) = True -riZero (RIImm (ImmInteger 0)) = True -riZero (RIReg (RegReal (RealRegSingle 0))) = True -riZero _ = False +riZero :: RI -> Bool +riZero (RIImm (ImmInt 0)) = True +riZero (RIImm (ImmInteger 0)) = True +riZero (RIReg (RegReal (RealRegSingle 0))) = True +riZero _ = False -- | Calculate the effective address which would be used by the --- corresponding fpRel sequence. +-- corresponding fpRel sequence. fpRelEA :: Int -> Reg -> Instr fpRelEA n dst = ADD False False fp (RIImm (ImmInt (n * wordLength))) dst @@ -88,294 +80,294 @@ moveSp n isUnconditionalJump :: Instr -> Bool isUnconditionalJump ii = case ii of - CALL{} -> True - JMP{} -> True - JMP_TBL{} -> True - BI ALWAYS _ _ -> True - BF ALWAYS _ _ -> True - _ -> False + CALL{} -> True + JMP{} -> True + JMP_TBL{} -> True + BI ALWAYS _ _ -> True + BF ALWAYS _ _ -> True + _ -> False -- | instance for sparc instruction set instance Instruction Instr where - regUsageOfInstr = sparc_regUsageOfInstr - patchRegsOfInstr = sparc_patchRegsOfInstr - isJumpishInstr = sparc_isJumpishInstr - jumpDestsOfInstr = sparc_jumpDestsOfInstr - patchJumpInstr = sparc_patchJumpInstr - mkSpillInstr = sparc_mkSpillInstr - mkLoadInstr = sparc_mkLoadInstr - takeDeltaInstr = sparc_takeDeltaInstr - isMetaInstr = sparc_isMetaInstr - mkRegRegMoveInstr = sparc_mkRegRegMoveInstr - takeRegRegMoveInstr = sparc_takeRegRegMoveInstr - mkJumpInstr = sparc_mkJumpInstr + regUsageOfInstr = sparc_regUsageOfInstr + patchRegsOfInstr = sparc_patchRegsOfInstr + isJumpishInstr = sparc_isJumpishInstr + jumpDestsOfInstr = sparc_jumpDestsOfInstr + patchJumpInstr = sparc_patchJumpInstr + mkSpillInstr = sparc_mkSpillInstr + mkLoadInstr = sparc_mkLoadInstr + takeDeltaInstr = sparc_takeDeltaInstr + isMetaInstr = sparc_isMetaInstr + mkRegRegMoveInstr = sparc_mkRegRegMoveInstr + takeRegRegMoveInstr = sparc_takeRegRegMoveInstr + mkJumpInstr = sparc_mkJumpInstr mkStackAllocInstr = panic "no sparc_mkStackAllocInstr" mkStackDeallocInstr = panic "no sparc_mkStackDeallocInstr" -- | SPARC instruction set. --- Not complete. This is only the ones we need. +-- Not complete. This is only the ones we need. -- data Instr - -- meta ops -------------------------------------------------- - -- comment pseudo-op - = COMMENT FastString - - -- some static data spat out during code generation. - -- Will be extracted before pretty-printing. - | LDATA Section CmmStatics - - -- Start a new basic block. Useful during codegen, removed later. - -- Preceding instruction should be a jump, as per the invariants - -- for a BasicBlock (see Cmm). - | NEWBLOCK BlockId - - -- specify current stack offset for benefit of subsequent passes. - | DELTA Int - - -- real instrs ----------------------------------------------- - -- Loads and stores. - | LD Size AddrMode Reg -- size, src, dst - | ST Size Reg AddrMode -- size, src, dst - - -- Int Arithmetic. - -- x: add/sub with carry bit. - -- In SPARC V9 addx and friends were renamed addc. - -- - -- cc: modify condition codes - -- - | ADD Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst - | SUB Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst - - | UMUL Bool Reg RI Reg -- cc?, src1, src2, dst - | SMUL Bool Reg RI Reg -- cc?, src1, src2, dst - - - -- The SPARC divide instructions perform 64bit by 32bit division - -- The Y register is xored into the first operand. - - -- On _some implementations_ the Y register is overwritten by - -- the remainder, so we have to make sure it is 0 each time. - - -- dst <- ((Y `shiftL` 32) `or` src1) `div` src2 - | UDIV Bool Reg RI Reg -- cc?, src1, src2, dst - | SDIV Bool Reg RI Reg -- cc?, src1, src2, dst - - | RDY Reg -- move contents of Y register to reg - | WRY Reg Reg -- Y <- src1 `xor` src2 - - -- Logic operations. - | AND Bool Reg RI Reg -- cc?, src1, src2, dst - | ANDN Bool Reg RI Reg -- cc?, src1, src2, dst - | OR Bool Reg RI Reg -- cc?, src1, src2, dst - | ORN Bool Reg RI Reg -- cc?, src1, src2, dst - | XOR Bool Reg RI Reg -- cc?, src1, src2, dst - | XNOR Bool Reg RI Reg -- cc?, src1, src2, dst - | SLL Reg RI Reg -- src1, src2, dst - | SRL Reg RI Reg -- src1, src2, dst - | SRA Reg RI Reg -- src1, src2, dst - - -- Load immediates. - | SETHI Imm Reg -- src, dst - - -- Do nothing. - -- Implemented by the assembler as SETHI 0, %g0, but worth an alias - | NOP - - -- Float Arithmetic. - -- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single - -- instructions right up until we spit them out. - -- - | FABS Size Reg Reg -- src dst - | FADD Size Reg Reg Reg -- src1, src2, dst - | FCMP Bool Size Reg Reg -- exception?, src1, src2, dst - | FDIV Size Reg Reg Reg -- src1, src2, dst - | FMOV Size Reg Reg -- src, dst - | FMUL Size Reg Reg Reg -- src1, src2, dst - | FNEG Size Reg Reg -- src, dst - | FSQRT Size Reg Reg -- src, dst - | FSUB Size Reg Reg Reg -- src1, src2, dst - | FxTOy Size Size Reg Reg -- src, dst - - -- Jumping around. - | BI Cond Bool BlockId -- cond, annul?, target - | BF Cond Bool BlockId -- cond, annul?, target - - | JMP AddrMode -- target - - -- With a tabled jump we know all the possible destinations. - -- We also need this info so we can work out what regs are live across the jump. - -- - | JMP_TBL AddrMode [Maybe BlockId] CLabel - - | CALL (Either Imm Reg) Int Bool -- target, args, terminal + -- meta ops -------------------------------------------------- + -- comment pseudo-op + = COMMENT FastString + + -- some static data spat out during code generation. + -- Will be extracted before pretty-printing. + | LDATA Section CmmStatics + + -- Start a new basic block. Useful during codegen, removed later. + -- Preceding instruction should be a jump, as per the invariants + -- for a BasicBlock (see Cmm). + | NEWBLOCK BlockId + + -- specify current stack offset for benefit of subsequent passes. + | DELTA Int + + -- real instrs ----------------------------------------------- + -- Loads and stores. + | LD Size AddrMode Reg -- size, src, dst + | ST Size Reg AddrMode -- size, src, dst + + -- Int Arithmetic. + -- x: add/sub with carry bit. + -- In SPARC V9 addx and friends were renamed addc. + -- + -- cc: modify condition codes + -- + | ADD Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst + | SUB Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst + + | UMUL Bool Reg RI Reg -- cc?, src1, src2, dst + | SMUL Bool Reg RI Reg -- cc?, src1, src2, dst + + + -- The SPARC divide instructions perform 64bit by 32bit division + -- The Y register is xored into the first operand. + + -- On _some implementations_ the Y register is overwritten by + -- the remainder, so we have to make sure it is 0 each time. + + -- dst <- ((Y `shiftL` 32) `or` src1) `div` src2 + | UDIV Bool Reg RI Reg -- cc?, src1, src2, dst + | SDIV Bool Reg RI Reg -- cc?, src1, src2, dst + + | RDY Reg -- move contents of Y register to reg + | WRY Reg Reg -- Y <- src1 `xor` src2 + + -- Logic operations. + | AND Bool Reg RI Reg -- cc?, src1, src2, dst + | ANDN Bool Reg RI Reg -- cc?, src1, src2, dst + | OR Bool Reg RI Reg -- cc?, src1, src2, dst + | ORN Bool Reg RI Reg -- cc?, src1, src2, dst + | XOR Bool Reg RI Reg -- cc?, src1, src2, dst + | XNOR Bool Reg RI Reg -- cc?, src1, src2, dst + | SLL Reg RI Reg -- src1, src2, dst + | SRL Reg RI Reg -- src1, src2, dst + | SRA Reg RI Reg -- src1, src2, dst + + -- Load immediates. + | SETHI Imm Reg -- src, dst + + -- Do nothing. + -- Implemented by the assembler as SETHI 0, %g0, but worth an alias + | NOP + + -- Float Arithmetic. + -- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single + -- instructions right up until we spit them out. + -- + | FABS Size Reg Reg -- src dst + | FADD Size Reg Reg Reg -- src1, src2, dst + | FCMP Bool Size Reg Reg -- exception?, src1, src2, dst + | FDIV Size Reg Reg Reg -- src1, src2, dst + | FMOV Size Reg Reg -- src, dst + | FMUL Size Reg Reg Reg -- src1, src2, dst + | FNEG Size Reg Reg -- src, dst + | FSQRT Size Reg Reg -- src, dst + | FSUB Size Reg Reg Reg -- src1, src2, dst + | FxTOy Size Size Reg Reg -- src, dst + + -- Jumping around. + | BI Cond Bool BlockId -- cond, annul?, target + | BF Cond Bool BlockId -- cond, annul?, target + + | JMP AddrMode -- target + + -- With a tabled jump we know all the possible destinations. + -- We also need this info so we can work out what regs are live across the jump. + -- + | JMP_TBL AddrMode [Maybe BlockId] CLabel + + | CALL (Either Imm Reg) Int Bool -- target, args, terminal -- | regUsage returns the sets of src and destination registers used --- by a particular instruction. Machine registers that are --- pre-allocated to stgRegs are filtered out, because they are --- uninteresting from a register allocation standpoint. (We wouldn't --- want them to end up on the free list!) As far as we are concerned, --- the fixed registers simply don't exist (for allocation purposes, --- anyway). - --- regUsage doesn't need to do any trickery for jumps and such. Just --- state precisely the regs read and written by that insn. The --- consequences of control flow transfers, as far as register --- allocation goes, are taken care of by the register allocator. +-- by a particular instruction. Machine registers that are +-- pre-allocated to stgRegs are filtered out, because they are +-- uninteresting from a register allocation standpoint. (We wouldn't +-- want them to end up on the free list!) As far as we are concerned, +-- the fixed registers simply don't exist (for allocation purposes, +-- anyway). + +-- regUsage doesn't need to do any trickery for jumps and such. Just +-- state precisely the regs read and written by that insn. The +-- consequences of control flow transfers, as far as register +-- allocation goes, are taken care of by the register allocator. -- sparc_regUsageOfInstr :: Platform -> Instr -> RegUsage sparc_regUsageOfInstr platform instr = case instr of - LD _ addr reg -> usage (regAddr addr, [reg]) - ST _ reg addr -> usage (reg : regAddr addr, []) - ADD _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SUB _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - UMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - UDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - RDY rd -> usage ([], [rd]) - WRY r1 r2 -> usage ([r1, r2], []) - AND _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ANDN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - OR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ORN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XNOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SLL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRA r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SETHI _ reg -> usage ([], [reg]) - FABS _ r1 r2 -> usage ([r1], [r2]) - FADD _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FCMP _ _ r1 r2 -> usage ([r1, r2], []) - FDIV _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FMOV _ r1 r2 -> usage ([r1], [r2]) - FMUL _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FNEG _ r1 r2 -> usage ([r1], [r2]) - FSQRT _ r1 r2 -> usage ([r1], [r2]) - FSUB _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FxTOy _ _ r1 r2 -> usage ([r1], [r2]) - - JMP addr -> usage (regAddr addr, []) - JMP_TBL addr _ _ -> usage (regAddr addr, []) - - CALL (Left _ ) _ True -> noUsage - CALL (Left _ ) n False -> usage (argRegs n, callClobberedRegs) - CALL (Right reg) _ True -> usage ([reg], []) - CALL (Right reg) n False -> usage (reg : (argRegs n), callClobberedRegs) - _ -> noUsage + LD _ addr reg -> usage (regAddr addr, [reg]) + ST _ reg addr -> usage (reg : regAddr addr, []) + ADD _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SUB _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + UMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + UDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + RDY rd -> usage ([], [rd]) + WRY r1 r2 -> usage ([r1, r2], []) + AND _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + ANDN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + OR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + ORN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + XOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + XNOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SLL r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SRL r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SRA r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SETHI _ reg -> usage ([], [reg]) + FABS _ r1 r2 -> usage ([r1], [r2]) + FADD _ r1 r2 r3 -> usage ([r1, r2], [r3]) + FCMP _ _ r1 r2 -> usage ([r1, r2], []) + FDIV _ r1 r2 r3 -> usage ([r1, r2], [r3]) + FMOV _ r1 r2 -> usage ([r1], [r2]) + FMUL _ r1 r2 r3 -> usage ([r1, r2], [r3]) + FNEG _ r1 r2 -> usage ([r1], [r2]) + FSQRT _ r1 r2 -> usage ([r1], [r2]) + FSUB _ r1 r2 r3 -> usage ([r1, r2], [r3]) + FxTOy _ _ r1 r2 -> usage ([r1], [r2]) + + JMP addr -> usage (regAddr addr, []) + JMP_TBL addr _ _ -> usage (regAddr addr, []) + + CALL (Left _ ) _ True -> noUsage + CALL (Left _ ) n False -> usage (argRegs n, callClobberedRegs) + CALL (Right reg) _ True -> usage ([reg], []) + CALL (Right reg) n False -> usage (reg : (argRegs n), callClobberedRegs) + _ -> noUsage where - usage (src, dst) + usage (src, dst) = RU (filter (interesting platform) src) (filter (interesting platform) dst) - regAddr (AddrRegReg r1 r2) = [r1, r2] - regAddr (AddrRegImm r1 _) = [r1] + regAddr (AddrRegReg r1 r2) = [r1, r2] + regAddr (AddrRegImm r1 _) = [r1] - regRI (RIReg r) = [r] - regRI _ = [] + regRI (RIReg r) = [r] + regRI _ = [] --- | Interesting regs are virtuals, or ones that are allocatable --- by the register allocator. +-- | Interesting regs are virtuals, or ones that are allocatable +-- by the register allocator. interesting :: Platform -> Reg -> Bool interesting platform reg = case reg of - RegVirtual _ -> True - RegReal (RealRegSingle r1) -> isFastTrue (freeReg platform r1) - RegReal (RealRegPair r1 _) -> isFastTrue (freeReg platform r1) + RegVirtual _ -> True + RegReal (RealRegSingle r1) -> isFastTrue (freeReg platform r1) + RegReal (RealRegPair r1 _) -> isFastTrue (freeReg platform r1) -- | Apply a given mapping to tall the register references in this instruction. sparc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr sparc_patchRegsOfInstr instr env = case instr of - LD sz addr reg -> LD sz (fixAddr addr) (env reg) - ST sz reg addr -> ST sz (env reg) (fixAddr addr) - - ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2) - SUB x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2) - UMUL cc r1 ar r2 -> UMUL cc (env r1) (fixRI ar) (env r2) - SMUL cc r1 ar r2 -> SMUL cc (env r1) (fixRI ar) (env r2) - UDIV cc r1 ar r2 -> UDIV cc (env r1) (fixRI ar) (env r2) - SDIV cc r1 ar r2 -> SDIV cc (env r1) (fixRI ar) (env r2) - RDY rd -> RDY (env rd) - WRY r1 r2 -> WRY (env r1) (env r2) - AND b r1 ar r2 -> AND b (env r1) (fixRI ar) (env r2) - ANDN b r1 ar r2 -> ANDN b (env r1) (fixRI ar) (env r2) - OR b r1 ar r2 -> OR b (env r1) (fixRI ar) (env r2) - ORN b r1 ar r2 -> ORN b (env r1) (fixRI ar) (env r2) - XOR b r1 ar r2 -> XOR b (env r1) (fixRI ar) (env r2) - XNOR b r1 ar r2 -> XNOR b (env r1) (fixRI ar) (env r2) - SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2) - SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2) - SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2) - - SETHI imm reg -> SETHI imm (env reg) - - FABS s r1 r2 -> FABS s (env r1) (env r2) - FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3) - FCMP e s r1 r2 -> FCMP e s (env r1) (env r2) - FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3) - FMOV s r1 r2 -> FMOV s (env r1) (env r2) - FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3) - FNEG s r1 r2 -> FNEG s (env r1) (env r2) - FSQRT s r1 r2 -> FSQRT s (env r1) (env r2) - FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3) - FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2) - - JMP addr -> JMP (fixAddr addr) - JMP_TBL addr ids l -> JMP_TBL (fixAddr addr) ids l - - CALL (Left i) n t -> CALL (Left i) n t - CALL (Right r) n t -> CALL (Right (env r)) n t - _ -> instr + LD sz addr reg -> LD sz (fixAddr addr) (env reg) + ST sz reg addr -> ST sz (env reg) (fixAddr addr) + + ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2) + SUB x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2) + UMUL cc r1 ar r2 -> UMUL cc (env r1) (fixRI ar) (env r2) + SMUL cc r1 ar r2 -> SMUL cc (env r1) (fixRI ar) (env r2) + UDIV cc r1 ar r2 -> UDIV cc (env r1) (fixRI ar) (env r2) + SDIV cc r1 ar r2 -> SDIV cc (env r1) (fixRI ar) (env r2) + RDY rd -> RDY (env rd) + WRY r1 r2 -> WRY (env r1) (env r2) + AND b r1 ar r2 -> AND b (env r1) (fixRI ar) (env r2) + ANDN b r1 ar r2 -> ANDN b (env r1) (fixRI ar) (env r2) + OR b r1 ar r2 -> OR b (env r1) (fixRI ar) (env r2) + ORN b r1 ar r2 -> ORN b (env r1) (fixRI ar) (env r2) + XOR b r1 ar r2 -> XOR b (env r1) (fixRI ar) (env r2) + XNOR b r1 ar r2 -> XNOR b (env r1) (fixRI ar) (env r2) + SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2) + SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2) + SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2) + + SETHI imm reg -> SETHI imm (env reg) + + FABS s r1 r2 -> FABS s (env r1) (env r2) + FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3) + FCMP e s r1 r2 -> FCMP e s (env r1) (env r2) + FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3) + FMOV s r1 r2 -> FMOV s (env r1) (env r2) + FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3) + FNEG s r1 r2 -> FNEG s (env r1) (env r2) + FSQRT s r1 r2 -> FSQRT s (env r1) (env r2) + FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3) + FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2) + + JMP addr -> JMP (fixAddr addr) + JMP_TBL addr ids l -> JMP_TBL (fixAddr addr) ids l + + CALL (Left i) n t -> CALL (Left i) n t + CALL (Right r) n t -> CALL (Right (env r)) n t + _ -> instr where - fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) - fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i + fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) + fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i - fixRI (RIReg r) = RIReg (env r) - fixRI other = other + fixRI (RIReg r) = RIReg (env r) + fixRI other = other -------------------------------------------------------------------------------- sparc_isJumpishInstr :: Instr -> Bool sparc_isJumpishInstr instr = case instr of - BI{} -> True - BF{} -> True - JMP{} -> True - JMP_TBL{} -> True - CALL{} -> True - _ -> False + BI{} -> True + BF{} -> True + JMP{} -> True + JMP_TBL{} -> True + CALL{} -> True + _ -> False sparc_jumpDestsOfInstr :: Instr -> [BlockId] sparc_jumpDestsOfInstr insn = case insn of - BI _ _ id -> [id] - BF _ _ id -> [id] - JMP_TBL _ ids _ -> [id | Just id <- ids] - _ -> [] + BI _ _ id -> [id] + BF _ _ id -> [id] + JMP_TBL _ ids _ -> [id | Just id <- ids] + _ -> [] sparc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr sparc_patchJumpInstr insn patchF = case insn of - BI cc annul id -> BI cc annul (patchF id) - BF cc annul id -> BF cc annul (patchF id) - JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l - _ -> insn + BI cc annul id -> BI cc annul (patchF id) + BF cc annul id -> BF cc annul (patchF id) + JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l + _ -> insn -------------------------------------------------------------------------------- -- | Make a spill instruction. --- On SPARC we spill below frame pointer leaving 2 words/spill +-- On SPARC we spill below frame pointer leaving 2 words/spill sparc_mkSpillInstr :: DynFlags -> Reg -- ^ register to spill @@ -387,12 +379,12 @@ sparc_mkSpillInstr dflags reg _ slot = let platform = targetPlatform dflags off = spillSlotToOffset dflags slot off_w = 1 + (off `div` 4) - sz = case targetClassOfReg platform reg of - RcInteger -> II32 - RcFloat -> FF32 - RcDouble -> FF64 - _ -> panic "sparc_mkSpillInstr" - + sz = case targetClassOfReg platform reg of + RcInteger -> II32 + RcFloat -> FF32 + RcDouble -> FF64 + _ -> panic "sparc_mkSpillInstr" + in ST sz reg (fpRel (negate off_w)) @@ -407,12 +399,12 @@ sparc_mkLoadInstr sparc_mkLoadInstr dflags reg _ slot = let platform = targetPlatform dflags off = spillSlotToOffset dflags slot - off_w = 1 + (off `div` 4) - sz = case targetClassOfReg platform reg of - RcInteger -> II32 - RcFloat -> FF32 - RcDouble -> FF64 - _ -> panic "sparc_mkLoadInstr" + off_w = 1 + (off `div` 4) + sz = case targetClassOfReg platform reg of + RcInteger -> II32 + RcFloat -> FF32 + RcDouble -> FF64 + _ -> panic "sparc_mkLoadInstr" in LD sz (fpRel (- off_w)) reg @@ -420,32 +412,32 @@ sparc_mkLoadInstr dflags reg _ slot -------------------------------------------------------------------------------- -- | See if this instruction is telling us the current C stack delta sparc_takeDeltaInstr - :: Instr - -> Maybe Int - + :: Instr + -> Maybe Int + sparc_takeDeltaInstr instr = case instr of - DELTA i -> Just i - _ -> Nothing + DELTA i -> Just i + _ -> Nothing sparc_isMetaInstr - :: Instr - -> Bool - + :: Instr + -> Bool + sparc_isMetaInstr instr = case instr of - COMMENT{} -> True - LDATA{} -> True - NEWBLOCK{} -> True - DELTA{} -> True - _ -> False - + COMMENT{} -> True + LDATA{} -> True + NEWBLOCK{} -> True + DELTA{} -> True + _ -> False + -- | Make a reg-reg move instruction. --- On SPARC v8 there are no instructions to move directly between --- floating point and integer regs. If we need to do that then we --- have to go via memory. +-- On SPARC v8 there are no instructions to move directly between +-- floating point and integer regs. If we need to do that then we +-- have to go via memory. -- sparc_mkRegRegMoveInstr :: Platform @@ -454,40 +446,39 @@ sparc_mkRegRegMoveInstr -> Instr sparc_mkRegRegMoveInstr platform src dst - | srcClass <- targetClassOfReg platform src - , dstClass <- targetClassOfReg platform dst - , srcClass == dstClass - = case srcClass of - RcInteger -> ADD False False src (RIReg g0) dst - RcDouble -> FMOV FF64 src dst - RcFloat -> FMOV FF32 src dst + | srcClass <- targetClassOfReg platform src + , dstClass <- targetClassOfReg platform dst + , srcClass == dstClass + = case srcClass of + RcInteger -> ADD False False src (RIReg g0) dst + RcDouble -> FMOV FF64 src dst + RcFloat -> FMOV FF32 src dst _ -> panic "sparc_mkRegRegMoveInstr" - - | otherwise - = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same" + + | otherwise + = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same" -- | Check whether an instruction represents a reg-reg move. --- The register allocator attempts to eliminate reg->reg moves whenever it can, --- by assigning the src and dest temporaries to the same real register. +-- The register allocator attempts to eliminate reg->reg moves whenever it can, +-- by assigning the src and dest temporaries to the same real register. -- sparc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg) sparc_takeRegRegMoveInstr instr = case instr of - ADD False False src (RIReg src2) dst - | g0 == src2 -> Just (src, dst) + ADD False False src (RIReg src2) dst + | g0 == src2 -> Just (src, dst) - FMOV FF64 src dst -> Just (src, dst) - FMOV FF32 src dst -> Just (src, dst) - _ -> Nothing + FMOV FF64 src dst -> Just (src, dst) + FMOV FF32 src dst -> Just (src, dst) + _ -> Nothing -- | Make an unconditional branch instruction. sparc_mkJumpInstr - :: BlockId - -> [Instr] - -sparc_mkJumpInstr id - = [BI ALWAYS False id - , NOP] -- fill the branch delay slot. + :: BlockId + -> [Instr] +sparc_mkJumpInstr id + = [BI ALWAYS False id + , NOP] -- fill the branch delay slot. diff --git a/compiler/nativeGen/SPARC/Regs.hs b/compiler/nativeGen/SPARC/Regs.hs index 01db0ed3ac..394389c4bf 100644 --- a/compiler/nativeGen/SPARC/Regs.hs +++ b/compiler/nativeGen/SPARC/Regs.hs @@ -1,39 +1,32 @@ -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 1994-2004 --- +-- -- ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.Regs ( - -- registers - showReg, - virtualRegSqueeze, - realRegSqueeze, - classOfRealReg, - allRealRegs, - - -- machine specific info - gReg, iReg, lReg, oReg, fReg, - fp, sp, g0, g1, g2, o0, o1, f0, f1, f6, f8, f22, f26, f27, - - -- allocatable - allocatableRegs, - - -- args - argRegs, - allArgRegs, - callClobberedRegs, - - -- - mkVirtualReg, - regDotColor + -- registers + showReg, + virtualRegSqueeze, + realRegSqueeze, + classOfRealReg, + allRealRegs, + + -- machine specific info + gReg, iReg, lReg, oReg, fReg, + fp, sp, g0, g1, g2, o0, o1, f0, f1, f6, f8, f22, f26, f27, + + -- allocatable + allocatableRegs, + + -- args + argRegs, + allArgRegs, + callClobberedRegs, + + -- + mkVirtualReg, + regDotColor ) where @@ -50,65 +43,65 @@ import FastTypes import FastBool {- - The SPARC has 64 registers of interest; 32 integer registers and 32 - floating point registers. The mapping of STG registers to SPARC - machine registers is defined in StgRegs.h. We are, of course, - prepared for any eventuality. - - The whole fp-register pairing thing on sparcs is a huge nuisance. See - includes/stg/MachRegs.h for a description of what's going on - here. + The SPARC has 64 registers of interest; 32 integer registers and 32 + floating point registers. The mapping of STG registers to SPARC + machine registers is defined in StgRegs.h. We are, of course, + prepared for any eventuality. + + The whole fp-register pairing thing on sparcs is a huge nuisance. See + includes/stg/MachRegs.h for a description of what's going on + here. -} -- | Get the standard name for the register with this number. showReg :: RegNo -> String showReg n - | n >= 0 && n < 8 = "%g" ++ show n - | n >= 8 && n < 16 = "%o" ++ show (n-8) - | n >= 16 && n < 24 = "%l" ++ show (n-16) - | n >= 24 && n < 32 = "%i" ++ show (n-24) - | n >= 32 && n < 64 = "%f" ++ show (n-32) - | otherwise = panic "SPARC.Regs.showReg: unknown sparc register" + | n >= 0 && n < 8 = "%g" ++ show n + | n >= 8 && n < 16 = "%o" ++ show (n-8) + | n >= 16 && n < 24 = "%l" ++ show (n-16) + | n >= 24 && n < 32 = "%i" ++ show (n-24) + | n >= 32 && n < 64 = "%f" ++ show (n-32) + | otherwise = panic "SPARC.Regs.showReg: unknown sparc register" -- Get the register class of a certain real reg classOfRealReg :: RealReg -> RegClass classOfRealReg reg = case reg of - RealRegSingle i - | i < 32 -> RcInteger - | otherwise -> RcFloat - - RealRegPair{} -> RcDouble + RealRegSingle i + | i < 32 -> RcInteger + | otherwise -> RcFloat + + RealRegPair{} -> RcDouble -- | regSqueeze_class reg --- Calculuate the maximum number of register colors that could be --- denied to a node of this class due to having this reg --- as a neighbour. +-- Calculuate the maximum number of register colors that could be +-- denied to a node of this class due to having this reg +-- as a neighbour. -- {-# INLINE virtualRegSqueeze #-} virtualRegSqueeze :: RegClass -> VirtualReg -> FastInt virtualRegSqueeze cls vr = case cls of - RcInteger - -> case vr of - VirtualRegI{} -> _ILIT(1) - VirtualRegHi{} -> _ILIT(1) + RcInteger + -> case vr of + VirtualRegI{} -> _ILIT(1) + VirtualRegHi{} -> _ILIT(1) _other -> _ILIT(0) - RcFloat - -> case vr of - VirtualRegF{} -> _ILIT(1) - VirtualRegD{} -> _ILIT(2) + RcFloat + -> case vr of + VirtualRegF{} -> _ILIT(1) + VirtualRegD{} -> _ILIT(2) _other -> _ILIT(0) - RcDouble - -> case vr of - VirtualRegF{} -> _ILIT(1) - VirtualRegD{} -> _ILIT(1) + RcDouble + -> case vr of + VirtualRegF{} -> _ILIT(1) + VirtualRegD{} -> _ILIT(1) _other -> _ILIT(0) _other -> _ILIT(0) @@ -118,48 +111,48 @@ realRegSqueeze :: RegClass -> RealReg -> FastInt realRegSqueeze cls rr = case cls of - RcInteger - -> case rr of - RealRegSingle regNo - | regNo < 32 -> _ILIT(1) - | otherwise -> _ILIT(0) - - RealRegPair{} -> _ILIT(0) - - RcFloat - -> case rr of - RealRegSingle regNo - | regNo < 32 -> _ILIT(0) - | otherwise -> _ILIT(1) - - RealRegPair{} -> _ILIT(2) - - RcDouble - -> case rr of - RealRegSingle regNo - | regNo < 32 -> _ILIT(0) - | otherwise -> _ILIT(1) - - RealRegPair{} -> _ILIT(1) - + RcInteger + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(1) + | otherwise -> _ILIT(0) + + RealRegPair{} -> _ILIT(0) + + RcFloat + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(0) + | otherwise -> _ILIT(1) + + RealRegPair{} -> _ILIT(2) + + RcDouble + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(0) + | otherwise -> _ILIT(1) + + RealRegPair{} -> _ILIT(1) + _other -> _ILIT(0) - --- | All the allocatable registers in the machine, --- including register pairs. + +-- | All the allocatable registers in the machine, +-- including register pairs. allRealRegs :: [RealReg] -allRealRegs - = [ (RealRegSingle i) | i <- [0..63] ] - ++ [ (RealRegPair i (i+1)) | i <- [32, 34 .. 62 ] ] +allRealRegs + = [ (RealRegSingle i) | i <- [0..63] ] + ++ [ (RealRegPair i (i+1)) | i <- [32, 34 .. 62 ] ] -- | Get the regno for this sort of reg gReg, lReg, iReg, oReg, fReg :: Int -> RegNo -gReg x = x -- global regs -oReg x = (8 + x) -- output regs -lReg x = (16 + x) -- local regs -iReg x = (24 + x) -- input regs -fReg x = (32 + x) -- float regs +gReg x = x -- global regs +oReg x = (8 + x) -- output regs +lReg x = (16 + x) -- local regs +iReg x = (24 + x) -- input regs +fReg x = (32 + x) -- float regs -- | Some specific regs used by the code generator. @@ -187,88 +180,87 @@ f1 = RegReal (RealRegSingle (fReg 1)) -- | Produce the second-half-of-a-double register given the first half. {- fPair :: Reg -> Maybe Reg -fPair (RealReg n) - | n >= 32 && n `mod` 2 == 0 = Just (RealReg (n+1)) +fPair (RealReg n) + | n >= 32 && n `mod` 2 == 0 = Just (RealReg (n+1)) fPair (VirtualRegD u) - = Just (VirtualRegHi u) + = Just (VirtualRegHi u) fPair reg - = trace ("MachInstrs.fPair: can't get high half of supposed double reg " ++ showPpr reg) - Nothing + = trace ("MachInstrs.fPair: can't get high half of supposed double reg " ++ showPpr reg) + Nothing -} --- | All the regs that the register allocator can allocate to, --- with the the fixed use regs removed. --- +-- | All the regs that the register allocator can allocate to, +-- with the the fixed use regs removed. +-- allocatableRegs :: [RealReg] allocatableRegs - = let isFree rr - = case rr of - RealRegSingle r - -> isFastTrue (freeReg r) + = let isFree rr + = case rr of + RealRegSingle r + -> isFastTrue (freeReg r) - RealRegPair r1 r2 - -> isFastTrue (freeReg r1) - && isFastTrue (freeReg r2) + RealRegPair r1 r2 + -> isFastTrue (freeReg r1) + && isFastTrue (freeReg r2) - in filter isFree allRealRegs + in filter isFree allRealRegs --- | The registers to place arguments for function calls, --- for some number of arguments. +-- | The registers to place arguments for function calls, +-- for some number of arguments. -- argRegs :: RegNo -> [Reg] argRegs r = case r of - 0 -> [] - 1 -> map (RegReal . RealRegSingle . oReg) [0] - 2 -> map (RegReal . RealRegSingle . oReg) [0,1] - 3 -> map (RegReal . RealRegSingle . oReg) [0,1,2] - 4 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3] - 5 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4] - 6 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4,5] - _ -> panic "MachRegs.argRegs(sparc): don't know about >6 arguments!" + 0 -> [] + 1 -> map (RegReal . RealRegSingle . oReg) [0] + 2 -> map (RegReal . RealRegSingle . oReg) [0,1] + 3 -> map (RegReal . RealRegSingle . oReg) [0,1,2] + 4 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3] + 5 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4] + 6 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4,5] + _ -> panic "MachRegs.argRegs(sparc): don't know about >6 arguments!" -- | All all the regs that could possibly be returned by argRegs -- allArgRegs :: [Reg] -allArgRegs - = map (RegReal . RealRegSingle) [oReg i | i <- [0..5]] +allArgRegs + = map (RegReal . RealRegSingle) [oReg i | i <- [0..5]] --- These are the regs that we cannot assume stay alive over a C call. --- TODO: Why can we assume that o6 isn't clobbered? -- BL 2009/02 +-- These are the regs that we cannot assume stay alive over a C call. +-- TODO: Why can we assume that o6 isn't clobbered? -- BL 2009/02 -- callClobberedRegs :: [Reg] callClobberedRegs - = map (RegReal . RealRegSingle) - ( oReg 7 : - [oReg i | i <- [0..5]] ++ - [gReg i | i <- [1..7]] ++ - [fReg i | i <- [0..31]] ) + = map (RegReal . RealRegSingle) + ( oReg 7 : + [oReg i | i <- [0..5]] ++ + [gReg i | i <- [1..7]] ++ + [fReg i | i <- [0..31]] ) -- | Make a virtual reg with this size. mkVirtualReg :: Unique -> Size -> VirtualReg mkVirtualReg u size - | not (isFloatSize size) - = VirtualRegI u + | not (isFloatSize size) + = VirtualRegI u - | otherwise - = case size of - FF32 -> VirtualRegF u - FF64 -> VirtualRegD u - _ -> panic "mkVReg" + | otherwise + = case size of + FF32 -> VirtualRegF u + FF64 -> VirtualRegD u + _ -> panic "mkVReg" regDotColor :: RealReg -> SDoc regDotColor reg = case classOfRealReg reg of - RcInteger -> text "blue" - RcFloat -> text "red" - _other -> text "green" - + RcInteger -> text "blue" + RcFloat -> text "red" + _other -> text "green" diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs index 142ec6e65d..123a345130 100644 --- a/compiler/nativeGen/SPARC/ShortcutJump.hs +++ b/compiler/nativeGen/SPARC/ShortcutJump.hs @@ -1,17 +1,9 @@ - -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.ShortcutJump ( - JumpDest(..), getJumpDestBlockId, - canShortcut, - shortcutJump, - shortcutStatics, - shortBlockId + JumpDest(..), getJumpDestBlockId, + canShortcut, + shortcutJump, + shortcutStatics, + shortBlockId ) where @@ -28,9 +20,9 @@ import Unique -data JumpDest - = DestBlockId BlockId - | DestImm Imm +data JumpDest + = DestBlockId BlockId + | DestImm Imm getJumpDestBlockId :: JumpDest -> Maybe BlockId getJumpDestBlockId (DestBlockId bid) = Just bid @@ -59,9 +51,9 @@ shortcutLabel fn lab shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. shortcutStatic _ other_static @@ -75,6 +67,3 @@ shortBlockId fn blockid = Just (DestBlockId blockid') -> shortBlockId fn blockid' Just (DestImm (ImmCLbl lbl)) -> lbl _other -> panic "shortBlockId" - - - diff --git a/compiler/nativeGen/SPARC/Stack.hs b/compiler/nativeGen/SPARC/Stack.hs index 3560a0fe82..629b18789f 100644 --- a/compiler/nativeGen/SPARC/Stack.hs +++ b/compiler/nativeGen/SPARC/Stack.hs @@ -1,16 +1,8 @@ - -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.Stack ( - spRel, - fpRel, - spillSlotToOffset, - maxSpillSlots + spRel, + fpRel, + spillSlotToOffset, + maxSpillSlots ) where @@ -24,43 +16,42 @@ import DynFlags import Outputable -- | Get an AddrMode relative to the address in sp. --- This gives us a stack relative addressing mode for volatile --- temporaries and for excess call arguments. +-- This gives us a stack relative addressing mode for volatile +-- temporaries and for excess call arguments. -- -spRel :: Int -- ^ stack offset in words, positive or negative +spRel :: Int -- ^ stack offset in words, positive or negative -> AddrMode -spRel n = AddrRegImm sp (ImmInt (n * wordLength)) +spRel n = AddrRegImm sp (ImmInt (n * wordLength)) -- | Get an address relative to the frame pointer. --- This doesn't work work for offsets greater than 13 bits; we just hope for the best +-- This doesn't work work for offsets greater than 13 bits; we just hope for the best -- fpRel :: Int -> AddrMode fpRel n - = AddrRegImm fp (ImmInt (n * wordLength)) + = AddrRegImm fp (ImmInt (n * wordLength)) -- | Convert a spill slot number to a *byte* offset, with no sign. -- spillSlotToOffset :: DynFlags -> Int -> Int spillSlotToOffset dflags slot - | slot >= 0 && slot < maxSpillSlots dflags - = 64 + spillSlotSize * slot + | slot >= 0 && slot < maxSpillSlots dflags + = 64 + spillSlotSize * slot - | otherwise - = pprPanic "spillSlotToOffset:" - ( text "invalid spill location: " <> int slot - $$ text "maxSpillSlots: " <> int (maxSpillSlots dflags)) + | otherwise + = pprPanic "spillSlotToOffset:" + ( text "invalid spill location: " <> int slot + $$ text "maxSpillSlots: " <> int (maxSpillSlots dflags)) -- | The maximum number of spill slots available on the C stack. --- If we use up all of the slots, then we're screwed. +-- If we use up all of the slots, then we're screwed. -- --- Why do we reserve 64 bytes, instead of using the whole thing?? --- -- BL 2009/02/15 +-- Why do we reserve 64 bytes, instead of using the whole thing?? +-- -- BL 2009/02/15 -- maxSpillSlots :: DynFlags -> Int maxSpillSlots dflags - = ((spillAreaLength dflags - 64) `div` spillSlotSize) - 1 - + = ((spillAreaLength dflags - 64) `div` spillSlotSize) - 1 diff --git a/compiler/nativeGen/Size.hs b/compiler/nativeGen/Size.hs index 1b95ceb98b..8fe590f1e9 100644 --- a/compiler/nativeGen/Size.hs +++ b/compiler/nativeGen/Size.hs @@ -1,22 +1,15 @@ -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Sizes on this architecture --- A Size is a combination of width and class --- --- TODO: Rename this to "Format" instead of "Size" to reflect --- the fact that it represents floating point vs integer. +-- A Size is a combination of width and class +-- +-- TODO: Rename this to "Format" instead of "Size" to reflect +-- the fact that it represents floating point vs integer. -- --- TODO: Signed vs unsigned? +-- TODO: Signed vs unsigned? -- --- TODO: This module is currenly shared by all architectures because --- NCGMonad need to know about it to make a VReg. It would be better --- to have architecture specific formats, and do the overloading --- properly. eg SPARC doesn't care about FF80. +-- TODO: This module is currenly shared by all architectures because +-- NCGMonad need to know about it to make a VReg. It would be better +-- to have architecture specific formats, and do the overloading +-- properly. eg SPARC doesn't care about FF80. -- module Size ( Size(..), @@ -37,76 +30,76 @@ import Outputable -- significance, here in the native code generator. You can change it -- without global consequences. -- --- A major use is as an opcode qualifier; thus the opcode --- mov.l a b --- might be encoded --- MOV II32 a b +-- A major use is as an opcode qualifier; thus the opcode +-- mov.l a b +-- might be encoded +-- MOV II32 a b -- where the Size field encodes the ".l" part. -- ToDo: it's not clear to me that we need separate signed-vs-unsigned sizes --- here. I've removed them from the x86 version, we'll see what happens --SDM +-- here. I've removed them from the x86 version, we'll see what happens --SDM -- ToDo: quite a few occurrences of Size could usefully be replaced by Width data Size - = II8 - | II16 - | II32 - | II64 - | FF32 - | FF64 - | FF80 - deriving (Show, Eq) + = II8 + | II16 + | II32 + | II64 + | FF32 + | FF64 + | FF80 + deriving (Show, Eq) -- | Get the integer size of this width. intSize :: Width -> Size intSize width = case width of - W8 -> II8 - W16 -> II16 - W32 -> II32 - W64 -> II64 - other -> pprPanic "Size.intSize" (ppr other) + W8 -> II8 + W16 -> II16 + W32 -> II32 + W64 -> II64 + other -> pprPanic "Size.intSize" (ppr other) -- | Get the float size of this width. floatSize :: Width -> Size floatSize width = case width of - W32 -> FF32 - W64 -> FF64 - other -> pprPanic "Size.floatSize" (ppr other) + W32 -> FF32 + W64 -> FF64 + other -> pprPanic "Size.floatSize" (ppr other) -- | Check if a size represents a floating point value. isFloatSize :: Size -> Bool isFloatSize size = case size of - FF32 -> True - FF64 -> True - FF80 -> True - _ -> False + FF32 -> True + FF64 -> True + FF80 -> True + _ -> False -- | Convert a Cmm type to a Size. cmmTypeSize :: CmmType -> Size -cmmTypeSize ty - | isFloatType ty = floatSize (typeWidth ty) - | otherwise = intSize (typeWidth ty) +cmmTypeSize ty + | isFloatType ty = floatSize (typeWidth ty) + | otherwise = intSize (typeWidth ty) -- | Get the Width of a Size. sizeToWidth :: Size -> Width sizeToWidth size = case size of - II8 -> W8 - II16 -> W16 - II32 -> W32 - II64 -> W64 - FF32 -> W32 - FF64 -> W64 - FF80 -> W80 + II8 -> W8 + II16 -> W16 + II32 -> W32 + II64 -> W64 + FF32 -> W32 + FF64 -> W64 + FF80 -> W80 sizeInBytes :: Size -> Int sizeInBytes = widthInBytes . sizeToWidth diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs index daf1e254c8..96c1777795 100644 --- a/compiler/nativeGen/TargetReg.hs +++ b/compiler/nativeGen/TargetReg.hs @@ -1,28 +1,20 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Hard wired things related to registers. --- This is module is preventing the native code generator being able to --- emit code for non-host architectures. +-- This is module is preventing the native code generator being able to +-- emit code for non-host architectures. -- --- TODO: Do a better job of the overloading, and eliminate this module. --- We'd probably do better with a Register type class, and hook this to --- Instruction somehow. +-- TODO: Do a better job of the overloading, and eliminate this module. +-- We'd probably do better with a Register type class, and hook this to +-- Instruction somehow. -- --- TODO: We should also make arch specific versions of RegAlloc.Graph.TrivColorable - +-- TODO: We should also make arch specific versions of RegAlloc.Graph.TrivColorable module TargetReg ( - targetVirtualRegSqueeze, - targetRealRegSqueeze, - targetClassOfRealReg, - targetMkVirtualReg, - targetRegDotColor, - targetClassOfReg + targetVirtualRegSqueeze, + targetRealRegSqueeze, + targetClassOfRealReg, + targetMkVirtualReg, + targetRegDotColor, + targetClassOfReg ) where @@ -132,5 +124,3 @@ targetClassOfReg platform reg = case reg of RegVirtual vr -> classOfVirtualReg vr RegReal rr -> targetClassOfRealReg platform rr - - diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index fa93767fa3..a9ff8f2853 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -41,7 +41,7 @@ import Platform -- Our intermediate code: import BasicTypes import BlockId -import Module ( primPackageId ) +import Module ( primPackageKey ) import PprCmm () import CmmUtils import Cmm @@ -1057,6 +1057,18 @@ getAmode' _ expr = do (reg,code) <- getSomeReg expr return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code) +-- | Like 'getAmode', but on 32-bit use simple register addressing +-- (i.e. no index register). This stops us from running out of +-- registers on x86 when using instructions such as cmpxchg, which can +-- use up to three virtual registers and one fixed register. +getSimpleAmode :: DynFlags -> Bool -> CmmExpr -> NatM Amode +getSimpleAmode dflags is32Bit addr + | is32Bit = do + addr_code <- getAnyReg addr + addr_r <- getNewRegNat (intSize (wordWidth dflags)) + let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0) + return $! Amode amode (addr_code addr_r) + | otherwise = getAmode addr x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode x86_complex_amode base index shift offset @@ -1749,7 +1761,7 @@ genCCall dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst] genCCall dflags is32Bit target dest_regs args where size = intSize width - lbl = mkCmmCodeLabel primPackageId (fsLit (popCntLabel width)) + lbl = mkCmmCodeLabel primPackageKey (fsLit (popCntLabel width)) genCCall dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args = do targetExpr <- cmmMakeDynamicReference dflags @@ -1759,7 +1771,97 @@ genCCall dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args = do CmmMayReturn) genCCall dflags is32Bit target dest_regs args where - lbl = mkCmmCodeLabel primPackageId (fsLit (word2FloatLabel width)) + lbl = mkCmmCodeLabel primPackageKey (fsLit (word2FloatLabel width)) + +genCCall dflags is32Bit (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = do + Amode amode addr_code <- + if amop `elem` [AMO_Add, AMO_Sub] + then getAmode addr + else getSimpleAmode dflags is32Bit addr -- See genCCall for MO_Cmpxchg + arg <- getNewRegNat size + arg_code <- getAnyReg n + use_sse2 <- sse2Enabled + let platform = targetPlatform dflags + dst_r = getRegisterReg platform use_sse2 (CmmLocal dst) + code <- op_code dst_r arg amode + return $ addr_code `appOL` arg_code arg `appOL` code + where + -- Code for the operation + op_code :: Reg -- Destination reg + -> Reg -- Register containing argument + -> AddrMode -- Address of location to mutate + -> NatM (OrdList Instr) + op_code dst_r arg amode = case amop of + -- In the common case where dst_r is a virtual register the + -- final move should go away, because it's the last use of arg + -- and the first use of dst_r. + AMO_Add -> return $ toOL [ LOCK (XADD size (OpReg arg) (OpAddr amode)) + , MOV size (OpReg arg) (OpReg dst_r) + ] + AMO_Sub -> return $ toOL [ NEGI size (OpReg arg) + , LOCK (XADD size (OpReg arg) (OpAddr amode)) + , MOV size (OpReg arg) (OpReg dst_r) + ] + AMO_And -> cmpxchg_code (\ src dst -> unitOL $ AND size src dst) + AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND size src dst + , NOT size dst + ]) + AMO_Or -> cmpxchg_code (\ src dst -> unitOL $ OR size src dst) + AMO_Xor -> cmpxchg_code (\ src dst -> unitOL $ XOR size src dst) + where + -- Simulate operation that lacks a dedicated instruction using + -- cmpxchg. + cmpxchg_code :: (Operand -> Operand -> OrdList Instr) + -> NatM (OrdList Instr) + cmpxchg_code instrs = do + lbl <- getBlockIdNat + tmp <- getNewRegNat size + return $ toOL + [ MOV size (OpAddr amode) (OpReg eax) + , JXX ALWAYS lbl + , NEWBLOCK lbl + -- Keep old value so we can return it: + , MOV size (OpReg eax) (OpReg dst_r) + , MOV size (OpReg eax) (OpReg tmp) + ] + `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL + [ LOCK (CMPXCHG size (OpReg tmp) (OpAddr amode)) + , JXX NE lbl + ] + + size = intSize width + +genCCall dflags _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] = do + load_code <- intLoadCode (MOV (intSize width)) addr + let platform = targetPlatform dflags + use_sse2 <- sse2Enabled + return (load_code (getRegisterReg platform use_sse2 (CmmLocal dst))) + +genCCall _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do + code <- assignMem_IntCode (intSize width) addr val + return $ code `snocOL` MFENCE + +genCCall dflags is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] = do + -- On x86 we don't have enough registers to use cmpxchg with a + -- complicated addressing mode, so on that architecture we + -- pre-compute the address first. + Amode amode addr_code <- getSimpleAmode dflags is32Bit addr + newval <- getNewRegNat size + newval_code <- getAnyReg new + oldval <- getNewRegNat size + oldval_code <- getAnyReg old + use_sse2 <- sse2Enabled + let platform = targetPlatform dflags + dst_r = getRegisterReg platform use_sse2 (CmmLocal dst) + code = toOL + [ MOV size (OpReg oldval) (OpReg eax) + , LOCK (CMPXCHG size (OpReg newval) (OpAddr amode)) + , MOV size (OpReg eax) (OpReg dst_r) + ] + return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval + `appOL` code + where + size = intSize width genCCall _ is32Bit target dest_regs args | is32Bit = genCCall32 target dest_regs args @@ -2385,6 +2487,11 @@ outOfLineCmmOp mop res args MO_PopCnt _ -> fsLit "popcnt" MO_BSwap _ -> fsLit "bswap" + MO_AtomicRMW _ _ -> fsLit "atomicrmw" + MO_AtomicRead _ -> fsLit "atomicread" + MO_AtomicWrite _ -> fsLit "atomicwrite" + MO_Cmpxchg _ -> fsLit "cmpxchg" + MO_UF_Conv _ -> unsupported MO_S_QuotRem {} -> unsupported diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 05fff9be96..172ce93f50 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -327,6 +327,11 @@ data Instr | PREFETCH PrefetchVariant Size Operand -- prefetch Variant, addr size, address to prefetch -- variant can be NTA, Lvl0, Lvl1, or Lvl2 + | LOCK Instr -- lock prefix + | XADD Size Operand Operand -- src (r), dst (r/m) + | CMPXCHG Size Operand Operand -- src (r), dst (r/m), eax implicit + | MFENCE + data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2 @@ -337,6 +342,8 @@ data Operand +-- | Returns which registers are read and written as a (read, written) +-- pair. x86_regUsageOfInstr :: Platform -> Instr -> RegUsage x86_regUsageOfInstr platform instr = case instr of @@ -428,10 +435,22 @@ x86_regUsageOfInstr platform instr -- note: might be a better way to do this PREFETCH _ _ src -> mkRU (use_R src []) [] + LOCK i -> x86_regUsageOfInstr platform i + XADD _ src dst -> usageMM src dst + CMPXCHG _ src dst -> usageRMM src dst (OpReg eax) + MFENCE -> noUsage _other -> panic "regUsage: unrecognised instr" - where + -- # Definitions + -- + -- Written: If the operand is a register, it's written. If it's an + -- address, registers mentioned in the address are read. + -- + -- Modified: If the operand is a register, it's both read and + -- written. If it's an address, registers mentioned in the address + -- are read. + -- 2 operand form; first operand Read; second Written usageRW :: Operand -> Operand -> RegUsage usageRW op (OpReg reg) = mkRU (use_R op []) [reg] @@ -444,6 +463,18 @@ x86_regUsageOfInstr platform instr usageRM op (OpAddr ea) = mkRUR (use_R op $! use_EA ea []) usageRM _ _ = panic "X86.RegInfo.usageRM: no match" + -- 2 operand form; first operand Modified; second Modified + usageMM :: Operand -> Operand -> RegUsage + usageMM (OpReg src) (OpReg dst) = mkRU [src, dst] [src, dst] + usageMM (OpReg src) (OpAddr ea) = mkRU (use_EA ea [src]) [src] + usageMM _ _ = panic "X86.RegInfo.usageMM: no match" + + -- 3 operand form; first operand Read; second Modified; third Modified + usageRMM :: Operand -> Operand -> Operand -> RegUsage + usageRMM (OpReg src) (OpReg dst) (OpReg reg) = mkRU [src, dst, reg] [dst, reg] + usageRMM (OpReg src) (OpAddr ea) (OpReg reg) = mkRU (use_EA ea [src, reg]) [reg] + usageRMM _ _ _ = panic "X86.RegInfo.usageRMM: no match" + -- 1 operand form; operand Modified usageM :: Operand -> RegUsage usageM (OpReg reg) = mkRU [reg] [reg] @@ -476,6 +507,7 @@ x86_regUsageOfInstr platform instr where src' = filter (interesting platform) src dst' = filter (interesting platform) dst +-- | Is this register interesting for the register allocator? interesting :: Platform -> Reg -> Bool interesting _ (RegVirtual _) = True interesting platform (RegReal (RealRegSingle i)) = isFastTrue (freeReg platform i) @@ -483,6 +515,8 @@ interesting _ (RegReal (RealRegPair{})) = panic "X86.interesting: no re +-- | Applies the supplied function to all registers in instructions. +-- Typically used to change virtual registers to real registers. x86_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr x86_patchRegsOfInstr instr env = case instr of @@ -571,6 +605,11 @@ x86_patchRegsOfInstr instr env PREFETCH lvl size src -> PREFETCH lvl size (patchOp src) + LOCK i -> LOCK (x86_patchRegsOfInstr i env) + XADD sz src dst -> patch2 (XADD sz) src dst + CMPXCHG sz src dst -> patch2 (CMPXCHG sz) src dst + MFENCE -> instr + _other -> panic "patchRegs: unrecognised instr" where diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 459c041ba5..15d29679b0 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -886,6 +886,16 @@ pprInstr GFREE ptext (sLit "\tffree %st(4) ;ffree %st(5)") ] +-- Atomics + +pprInstr (LOCK i) = ptext (sLit "\tlock") $$ pprInstr i + +pprInstr MFENCE = ptext (sLit "\tmfence") + +pprInstr (XADD size src dst) = pprSizeOpOp (sLit "xadd") size src dst + +pprInstr (CMPXCHG size src dst) = pprSizeOpOp (sLit "cmpxchg") size src dst + pprInstr _ = panic "X86.Ppr.pprInstr: no match" diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs index 0303295bc6..39535634d7 100644 --- a/compiler/nativeGen/X86/RegInfo.hs +++ b/compiler/nativeGen/X86/RegInfo.hs @@ -1,14 +1,7 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module X86.RegInfo ( - mkVirtualReg, - regDotColor + mkVirtualReg, + regDotColor ) where @@ -30,9 +23,9 @@ import X86.Regs mkVirtualReg :: Unique -> Size -> VirtualReg mkVirtualReg u size = case size of - FF32 -> VirtualRegSSE u - FF64 -> VirtualRegSSE u - FF80 -> VirtualRegD u + FF32 -> VirtualRegSSE u + FF64 -> VirtualRegSSE u + FF80 -> VirtualRegD u _other -> VirtualRegI u regDotColor :: Platform -> RealReg -> SDoc @@ -65,11 +58,10 @@ normalRegColors platform fpRegColors :: [(Reg,String)] fpRegColors = [ (fake0, "#ff00ff") - , (fake1, "#ff00aa") - , (fake2, "#aa00ff") - , (fake3, "#aa00aa") - , (fake4, "#ff0055") - , (fake5, "#5500ff") ] - - ++ zip (map regSingle [24..39]) (repeat "red") + , (fake1, "#ff00aa") + , (fake2, "#aa00ff") + , (fake3, "#aa00aa") + , (fake4, "#ff0055") + , (fake5, "#5500ff") ] + ++ zip (map regSingle [24..39]) (repeat "red") diff --git a/compiler/parser/Ctype.lhs b/compiler/parser/Ctype.lhs index c024ebe45a..7233f50e7f 100644 --- a/compiler/parser/Ctype.lhs +++ b/compiler/parser/Ctype.lhs @@ -2,32 +2,25 @@ Character classification \begin{code} {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Ctype - ( is_ident -- Char# -> Bool - , is_symbol -- Char# -> Bool - , is_any -- Char# -> Bool - , is_space -- Char# -> Bool - , is_lower -- Char# -> Bool - , is_upper -- Char# -> Bool - , is_digit -- Char# -> Bool - , is_alphanum -- Char# -> Bool - - , is_decdigit, is_hexdigit, is_octdigit, is_bindigit - , hexDigit, octDecDigit - ) where + ( is_ident -- Char# -> Bool + , is_symbol -- Char# -> Bool + , is_any -- Char# -> Bool + , is_space -- Char# -> Bool + , is_lower -- Char# -> Bool + , is_upper -- Char# -> Bool + , is_digit -- Char# -> Bool + , is_alphanum -- Char# -> Bool + + , is_decdigit, is_hexdigit, is_octdigit, is_bindigit + , hexDigit, octDecDigit + ) where #include "HsVersions.h" -import Data.Int ( Int32 ) -import Data.Bits ( Bits((.&.)) ) -import Data.Char ( ord, chr ) +import Data.Int ( Int32 ) +import Data.Bits ( Bits((.&.)) ) +import Data.Char ( ord, chr ) import Panic \end{code} @@ -76,13 +69,13 @@ octDecDigit c = ord c - ord '0' is_decdigit :: Char -> Bool is_decdigit c - = c >= '0' && c <= '9' + = c >= '0' && c <= '9' is_hexdigit :: Char -> Bool is_hexdigit c - = is_decdigit c - || (c >= 'a' && c <= 'f') - || (c >= 'A' && c <= 'F') + = is_decdigit c + || (c >= 'a' && c <= 'f') + || (c >= 'A' && c <= 'F') is_octdigit :: Char -> Bool is_octdigit c = c >= '0' && c <= '7' @@ -112,7 +105,7 @@ charType c = case c of '\7' -> 0 -- \007 '\8' -> 0 -- \010 '\9' -> cSpace -- \t (not allowed in strings, so !cAny) - '\10' -> cSpace -- \n (ditto) + '\10' -> cSpace -- \n (ditto) '\11' -> cSpace -- \v (ditto) '\12' -> cSpace -- \f (ditto) '\13' -> cSpace -- ^M (ditto) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 78c39c75db..88a0f07d90 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -527,6 +527,10 @@ data Token | ITvect_scalar_prag | ITnovect_prag | ITminimal_prag + | IToverlappable_prag -- instance overlap mode + | IToverlapping_prag -- instance overlap mode + | IToverlaps_prag -- instance overlap mode + | ITincoherent_prag -- instance overlap mode | ITctype | ITdotdot -- reserved symbols @@ -1677,7 +1681,7 @@ getPState = P $ \s -> POk s s instance HasDynFlags P where getDynFlags = P $ \s -> POk s (dflags s) -withThisPackage :: (PackageId -> a) -> P a +withThisPackage :: (PackageKey -> a) -> P a withThisPackage f = do pkg <- liftM thisPackage getDynFlags return $ f pkg @@ -2428,6 +2432,10 @@ oneWordPrags = Map.fromList([("rules", rulePrag), ("vectorize", token ITvect_prag), ("novectorize", token ITnovect_prag), ("minimal", token ITminimal_prag), + ("overlaps", token IToverlaps_prag), + ("overlappable", token IToverlappable_prag), + ("overlapping", token IToverlapping_prag), + ("incoherent", token ITincoherent_prag), ("ctype", token ITctype)]) twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)), diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 4f4ec0b123..72dfc88fa6 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -16,8 +16,25 @@ -- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -module Parser ( parseModule, parseStmt, parseIdentifier, parseType, - parseHeader ) where +-- | This module provides the generated Happy parser for Haskell. It exports +-- a number of parsers which may be used in any library that uses the GHC API. +-- A common usage pattern is to initialize the parser state with a given string +-- and then parse that string: +-- +-- @ +-- runParser :: DynFlags -> String -> P a -> ParseResult a +-- runParser flags str parser = unP parser parseState +-- where +-- filename = "\<interactive\>" +-- location = mkRealSrcLoc (mkFastString filename) 1 1 +-- buffer = stringToStringBuffer str +-- parseState = mkPState flags buffer location in +-- @ +module Parser (parseModule, parseImport, parseStatement, + parseDeclaration, parseExpression, parseTypeSignature, + parseFullStmt, parseStmt, parseIdentifier, + parseType, parseHeader) where + import HsSyn import RdrHsSyn @@ -269,6 +286,10 @@ incorrect. '{-# NOVECTORISE' { L _ ITnovect_prag } '{-# MINIMAL' { L _ ITminimal_prag } '{-# CTYPE' { L _ ITctype } + '{-# OVERLAPPING' { L _ IToverlapping_prag } + '{-# OVERLAPPABLE' { L _ IToverlappable_prag } + '{-# OVERLAPS' { L _ IToverlaps_prag } + '{-# INCOHERENT' { L _ ITincoherent_prag } '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols @@ -360,12 +381,20 @@ TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } %monad { P } { >>= } { return } %lexer { lexer } { L _ ITeof } +%tokentype { (Located Token) } + +-- Exported parsers %name parseModule module +%name parseImport importdecl +%name parseStatement stmt +%name parseDeclaration topdecl +%name parseExpression exp +%name parseTypeSignature sigdecl +%name parseFullStmt stmt %name parseStmt maybe_stmt %name parseIdentifier identifier %name parseType ctype %partial parseHeader header -%tokentype { (Located Token) } %% ----------------------------------------------------------------------------- @@ -654,12 +683,13 @@ ty_decl :: { LTyClDecl RdrName } {% mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) } inst_decl :: { LInstDecl RdrName } - : 'instance' inst_type where_inst - { let (binds, sigs, _, ats, adts, _) = cvBindsAndSigs (unLoc $3) in - let cid = ClsInstDecl { cid_poly_ty = $2, cid_binds = binds + : 'instance' overlap_pragma inst_type where_inst + { let (binds, sigs, _, ats, adts, _) = cvBindsAndSigs (unLoc $4) in + let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_overlap_mode = $2 , cid_datafam_insts = adts } - in L (comb3 $1 $2 $3) (ClsInstD { cid_inst = cid }) } + in L (comb3 $1 $3 $4) (ClsInstD { cid_inst = cid }) } -- type instance declarations | 'type' 'instance' ty_fam_inst_eqn @@ -677,6 +707,14 @@ inst_decl :: { LInstDecl RdrName } {% mkDataFamInst (comb4 $1 $4 $6 $7) (unLoc $1) $3 $4 (unLoc $5) (unLoc $6) (unLoc $7) } +overlap_pragma :: { Maybe OverlapMode } + : '{-# OVERLAPPABLE' '#-}' { Just Overlappable } + | '{-# OVERLAPPING' '#-}' { Just Overlapping } + | '{-# OVERLAPS' '#-}' { Just Overlaps } + | '{-# INCOHERENT' '#-}' { Just Incoherent } + | {- empty -} { Nothing } + + -- Closed type families where_type_family :: { Located (FamilyInfo RdrName) } @@ -783,7 +821,7 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (Header (getSTR -- Glasgow extension: stand-alone deriving declarations stand_alone_deriving :: { LDerivDecl RdrName } - : 'deriving' 'instance' inst_type { LL (DerivDecl $3) } + : 'deriving' 'instance' overlap_pragma inst_type { LL (DerivDecl $4 $3) } ----------------------------------------------------------------------------- -- Role annotations @@ -810,17 +848,29 @@ role : VARID { L1 $ Just $ getVARID $1 } -- Glasgow extension: pattern synonyms pattern_synonym_decl :: { LHsDecl RdrName } - : 'pattern' con vars0 patsyn_token pat { LL . ValD $ mkPatSynBind $2 (PrefixPatSyn $3) $5 $4 } - | 'pattern' varid conop varid patsyn_token pat { LL . ValD $ mkPatSynBind $3 (InfixPatSyn $2 $4) $6 $5 } + : 'pattern' pat '=' pat + {% do { (name, args) <- splitPatSyn $2 + ; return $ LL . ValD $ mkPatSynBind name args $4 ImplicitBidirectional + }} + | 'pattern' pat '<-' pat + {% do { (name, args) <- splitPatSyn $2 + ; return $ LL . ValD $ mkPatSynBind name args $4 Unidirectional + }} + | 'pattern' pat '<-' pat where_decls + {% do { (name, args) <- splitPatSyn $2 + ; mg <- toPatSynMatchGroup name $5 + ; return $ LL . ValD $ + mkPatSynBind name args $4 (ExplicitBidirectional mg) + }} + +where_decls :: { Located (OrdList (LHsDecl RdrName)) } + : 'where' '{' decls '}' { $3 } + | 'where' vocurly decls close { $3 } vars0 :: { [Located RdrName] } : {- empty -} { [] } | varid vars0 { $1 : $2 } -patsyn_token :: { HsPatSynDir RdrName } - : '<-' { Unidirectional } - | '=' { ImplicitBidirectional } - ----------------------------------------------------------------------------- -- Nested declarations diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index af351b7f31..84a284f0ab 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -17,6 +17,7 @@ module RdrHsSyn ( mkTyFamInst, mkFamDecl, splitCon, mkInlinePragma, + splitPatSyn, toPatSynMatchGroup, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp mkTyLit, mkTyClD, mkInstD, @@ -34,6 +35,7 @@ module RdrHsSyn ( mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName mkSimpleConDecl, mkDeprecatedGadtRecordDecl, + mkATDefault, -- Bunch of functions in the parser monad for -- checking and constructing values @@ -73,7 +75,7 @@ import TysWiredIn ( unitTyCon, unitDataCon ) import ForeignCall import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameString ) -import PrelNames ( forall_tv_RDR ) +import PrelNames ( forall_tv_RDR, allNameStrings ) import DynFlags import SrcLoc import OrdList ( OrdList, fromOL ) @@ -124,16 +126,31 @@ mkClassDecl :: SrcSpan -> P (LTyClDecl RdrName) mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls - = do { let (binds, sigs, ats, at_defs, _, docs) = cvBindsAndSigs (unLoc where_cls) + = do { let (binds, sigs, ats, at_insts, _, docs) = cvBindsAndSigs (unLoc where_cls) cxt = fromMaybe (noLoc []) mcxt ; (cls, tparams) <- checkTyClHdr tycl_hdr - ; tyvars <- checkTyVars (ptext (sLit "class")) whereDots - cls tparams -- Only type vars allowed + ; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams + ; at_defs <- mapM (eitherToP . mkATDefault) at_insts ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars, tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds, tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs, tcdFVs = placeHolderNames })) } +mkATDefault :: LTyFamInstDecl RdrName + -> Either (SrcSpan, SDoc) (LTyFamDefltEqn RdrName) +-- Take a type-family instance declaration and turn it into +-- a type-family default equation for a class declaration +-- We parse things as the former and use this function to convert to the latter +-- +-- We use the Either monad because this also called +-- from Convert.hs +mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e })) + | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs } <- e + = do { tvs <- checkTyVars (ptext (sLit "default")) equalsDots tc (hswb_cts pats) + ; return (L loc (TyFamEqn { tfe_tycon = tc + , tfe_pats = tvs + , tfe_rhs = rhs })) } + mkTyData :: SrcSpan -> NewOrData -> Maybe CType @@ -144,7 +161,7 @@ mkTyData :: SrcSpan -> P (LTyClDecl RdrName) mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams) <- checkTyClHdr tycl_hdr - ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams + ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars, tcdDataDefn = defn, @@ -172,7 +189,7 @@ mkTySynonym :: SrcSpan -> P (LTyClDecl RdrName) mkTySynonym loc lhs rhs = do { (tc, tparams) <- checkTyClHdr lhs - ; tyvars <- checkTyVars (ptext (sLit "type")) equalsDots tc tparams + ; tyvars <- checkTyVarsP (ptext (sLit "type")) equalsDots tc tparams ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars , tcdRhs = rhs, tcdFVs = placeHolderNames })) } @@ -181,9 +198,9 @@ mkTyFamInstEqn :: LHsType RdrName -> P (TyFamInstEqn RdrName) mkTyFamInstEqn lhs rhs = do { (tc, tparams) <- checkTyClHdr lhs - ; return (TyFamInstEqn { tfie_tycon = tc - , tfie_pats = mkHsWithBndrs tparams - , tfie_rhs = rhs }) } + ; return (TyFamEqn { tfe_tycon = tc + , tfe_pats = mkHsWithBndrs tparams + , tfe_rhs = rhs }) } mkDataFamInst :: SrcSpan -> NewOrData @@ -214,7 +231,7 @@ mkFamDecl :: SrcSpan -> P (LTyClDecl RdrName) mkFamDecl loc info lhs ksig = do { (tc, tparams) <- checkTyClHdr lhs - ; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams + ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams ; return (L loc (FamDecl (FamilyDecl { fdInfo = info, fdLName = tc , fdTyVars = tyvars, fdKindSig = ksig }))) } where @@ -412,6 +429,56 @@ splitCon ty mk_rest [L _ (HsRecTy flds)] = RecCon flds mk_rest ts = PrefixCon ts +splitPatSyn :: LPat RdrName + -> P (Located RdrName, HsPatSynDetails (Located RdrName)) +splitPatSyn (L _ (ParPat pat)) = splitPatSyn pat +splitPatSyn pat@(L loc (ConPatIn con details)) = do + details' <- case details of + PrefixCon pats -> liftM PrefixPatSyn (mapM patVar pats) + InfixCon pat1 pat2 -> liftM2 InfixPatSyn (patVar pat1) (patVar pat2) + RecCon{} -> recordPatSynErr loc pat + return (con, details') + where + patVar :: LPat RdrName -> P (Located RdrName) + patVar (L loc (VarPat v)) = return $ L loc v + patVar (L _ (ParPat pat)) = patVar pat + patVar (L loc pat) = parseErrorSDoc loc $ + text "Pattern synonym arguments must be variable names:" $$ + ppr pat +splitPatSyn pat@(L loc _) = parseErrorSDoc loc $ + text "invalid pattern synonym declaration:" $$ ppr pat + +recordPatSynErr :: SrcSpan -> LPat RdrName -> P a +recordPatSynErr loc pat = + parseErrorSDoc loc $ + text "record syntax not supported for pattern synonym declarations:" $$ + ppr pat + +toPatSynMatchGroup :: Located RdrName -> Located (OrdList (LHsDecl RdrName)) -> P (MatchGroup RdrName (LHsExpr RdrName)) +toPatSynMatchGroup (L _ patsyn_name) (L _ decls) = + do { matches <- mapM fromDecl (fromOL decls) + ; return $ mkMatchGroup FromSource matches } + where + fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn (L _ name) details)) rhs _ _ _))) = + do { unless (name == patsyn_name) $ + wrongNameBindingErr loc decl + ; match <- case details of + PrefixCon pats -> return $ Match pats Nothing rhs + InfixCon pat1 pat2 -> return $ Match [pat1, pat2] Nothing rhs + RecCon{} -> recordPatSynErr loc pat + ; return $ L loc match } + fromDecl (L loc decl) = extraDeclErr loc decl + + extraDeclErr loc decl = + parseErrorSDoc loc $ + text "pattern synonym 'where' clause must contain a single binding:" $$ + ppr decl + + wrongNameBindingErr loc decl = + parseErrorSDoc loc $ + text "pattern synonym 'where' clause must bind the pattern synonym's name" <+> + quotes (ppr patsyn_name) $$ ppr decl + mkDeprecatedGadtRecordDecl :: SrcSpan -> Located RdrName -> [ConDeclField RdrName] @@ -502,26 +569,42 @@ we can bring x,y into scope. So: * For RecCon we do not \begin{code} -checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName) +checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName) +-- Same as checkTyVars, but in the P monad +checkTyVarsP pp_what equals_or_where tc tparms + = eitherToP $ checkTyVars pp_what equals_or_where tc tparms + +eitherToP :: Either (SrcSpan, SDoc) a -> P a +-- Adapts the Either monad to the P monad +eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc +eitherToP (Right thing) = return thing +checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] + -> Either (SrcSpan, SDoc) (LHsTyVarBndrs RdrName) -- Check whether the given list of type parameters are all type variables --- (possibly with a kind signature). -checkTyVars pp_what equals_or_where tc tparms = do { tvs <- mapM chk tparms - ; return (mkHsQTvs tvs) } +-- (possibly with a kind signature) +-- We use the Either monad because it's also called (via mkATDefault) from +-- Convert.hs +checkTyVars pp_what equals_or_where tc tparms + = do { tvs <- mapM chk tparms + ; return (mkHsQTvs tvs) } where + -- Check that the name space is correct! chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) | isRdrTyVar tv = return (L l (KindedTyVar tv k)) chk (L l (HsTyVar tv)) | isRdrTyVar tv = return (L l (UserTyVar tv)) - chk t@(L l _) - = parseErrorSDoc l $ - vcat [ ptext (sLit "Unexpected type") <+> quotes (ppr t) - , ptext (sLit "In the") <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc) - , vcat[ (ptext (sLit "A") <+> pp_what <+> ptext (sLit "declaration should have form")) - , nest 2 (pp_what <+> ppr tc <+> ptext (sLit "a b c") - <+> equals_or_where) ] ] + chk t@(L loc _) + = Left (loc, + vcat [ ptext (sLit "Unexpected type") <+> quotes (ppr t) + , ptext (sLit "In the") <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc) + , vcat[ (ptext (sLit "A") <+> pp_what <+> ptext (sLit "declaration should have form")) + , nest 2 (pp_what <+> ppr tc + <+> hsep (map text (takeList tparms allNameStrings)) + <+> equals_or_where) ] ]) whereDots, equalsDots :: SDoc +-- Second argument to checkTyVars whereDots = ptext (sLit "where ...") equalsDots = ptext (sLit "= ...") diff --git a/compiler/parser/cutils.c b/compiler/parser/cutils.c index c42ec9e3ce..d714a0cb2a 100644 --- a/compiler/parser/cutils.c +++ b/compiler/parser/cutils.c @@ -37,7 +37,7 @@ ghc_memcmp_off( HsPtr a1, HsInt i, HsPtr a2, HsInt len ) } void -enableTimingStats( void ) /* called from the driver */ +enableTimingStats( void ) /* called from the driver */ { RtsFlags.GcFlags.giveStats = ONELINE_GC_STATS; } @@ -47,9 +47,7 @@ setHeapSize( HsInt size ) { RtsFlags.GcFlags.heapSizeSuggestion = size / BLOCK_SIZE; if (RtsFlags.GcFlags.maxHeapSize != 0 && - RtsFlags.GcFlags.heapSizeSuggestion > RtsFlags.GcFlags.maxHeapSize) { - RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion; + RtsFlags.GcFlags.heapSizeSuggestion > RtsFlags.GcFlags.maxHeapSize) { + RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion; } } - - diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs index 5072908e6a..232f69f67f 100644 --- a/compiler/prelude/ForeignCall.lhs +++ b/compiler/prelude/ForeignCall.lhs @@ -117,7 +117,7 @@ data CCallTarget = StaticTarget CLabelString -- C-land name of label. - (Maybe PackageId) -- What package the function is in. + (Maybe PackageKey) -- What package the function is in. -- If Nothing, then it's taken to be in the current package. -- Note: This information is only used for PrimCalls on Windows. -- See CLabel.labelDynamic and CoreToStg.coreToStgApp diff --git a/compiler/prelude/PrelInfo.lhs b/compiler/prelude/PrelInfo.lhs index 829b5e3bf9..eaefff2364 100644 --- a/compiler/prelude/PrelInfo.lhs +++ b/compiler/prelude/PrelInfo.lhs @@ -5,13 +5,6 @@ \begin{code} {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module PrelInfo ( wiredInIds, ghcPrimIds, primOpRules, builtinRules, @@ -19,7 +12,7 @@ module PrelInfo ( ghcPrimExports, wiredInThings, basicKnownKeyNames, primOpId, - + -- Random other things maybeCharLikeCon, maybeIntLikeCon, @@ -49,9 +42,9 @@ import Data.Array \end{code} %************************************************************************ -%* * +%* * \subsection[builtinNameInfo]{Lookup built-in names} -%* * +%* * %************************************************************************ Notes about wired in things @@ -59,13 +52,13 @@ Notes about wired in things * Wired-in things are Ids\/TyCons that are completely known to the compiler. They are global values in GHC, (e.g. listTyCon :: TyCon). -* A wired in Name contains the thing itself inside the Name: - see Name.wiredInNameTyThing_maybe - (E.g. listTyConName contains listTyCon. +* A wired in Name contains the thing itself inside the Name: + see Name.wiredInNameTyThing_maybe + (E.g. listTyConName contains listTyCon. * The name cache is initialised with (the names of) all wired-in things -* The type checker sees if the Name is wired in before looking up +* The type checker sees if the Name is wired in before looking up the name in the type environment. So the type envt itself contains no wired in things. @@ -78,17 +71,17 @@ wiredInThings :: [TyThing] -- This list is used only to initialise HscMain.knownKeyNames -- to ensure that when you say "Prelude.map" in your source code, you -- get a Name with the correct known key (See Note [Known-key names]) -wiredInThings +wiredInThings = concat - [ -- Wired in TyCons and their implicit Ids - tycon_things - , concatMap implicitTyThings tycon_things + [ -- Wired in TyCons and their implicit Ids + tycon_things + , concatMap implicitTyThings tycon_things - -- Wired in Ids - , map AnId wiredInIds + -- Wired in Ids + , map AnId wiredInIds - -- PrimOps - , map (AnId . primOpId) allThePrimOps + -- PrimOps + , map (AnId . primOpId) allThePrimOps ] where tycon_things = map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons @@ -100,16 +93,16 @@ sense of them in interface pragmas. It's cool, though they all have "non-standard" names, so they won't get past the parser in user code. %************************************************************************ -%* * - PrimOpIds -%* * +%* * + PrimOpIds +%* * %************************************************************************ \begin{code} -primOpIds :: Array Int Id +primOpIds :: Array Int Id -- A cache of the PrimOp Ids, indexed by PrimOp tag -primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op) - | op <- allThePrimOps ] +primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op) + | op <- allThePrimOps ] primOpId :: PrimOp -> Id primOpId op = primOpIds ! primOpTag op @@ -117,9 +110,9 @@ primOpId op = primOpIds ! primOpTag op %************************************************************************ -%* * +%* * \subsection{Export lists for pseudo-modules (GHC.Prim)} -%* * +%* * %************************************************************************ GHC.Prim "exports" all the primops and primitive types, some @@ -130,16 +123,16 @@ ghcPrimExports :: [IfaceExport] ghcPrimExports = map (Avail . idName) ghcPrimIds ++ map (Avail . idName . primOpId) allThePrimOps ++ - [ AvailTC n [n] + [ AvailTC n [n] | tc <- funTyCon : primTyCons, let n = tyConName tc ] \end{code} %************************************************************************ -%* * +%* * \subsection{Built-in keys} -%* * +%* * %************************************************************************ ToDo: make it do the ``like'' part properly (as in 0.26 and before). @@ -152,9 +145,9 @@ maybeIntLikeCon con = con `hasKey` intDataConKey %************************************************************************ -%* * +%* * \subsection{Class predicates} -%* * +%* * %************************************************************************ \begin{code} diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index e7408a16a8..7eefc33ea2 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -130,6 +130,19 @@ import FastString %************************************************************************ %* * + allNameStrings +%* * +%************************************************************************ + +\begin{code} +allNameStrings :: [String] +-- Infinite list of a,b,c...z, aa, ab, ac, ... etc +allNameStrings = [ c:cs | cs <- "" : allNameStrings, c <- ['a'..'z'] ] +\end{code} + + +%************************************************************************ +%* * \subsection{Local Names} %* * %************************************************************************ @@ -448,7 +461,7 @@ rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation mkInteractiveModule :: Int -> Module -- (mkInteractiveMoudule 9) makes module 'interactive:M9' -mkInteractiveModule n = mkModule interactivePackageId (mkModuleName ("Ghci" ++ show n)) +mkInteractiveModule n = mkModule interactivePackageKey (mkModuleName ("Ghci" ++ show n)) pRELUDE_NAME, mAIN_NAME :: ModuleName pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude") @@ -459,28 +472,28 @@ dATA_ARRAY_PARALLEL_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel") dATA_ARRAY_PARALLEL_PRIM_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel.Prim") mkPrimModule :: FastString -> Module -mkPrimModule m = mkModule primPackageId (mkModuleNameFS m) +mkPrimModule m = mkModule primPackageKey (mkModuleNameFS m) mkIntegerModule :: FastString -> Module -mkIntegerModule m = mkModule integerPackageId (mkModuleNameFS m) +mkIntegerModule m = mkModule integerPackageKey (mkModuleNameFS m) mkBaseModule :: FastString -> Module -mkBaseModule m = mkModule basePackageId (mkModuleNameFS m) +mkBaseModule m = mkModule basePackageKey (mkModuleNameFS m) mkBaseModule_ :: ModuleName -> Module -mkBaseModule_ m = mkModule basePackageId m +mkBaseModule_ m = mkModule basePackageKey m mkThisGhcModule :: FastString -> Module -mkThisGhcModule m = mkModule thisGhcPackageId (mkModuleNameFS m) +mkThisGhcModule m = mkModule thisGhcPackageKey (mkModuleNameFS m) mkThisGhcModule_ :: ModuleName -> Module -mkThisGhcModule_ m = mkModule thisGhcPackageId m +mkThisGhcModule_ m = mkModule thisGhcPackageKey m mkMainModule :: FastString -> Module -mkMainModule m = mkModule mainPackageId (mkModuleNameFS m) +mkMainModule m = mkModule mainPackageKey (mkModuleNameFS m) mkMainModule_ :: ModuleName -> Module -mkMainModule_ m = mkModule mainPackageId m +mkMainModule_ m = mkModule mainPackageKey m \end{code} %************************************************************************ @@ -823,20 +836,20 @@ inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey -- Base classes (Eq, Ord, Functor) fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name -eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey -eqName = methName gHC_CLASSES (fsLit "==") eqClassOpKey -ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey -geName = methName gHC_CLASSES (fsLit ">=") geClassOpKey -functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey -fmapName = methName gHC_BASE (fsLit "fmap") fmapClassOpKey +eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey +eqName = varQual gHC_CLASSES (fsLit "==") eqClassOpKey +ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey +geName = varQual gHC_CLASSES (fsLit ">=") geClassOpKey +functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey +fmapName = varQual gHC_BASE (fsLit "fmap") fmapClassOpKey -- Class Monad monadClassName, thenMName, bindMName, returnMName, failMName :: Name -monadClassName = clsQual gHC_BASE (fsLit "Monad") monadClassKey -thenMName = methName gHC_BASE (fsLit ">>") thenMClassOpKey -bindMName = methName gHC_BASE (fsLit ">>=") bindMClassOpKey -returnMName = methName gHC_BASE (fsLit "return") returnMClassOpKey -failMName = methName gHC_BASE (fsLit "fail") failMClassOpKey +monadClassName = clsQual gHC_BASE (fsLit "Monad") monadClassKey +thenMName = varQual gHC_BASE (fsLit ">>") thenMClassOpKey +bindMName = varQual gHC_BASE (fsLit ">>=") bindMClassOpKey +returnMName = varQual gHC_BASE (fsLit "return") returnMClassOpKey +failMName = varQual gHC_BASE (fsLit "fail") failMClassOpKey -- Classes (Applicative, Foldable, Traversable) applicativeClassName, foldableClassName, traversableClassName :: Name @@ -849,10 +862,10 @@ traversableClassName = clsQual dATA_TRAVERSABLE (fsLit "Traversable") trave -- AMP additions joinMName, apAName, pureAName, alternativeClassName :: Name -joinMName = methName mONAD (fsLit "join") joinMIdKey -apAName = methName cONTROL_APPLICATIVE (fsLit "<*>") apAClassOpKey -pureAName = methName cONTROL_APPLICATIVE (fsLit "pure") pureAClassOpKey -alternativeClassName = clsQual cONTROL_APPLICATIVE (fsLit "Alternative") alternativeClassKey +joinMName = varQual mONAD (fsLit "join") joinMIdKey +apAName = varQual cONTROL_APPLICATIVE (fsLit "<*>") apAClassOpKey +pureAName = varQual cONTROL_APPLICATIVE (fsLit "pure") pureAClassOpKey +alternativeClassName = clsQual cONTROL_APPLICATIVE (fsLit "Alternative") alternativeClassKey joinMIdKey, apAClassOpKey, pureAClassOpKey, alternativeClassKey :: Unique joinMIdKey = mkPreludeMiscIdUnique 750 @@ -870,7 +883,7 @@ fromStringName, otherwiseIdName, foldrName, buildName, augmentName, mapName, appendName, assertName, breakpointName, breakpointCondName, breakpointAutoName, opaqueTyConName :: Name -fromStringName = methName dATA_STRING (fsLit "fromString") fromStringClassOpKey +fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey otherwiseIdName = varQual gHC_BASE (fsLit "otherwise") otherwiseIdKey foldrName = varQual gHC_BASE (fsLit "foldr") foldrIdKey buildName = varQual gHC_BASE (fsLit "build") buildIdKey @@ -881,7 +894,7 @@ assertName = varQual gHC_BASE (fsLit "assert") assertIdKey breakpointName = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey breakpointAutoName= varQual gHC_BASE (fsLit "breakpointAuto") breakpointAutoIdKey -opaqueTyConName = tcQual gHC_BASE (fsLit "Opaque") opaqueTyConKey +opaqueTyConName = tcQual gHC_BASE (fsLit "Opaque") opaqueTyConKey breakpointJumpName :: Name breakpointJumpName @@ -909,10 +922,10 @@ sndName = varQual dATA_TUPLE (fsLit "snd") sndIdKey -- Module GHC.Num numClassName, fromIntegerName, minusName, negateName :: Name -numClassName = clsQual gHC_NUM (fsLit "Num") numClassKey -fromIntegerName = methName gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey -minusName = methName gHC_NUM (fsLit "-") minusClassOpKey -negateName = methName gHC_NUM (fsLit "negate") negateClassOpKey +numClassName = clsQual gHC_NUM (fsLit "Num") numClassKey +fromIntegerName = varQual gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey +minusName = varQual gHC_NUM (fsLit "-") minusClassOpKey +negateName = varQual gHC_NUM (fsLit "negate") negateClassOpKey integerTyConName, mkIntegerName, integerToWord64Name, integerToInt64Name, @@ -979,23 +992,23 @@ rationalTyConName, ratioTyConName, ratioDataConName, realClassName, integralClassName, realFracClassName, fractionalClassName, fromRationalName, toIntegerName, toRationalName, fromIntegralName, realToFracName :: Name -rationalTyConName = tcQual gHC_REAL (fsLit "Rational") rationalTyConKey -ratioTyConName = tcQual gHC_REAL (fsLit "Ratio") ratioTyConKey -ratioDataConName = conName gHC_REAL (fsLit ":%") ratioDataConKey -realClassName = clsQual gHC_REAL (fsLit "Real") realClassKey -integralClassName = clsQual gHC_REAL (fsLit "Integral") integralClassKey -realFracClassName = clsQual gHC_REAL (fsLit "RealFrac") realFracClassKey -fractionalClassName = clsQual gHC_REAL (fsLit "Fractional") fractionalClassKey -fromRationalName = methName gHC_REAL (fsLit "fromRational") fromRationalClassOpKey -toIntegerName = methName gHC_REAL (fsLit "toInteger") toIntegerClassOpKey -toRationalName = methName gHC_REAL (fsLit "toRational") toRationalClassOpKey -fromIntegralName = varQual gHC_REAL (fsLit "fromIntegral") fromIntegralIdKey -realToFracName = varQual gHC_REAL (fsLit "realToFrac") realToFracIdKey +rationalTyConName = tcQual gHC_REAL (fsLit "Rational") rationalTyConKey +ratioTyConName = tcQual gHC_REAL (fsLit "Ratio") ratioTyConKey +ratioDataConName = conName gHC_REAL (fsLit ":%") ratioDataConKey +realClassName = clsQual gHC_REAL (fsLit "Real") realClassKey +integralClassName = clsQual gHC_REAL (fsLit "Integral") integralClassKey +realFracClassName = clsQual gHC_REAL (fsLit "RealFrac") realFracClassKey +fractionalClassName = clsQual gHC_REAL (fsLit "Fractional") fractionalClassKey +fromRationalName = varQual gHC_REAL (fsLit "fromRational") fromRationalClassOpKey +toIntegerName = varQual gHC_REAL (fsLit "toInteger") toIntegerClassOpKey +toRationalName = varQual gHC_REAL (fsLit "toRational") toRationalClassOpKey +fromIntegralName = varQual gHC_REAL (fsLit "fromIntegral")fromIntegralIdKey +realToFracName = varQual gHC_REAL (fsLit "realToFrac") realToFracIdKey -- PrelFloat classes floatingClassName, realFloatClassName :: Name -floatingClassName = clsQual gHC_FLOAT (fsLit "Floating") floatingClassKey -realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey +floatingClassName = clsQual gHC_FLOAT (fsLit "Floating") floatingClassKey +realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey -- other GHC.Float functions rationalToFloatName, rationalToDoubleName :: Name @@ -1011,7 +1024,7 @@ typeableClassName, oldTypeableClassName, oldTypeable1ClassName, oldTypeable2ClassName, oldTypeable3ClassName, oldTypeable4ClassName, oldTypeable5ClassName, oldTypeable6ClassName, oldTypeable7ClassName :: Name -typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey +typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey oldTypeableClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable") oldTypeableClassKey oldTypeable1ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable1") oldTypeable1ClassKey oldTypeable2ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable2") oldTypeable2ClassKey @@ -1037,33 +1050,33 @@ assertErrorName = varQual gHC_IO_Exception (fsLit "assertError") assertErrorId -- Enum module (Enum, Bounded) enumClassName, enumFromName, enumFromToName, enumFromThenName, enumFromThenToName, boundedClassName :: Name -enumClassName = clsQual gHC_ENUM (fsLit "Enum") enumClassKey -enumFromName = methName gHC_ENUM (fsLit "enumFrom") enumFromClassOpKey -enumFromToName = methName gHC_ENUM (fsLit "enumFromTo") enumFromToClassOpKey -enumFromThenName = methName gHC_ENUM (fsLit "enumFromThen") enumFromThenClassOpKey -enumFromThenToName = methName gHC_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey -boundedClassName = clsQual gHC_ENUM (fsLit "Bounded") boundedClassKey +enumClassName = clsQual gHC_ENUM (fsLit "Enum") enumClassKey +enumFromName = varQual gHC_ENUM (fsLit "enumFrom") enumFromClassOpKey +enumFromToName = varQual gHC_ENUM (fsLit "enumFromTo") enumFromToClassOpKey +enumFromThenName = varQual gHC_ENUM (fsLit "enumFromThen") enumFromThenClassOpKey +enumFromThenToName = varQual gHC_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey +boundedClassName = clsQual gHC_ENUM (fsLit "Bounded") boundedClassKey -- List functions concatName, filterName, zipName :: Name concatName = varQual gHC_LIST (fsLit "concat") concatIdKey filterName = varQual gHC_LIST (fsLit "filter") filterIdKey -zipName = varQual gHC_LIST (fsLit "zip") zipIdKey +zipName = varQual gHC_LIST (fsLit "zip") zipIdKey -- Overloaded lists isListClassName, fromListName, fromListNName, toListName :: Name -isListClassName = clsQual gHC_EXTS (fsLit "IsList") isListClassKey -fromListName = methName gHC_EXTS (fsLit "fromList") fromListClassOpKey -fromListNName = methName gHC_EXTS (fsLit "fromListN") fromListNClassOpKey -toListName = methName gHC_EXTS (fsLit "toList") toListClassOpKey +isListClassName = clsQual gHC_EXTS (fsLit "IsList") isListClassKey +fromListName = varQual gHC_EXTS (fsLit "fromList") fromListClassOpKey +fromListNName = varQual gHC_EXTS (fsLit "fromListN") fromListNClassOpKey +toListName = varQual gHC_EXTS (fsLit "toList") toListClassOpKey -- Class Show showClassName :: Name -showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey +showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey -- Class Read readClassName :: Name -readClassName = clsQual gHC_READ (fsLit "Read") readClassKey +readClassName = clsQual gHC_READ (fsLit "Read") readClassKey -- Classes Generic and Generic1, Datatype, Constructor and Selector genClassName, gen1ClassName, datatypeClassName, constructorClassName, @@ -1071,24 +1084,27 @@ genClassName, gen1ClassName, datatypeClassName, constructorClassName, genClassName = clsQual gHC_GENERICS (fsLit "Generic") genClassKey gen1ClassName = clsQual gHC_GENERICS (fsLit "Generic1") gen1ClassKey -datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey +datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey -selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey +selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey + +genericClassNames :: [Name] +genericClassNames = [genClassName, gen1ClassName] -- GHCi things ghciIoClassName, ghciStepIoMName :: Name ghciIoClassName = clsQual gHC_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey -ghciStepIoMName = methName gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey +ghciStepIoMName = varQual gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey -- IO things ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName, failIOName :: Name -ioTyConName = tcQual gHC_TYPES (fsLit "IO") ioTyConKey -ioDataConName = conName gHC_TYPES (fsLit "IO") ioDataConKey -thenIOName = varQual gHC_BASE (fsLit "thenIO") thenIOIdKey -bindIOName = varQual gHC_BASE (fsLit "bindIO") bindIOIdKey -returnIOName = varQual gHC_BASE (fsLit "returnIO") returnIOIdKey -failIOName = varQual gHC_IO (fsLit "failIO") failIOIdKey +ioTyConName = tcQual gHC_TYPES (fsLit "IO") ioTyConKey +ioDataConName = conName gHC_TYPES (fsLit "IO") ioDataConKey +thenIOName = varQual gHC_BASE (fsLit "thenIO") thenIOIdKey +bindIOName = varQual gHC_BASE (fsLit "bindIO") bindIOIdKey +returnIOName = varQual gHC_BASE (fsLit "returnIO") returnIOIdKey +failIOName = varQual gHC_IO (fsLit "failIO") failIOIdKey -- IO things printName :: Name @@ -1096,7 +1112,7 @@ printName = varQual sYSTEM_IO (fsLit "print") printIdKey -- Int, Word, and Addr things int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name -int8TyConName = tcQual gHC_INT (fsLit "Int8") int8TyConKey +int8TyConName = tcQual gHC_INT (fsLit "Int8") int8TyConKey int16TyConName = tcQual gHC_INT (fsLit "Int16") int16TyConKey int32TyConName = tcQual gHC_INT (fsLit "Int32") int32TyConKey int64TyConName = tcQual gHC_INT (fsLit "Int64") int64TyConKey @@ -1110,12 +1126,12 @@ word64TyConName = tcQual gHC_WORD (fsLit "Word64") word64TyConKey -- PrelPtr module ptrTyConName, funPtrTyConName :: Name -ptrTyConName = tcQual gHC_PTR (fsLit "Ptr") ptrTyConKey +ptrTyConName = tcQual gHC_PTR (fsLit "Ptr") ptrTyConKey funPtrTyConName = tcQual gHC_PTR (fsLit "FunPtr") funPtrTyConKey -- Foreign objects and weak pointers stablePtrTyConName, newStablePtrName :: Name -stablePtrTyConName = tcQual gHC_STABLE (fsLit "StablePtr") stablePtrTyConKey +stablePtrTyConName = tcQual gHC_STABLE (fsLit "StablePtr") stablePtrTyConKey newStablePtrName = varQual gHC_STABLE (fsLit "newStablePtr") newStablePtrIdKey -- PrelST module @@ -1125,21 +1141,21 @@ runSTRepName = varQual gHC_ST (fsLit "runSTRep") runSTRepIdKey -- Recursive-do notation monadFixClassName, mfixName :: Name monadFixClassName = clsQual mONAD_FIX (fsLit "MonadFix") monadFixClassKey -mfixName = methName mONAD_FIX (fsLit "mfix") mfixIdKey +mfixName = varQual mONAD_FIX (fsLit "mfix") mfixIdKey -- Arrow notation arrAName, composeAName, firstAName, appAName, choiceAName, loopAName :: Name -arrAName = varQual aRROW (fsLit "arr") arrAIdKey +arrAName = varQual aRROW (fsLit "arr") arrAIdKey composeAName = varQual gHC_DESUGAR (fsLit ">>>") composeAIdKey -firstAName = varQual aRROW (fsLit "first") firstAIdKey -appAName = varQual aRROW (fsLit "app") appAIdKey -choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey -loopAName = varQual aRROW (fsLit "loop") loopAIdKey +firstAName = varQual aRROW (fsLit "first") firstAIdKey +appAName = varQual aRROW (fsLit "app") appAIdKey +choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey +loopAName = varQual aRROW (fsLit "loop") loopAIdKey -- Monad comprehensions guardMName, liftMName, mzipName :: Name -guardMName = varQual mONAD (fsLit "guard") guardMIdKey -liftMName = varQual mONAD (fsLit "liftM") liftMIdKey +guardMName = varQual mONAD (fsLit "guard") guardMIdKey +liftMName = varQual mONAD (fsLit "liftM") liftMIdKey mzipName = varQual mONAD_ZIP (fsLit "mzip") mzipIdKey @@ -1150,9 +1166,9 @@ toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAn -- Other classes, needed for type defaulting monadPlusClassName, randomClassName, randomGenClassName, isStringClassName :: Name -monadPlusClassName = clsQual mONAD (fsLit "MonadPlus") monadPlusClassKey -randomClassName = clsQual rANDOM (fsLit "Random") randomClassKey -randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey +monadPlusClassName = clsQual mONAD (fsLit "MonadPlus") monadPlusClassKey +randomClassName = clsQual rANDOM (fsLit "Random") randomClassKey +randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey -- Type-level naturals @@ -1208,10 +1224,6 @@ mk_known_key_name space modu str unique conName :: Module -> FastString -> Unique -> Name conName modu occ unique = mkExternalName unique modu (mkOccNameFS dataName occ) noSrcSpan - -methName :: Module -> FastString -> Unique -> Name -methName modu occ unique - = mkExternalName unique modu (mkVarOccFS occ) noSrcSpan \end{code} %************************************************************************ diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs index 4155a541ba..198078bc9f 100644 --- a/compiler/prelude/PrimOp.lhs +++ b/compiler/prelude/PrimOp.lhs @@ -40,7 +40,7 @@ import Unique ( Unique, mkPrimOpIdUnique ) import Outputable import FastTypes import FastString -import Module ( PackageId ) +import Module ( PackageKey ) \end{code} %************************************************************************ @@ -329,27 +329,89 @@ Note [PrimOp can_fail and has_side_effects] Both can_fail and has_side_effects mean that the primop has some effect that is not captured entirely by its result value. - ---------- has_side_effects --------------------- - Has some imperative side effect, perhaps on the world (I/O), - or perhaps on some mutable data structure (writeIORef). - Generally speaking all such primops have a type like - State -> input -> (State, output) - so the state token guarantees ordering, and also ensures - that the primop is executed even if 'output' is discarded. - - ---------- can_fail ---------------------------- - Can fail with a seg-fault or divide-by-zero error on some elements - of its input domain. Main examples: - division (fails on zero demoninator - array indexing (fails if the index is out of bounds) - However (ASSUMPTION), these can_fail primops are ALWAYS surrounded - with a test that checks for the bad cases. - -Consequences: - -* You can discard a can_fail primop, or float it _inwards_. - But you cannot float it _outwards_, lest you escape the - dynamic scope of the test. Example: +---------- has_side_effects --------------------- +A primop "has_side_effects" if it has some *write* effect, visible +elsewhere + - writing to the world (I/O) + - writing to a mutable data structure (writeIORef) + - throwing a synchronous Haskell exception + +Often such primops have a type like + State -> input -> (State, output) +so the state token guarantees ordering. In general we rely *only* on +data dependencies of the state token to enforce write-effect ordering + + * NB1: if you inline unsafePerformIO, you may end up with + side-effecting ops whose 'state' output is discarded. + And programmers may do that by hand; see Trac #9390. + That is why we (conservatively) do not discard write-effecting + primops even if both their state and result is discarded. + + * NB2: We consider primops, such as raiseIO#, that can raise a + (Haskell) synchronous exception to "have_side_effects" but not + "can_fail". We must be careful about not discarding such things; + see the paper "A semantics for imprecise exceptions". + + * NB3: *Read* effects (like reading an IORef) don't count here, + because it doesn't matter if we don't do them, or do them more than + once. *Sequencing* is maintained by the data dependency of the state + token. + +---------- can_fail ---------------------------- +A primop "can_fail" if it can fail with an *unchecked* exception on +some elements of its input domain. Main examples: + division (fails on zero demoninator) + array indexing (fails if the index is out of bounds) + +An "unchecked exception" is one that is an outright error, (not +turned into a Haskell exception,) such as seg-fault or +divide-by-zero error. Such can_fail primops are ALWAYS surrounded +with a test that checks for the bad cases, but we need to be +very careful about code motion that might move it out of +the scope of the test. + +Note [Transformations affected by can_fail and has_side_effects] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The can_fail and has_side_effects properties have the following effect +on program transformations. Summary table is followed by details. + + can_fail has_side_effects +Discard NO NO +Float in YES YES +Float out NO NO +Duplicate YES NO + +* Discarding. case (a `op` b) of _ -> rhs ===> rhs + You should not discard a has_side_effects primop; e.g. + case (writeIntArray# a i v s of (# _, _ #) -> True + Arguably you should be able to discard this, since the + returned stat token is not used, but that relies on NEVER + inlining unsafePerformIO, and programmers sometimes write + this kind of stuff by hand (Trac #9390). So we (conservatively) + never discard a has_side_effects primop. + + However, it's fine to discard a can_fail primop. For example + case (indexIntArray# a i) of _ -> True + We can discard indexIntArray#; it has can_fail, but not + has_side_effects; see Trac #5658 which was all about this. + Notice that indexIntArray# is (in a more general handling of + effects) read effect, but we don't care about that here, and + treat read effects as *not* has_side_effects. + + Similarly (a `/#` b) can be discarded. It can seg-fault or + cause a hardware exception, but not a synchronous Haskell + exception. + + + + Synchronous Haskell exceptions, e.g. from raiseIO#, are treated + as has_side_effects and hence are not discarded. + +* Float in. You can float a can_fail or has_side_effects primop + *inwards*, but not inside a lambda (see Duplication below). + +* Float out. You must not float a can_fail primop *outwards* lest + you escape the dynamic scope of the test. Example: case d ># 0# of True -> case x /# d of r -> r +# 1 False -> 0 @@ -359,25 +421,21 @@ Consequences: True -> r +# 1 False -> 0 -* I believe that exactly the same rules apply to a has_side_effects - primop; you can discard it (remember, the state token will keep - it alive if necessary), or float it in, but not float it out. - - Example of the latter - if blah then let! s1 = writeMutVar s0 v True in s1 + Nor can you float out a has_side_effects primop. For example: + if blah then case writeMutVar# v True s0 of (# s1 #) -> s1 else s0 - Notice that s0 is mentioned in both branches of the 'if', but + Notice that s0 is mentioned in both branches of the 'if', but only one of these two will actually be consumed. But if we float out to - let! s1 = writeMutVar s0 v True - in if blah then s1 else s0 + case writeMutVar# v True s0 of (# s1 #) -> + if blah then s1 else s0 the writeMutVar will be performed in both branches, which is utterly wrong. -* You cannot duplicate a has_side_effect primop. You might wonder - how this can occur given the state token threading, but just look - at Control.Monad.ST.Lazy.Imp.strictToLazy! We get something like - this +* Duplication. You cannot duplicate a has_side_effect primop. You + might wonder how this can occur given the state token threading, but + just look at Control.Monad.ST.Lazy.Imp.strictToLazy! We get + something like this p = case readMutVar# s v of (# s', r #) -> (S# s', r) s' = case p of (s', r) -> s' @@ -385,28 +443,28 @@ Consequences: (All these bindings are boxed.) If we inline p at its two call sites, we get a catastrophe: because the read is performed once when - s' is demanded, and once when 'r' is demanded, which may be much + s' is demanded, and once when 'r' is demanded, which may be much later. Utterly wrong. Trac #3207 is real example of this happening. - However, it's fine to duplicate a can_fail primop. That is - the difference between can_fail and has_side_effects. + However, it's fine to duplicate a can_fail primop. That is really + the only difference between can_fail and has_side_effects. - can_fail has_side_effects -Discard YES YES -Float in YES YES -Float out NO NO -Duplicate YES NO +Note [Implementation: how can_fail/has_side_effects affect transformations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How do we ensure that that floating/duplication/discarding are done right +in the simplifier? -How do we achieve these effects? +Two main predicates on primpops test these flags: + primOpOkForSideEffects <=> not has_side_effects + primOpOkForSpeculation <=> not (has_side_effects || can_fail) -Note [primOpOkForSpeculation] * The "no-float-out" thing is achieved by ensuring that we never let-bind a can_fail or has_side_effects primop. The RHS of a let-binding (which can float in and out freely) satisfies - exprOkForSpeculation. And exprOkForSpeculation is false of - can_fail and no_side_effect. + exprOkForSpeculation; this is the let/app invariant. And + exprOkForSpeculation is false of can_fail and has_side_effects. - * So can_fail and no_side_effect primops will appear only as the + * So can_fail and has_side_effects primops will appear only as the scrutinees of cases, and that's why the FloatIn pass is capable of floating case bindings inwards. @@ -422,10 +480,14 @@ primOpCanFail :: PrimOp -> Bool #include "primop-can-fail.hs-incl" primOpOkForSpeculation :: PrimOp -> Bool - -- See Note [primOpOkForSpeculation and primOpOkForFloatOut] + -- See Note [PrimOp can_fail and has_side_effects] -- See comments with CoreUtils.exprOkForSpeculation + -- primOpOkForSpeculation => primOpOkForSideEffects primOpOkForSpeculation op - = not (primOpHasSideEffects op || primOpOutOfLine op || primOpCanFail op) + = primOpOkForSideEffects op + && not (primOpOutOfLine op || primOpCanFail op) + -- I think the "out of line" test is because out of line things can + -- be expensive (eg sine, cosine), and so we may not want to speculate them primOpOkForSideEffects :: PrimOp -> Bool primOpOkForSideEffects op @@ -443,6 +505,7 @@ behaviour of 'seq' for primops that can fail, so we don't treat them as cheap. \begin{code} primOpIsCheap :: PrimOp -> Bool +-- See Note [PrimOp can_fail and has_side_effects] primOpIsCheap op = primOpOkForSpeculation op -- In March 2001, we changed this to -- primOpIsCheap op = False @@ -587,7 +650,7 @@ pprPrimOp other_op = pprOccName (primOpOcc other_op) %************************************************************************ \begin{code} -data PrimCall = PrimCall CLabelString PackageId +data PrimCall = PrimCall CLabelString PackageKey instance Outputable PrimCall where ppr (PrimCall lbl pkgId) diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 4851315eb4..19cd8127e5 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -1363,19 +1363,79 @@ primop SetByteArrayOp "setByteArray#" GenPrimOp code_size = { primOpCodeSizeForeignCall + 4 } can_fail = True +-- Atomic operations + +primop AtomicReadByteArrayOp_Int "atomicReadIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #) + {Given an array and an offset in Int units, read an element. The + index is assumed to be in bounds. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop AtomicWriteByteArrayOp_Int "atomicWriteIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + {Given an array and an offset in Int units, write an element. The + index is assumed to be in bounds. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + primop CasByteArrayOp_Int "casIntArray#" GenPrimOp MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #) - {Machine-level atomic compare and swap on a word within a ByteArray.} - with - out_of_line = True - has_side_effects = True + {Given an array, an offset in Int units, the expected old value, and + the new value, perform an atomic compare and swap i.e. write the new + value if the current value matches the provided old value. Returns + the value of the element before the operation. Implies a full memory + barrier.} + with has_side_effects = True + can_fail = True primop FetchAddByteArrayOp_Int "fetchAddIntArray#" GenPrimOp MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) - {Machine-level word-sized fetch-and-add within a ByteArray.} - with - out_of_line = True - has_side_effects = True + {Given an array, and offset in Int units, and a value to add, + atomically add the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchSubByteArrayOp_Int "fetchSubIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to subtract, + atomically substract the value to the element. Returns the value of + the element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchAndByteArrayOp_Int "fetchAndIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to AND, + atomically AND the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchNandByteArrayOp_Int "fetchNandIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to NAND, + atomically NAND the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchOrByteArrayOp_Int "fetchOrIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to OR, + atomically OR the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchXorByteArrayOp_Int "fetchXorIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to XOR, + atomically XOR the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True ------------------------------------------------------------------------ @@ -1821,6 +1881,11 @@ primop RaiseOp "raise#" GenPrimOp strictness = { \ _arity -> mkClosedStrictSig [topDmd] botRes } -- NB: result is bottom out_of_line = True + has_side_effects = True + -- raise# certainly throws a Haskell exception and hence has_side_effects + -- It doesn't actually make much difference because the fact that it + -- returns bottom independently ensures that we are careful not to discard + -- it. But still, it's better to say the Right Thing. -- raiseIO# needs to be a primop, because exceptions in the IO monad -- must be *precise* - we don't want the strictness analyser turning diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs index 4a7a063897..8a6ed044fb 100644 --- a/compiler/profiling/CostCentre.lhs +++ b/compiler/profiling/CostCentre.lhs @@ -1,32 +1,24 @@ \begin{code} -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - {-# LANGUAGE BangPatterns, DeriveDataTypeable #-} - module CostCentre ( CostCentre(..), CcName, IsCafCC(..), - -- All abstract except to friend: ParseIface.y + -- All abstract except to friend: ParseIface.y - CostCentreStack, - CollectedCCs, + CostCentreStack, + CollectedCCs, noCCS, currentCCS, dontCareCCS, noCCSAttached, isCurrentCCS, maybeSingletonCCS, - mkUserCC, mkAutoCC, mkAllCafsCC, + mkUserCC, mkAutoCC, mkAllCafsCC, mkSingletonCCS, isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule, - pprCostCentreCore, + pprCostCentreCore, costCentreUserName, costCentreUserNameFS, costCentreSrcSpan, - cmpCostCentre -- used for removing dups in a list + cmpCostCentre -- used for removing dups in a list ) where import Binary @@ -34,7 +26,7 @@ import Var import Name import Module import Unique -import Outputable +import Outputable import FastTypes import SrcLoc import FastString @@ -46,7 +38,7 @@ import Data.Data -- Cost Centres -- | A Cost Centre is a single @{-# SCC #-}@ annotation. - + data CostCentre = NormalCC { cc_key :: {-# UNPACK #-} !Int, @@ -66,7 +58,7 @@ data CostCentre cc_is_caf :: IsCafCC -- see below } - | AllCafsCC { + | AllCafsCC { cc_mod :: Module, -- Name of module defining this CC. cc_loc :: SrcSpan } @@ -79,10 +71,10 @@ data IsCafCC = NotCafCC | CafCC instance Eq CostCentre where - c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } + c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } instance Ord CostCentre where - compare = cmpCostCentre + compare = cmpCostCentre cmpCostCentre :: CostCentre -> CostCentre -> Ordering @@ -96,8 +88,8 @@ cmpCostCentre NormalCC {cc_key = n1, cc_mod = m1} cmpCostCentre other_1 other_2 = let - !tag1 = tag_CC other_1 - !tag2 = tag_CC other_2 + !tag1 = tag_CC other_1 + !tag2 = tag_CC other_2 in if tag1 <# tag2 then LT else GT where @@ -143,7 +135,7 @@ mkAutoCC id mod is_caf cc_loc = nameSrcSpan (getName id), cc_is_caf = is_caf } - where + where name = getName id -- beware: only external names are guaranteed to have unique -- Occnames. If the name is not external, we must append its @@ -161,28 +153,28 @@ mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc } -- | A Cost Centre Stack is something that can be attached to a closure. -- This is either: --- +-- -- * the current cost centre stack (CCCS) -- * a pre-defined cost centre stack (there are several --- pre-defined CCSs, see below). +-- pre-defined CCSs, see below). data CostCentreStack = NoCCS - | CurrentCCS -- Pinned on a let(rec)-bound - -- thunk/function/constructor, this says that the - -- cost centre to be attached to the object, when it - -- is allocated, is whatever is in the - -- current-cost-centre-stack register. + | CurrentCCS -- Pinned on a let(rec)-bound + -- thunk/function/constructor, this says that the + -- cost centre to be attached to the object, when it + -- is allocated, is whatever is in the + -- current-cost-centre-stack register. | DontCareCCS -- We need a CCS to stick in static closures - -- (for data), but we *don't* expect them to - -- accumulate any costs. But we still need - -- the placeholder. This CCS is it. + -- (for data), but we *don't* expect them to + -- accumulate any costs. But we still need + -- the placeholder. This CCS is it. | SingletonCCS CostCentre - deriving (Eq, Ord) -- needed for Ord on CLabel + deriving (Eq, Ord) -- needed for Ord on CLabel -- synonym for triple which describes the cost centre info in the generated @@ -196,7 +188,7 @@ type CollectedCCs noCCS, currentCCS, dontCareCCS :: CostCentreStack -noCCS = NoCCS +noCCS = NoCCS currentCCS = CurrentCCS dontCareCCS = DontCareCCS @@ -204,20 +196,20 @@ dontCareCCS = DontCareCCS -- Predicates on Cost-Centre Stacks noCCSAttached :: CostCentreStack -> Bool -noCCSAttached NoCCS = True -noCCSAttached _ = False +noCCSAttached NoCCS = True +noCCSAttached _ = False isCurrentCCS :: CostCentreStack -> Bool -isCurrentCCS CurrentCCS = True -isCurrentCCS _ = False +isCurrentCCS CurrentCCS = True +isCurrentCCS _ = False isCafCCS :: CostCentreStack -> Bool isCafCCS (SingletonCCS cc) = isCafCC cc -isCafCCS _ = False +isCafCCS _ = False maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre maybeSingletonCCS (SingletonCCS cc) = Just cc -maybeSingletonCCS _ = Nothing +maybeSingletonCCS _ = Nothing mkSingletonCCS :: CostCentre -> CostCentreStack mkSingletonCCS cc = SingletonCCS cc @@ -230,31 +222,31 @@ mkSingletonCCS cc = SingletonCCS cc -- expression. instance Outputable CostCentreStack where - ppr NoCCS = ptext (sLit "NO_CCS") - ppr CurrentCCS = ptext (sLit "CCCS") + ppr NoCCS = ptext (sLit "NO_CCS") + ppr CurrentCCS = ptext (sLit "CCCS") ppr DontCareCCS = ptext (sLit "CCS_DONT_CARE") ppr (SingletonCCS cc) = ppr cc <> ptext (sLit "_ccs") ----------------------------------------------------------------------------- -- Printing Cost Centres --- +-- -- There are several different ways in which we might want to print a -- cost centre: --- --- - the name of the cost centre, for profiling output (a C string) --- - the label, i.e. C label for cost centre in .hc file. --- - the debugging name, for output in -ddump things --- - the interface name, for printing in _scc_ exprs in iface files. --- +-- +-- - the name of the cost centre, for profiling output (a C string) +-- - the label, i.e. C label for cost centre in .hc file. +-- - the debugging name, for output in -ddump things +-- - the interface name, for printing in _scc_ exprs in iface files. +-- -- The last 3 are derived from costCentreStr below. The first is given -- by costCentreName. instance Outputable CostCentre where ppr cc = getPprStyle $ \ sty -> - if codeStyle sty - then ppCostCentreLbl cc - else text (costCentreUserName cc) + if codeStyle sty + then ppCostCentreLbl cc + else text (costCentreUserName cc) -- Printing in Core pprCostCentreCore :: CostCentre -> SDoc @@ -281,7 +273,7 @@ ppCostCentreLbl (NormalCC {cc_key = k, cc_name = n, cc_mod = m, = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> case is_caf of { CafCC -> ptext (sLit "CAF"); _ -> ppr (mkUniqueGrimily k)} <> text "_cc" --- This is the name to go in the user-displayed string, +-- This is the name to go in the user-displayed string, -- recorded in the cost centre declaration costCentreUserName :: CostCentre -> String costCentreUserName = unpackFS . costCentreUserNameFS diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index e65d3173d6..0f9f44aed6 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -433,12 +433,12 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = name@(L nameLoc _) }) = do { newname <- applyNameMaker name_maker name ; return (bind { fun_id = L nameLoc newname }) } -rnBindLHS name_maker _ bind@(PatSynBind{ patsyn_id = rdrname@(L nameLoc _) }) +rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname@(L nameLoc _) }) = do { unless (isTopRecNameMaker name_maker) $ addErr localPatternSynonymErr ; addLocM checkConName rdrname ; name <- applyNameMaker name_maker rdrname - ; return (bind{ patsyn_id = L nameLoc name }) } + ; return (PatSynBind psb{ psb_id = L nameLoc name }) } where localPatternSynonymErr :: SDoc localPatternSynonymErr @@ -515,15 +515,37 @@ rnBind sig_fn bind@(FunBind { fun_id = name [plain_name], rhs_fvs) } -rnBind _sig_fn bind@(PatSynBind { patsyn_id = L _ name - , patsyn_args = details - , patsyn_def = pat - , patsyn_dir = dir }) +rnBind sig_fn (PatSynBind bind) + = do { (bind', name, fvs) <- rnPatSynBind sig_fn bind + ; return (PatSynBind bind', name, fvs) } + +rnBind _ b = pprPanic "rnBind" (ppr b) + +{- +Note [Free-variable space leak] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have + fvs' = trim fvs +and we seq fvs' before turning it as part of a record. + +The reason is that trim is sometimes something like + \xs -> intersectNameSet (mkNameSet bound_names) xs +and we don't want to retain the list bound_names. This showed up in +trac ticket #1136. +-} + +rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function + -> PatSynBind Name RdrName + -> RnM (PatSynBind Name Name, [Name], Uses) +rnPatSynBind _sig_fn bind@(PSB { psb_id = L _ name + , psb_args = details + , psb_def = pat + , psb_dir = dir }) -- invariant: no free vars here when it's a FunBind = do { pattern_synonym_ok <- xoptM Opt_PatternSynonyms ; unless pattern_synonym_ok (addErr patternSynonymErr) - ; ((pat', details'), fvs) <- rnPat PatSyn pat $ \pat' -> do + ; ((pat', details'), fvs1) <- rnPat PatSyn pat $ \pat' -> do -- We check the 'RdrName's instead of the 'Name's -- so that the binding locations are reported -- from the left-hand side @@ -539,23 +561,28 @@ rnBind _sig_fn bind@(PatSynBind { patsyn_id = L _ name -- ; checkPrecMatch -- TODO ; return (InfixPatSyn name1 name2, mkFVs (map unLoc [name1, name2])) } ; return ((pat', details'), fvs) } - ; dir' <- case dir of - Unidirectional -> return Unidirectional - ImplicitBidirectional -> return ImplicitBidirectional + ; (dir', fvs2) <- case dir of + Unidirectional -> return (Unidirectional, emptyFVs) + ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs) + ExplicitBidirectional mg -> + do { (mg', fvs) <- rnMatchGroup PatSyn rnLExpr mg + ; return (ExplicitBidirectional mg', fvs) } ; mod <- getModule - ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs + ; let fvs = fvs1 `plusFV` fvs2 + fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs -- Keep locally-defined Names -- As well as dependency analysis, we need these for the -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan - ; let bind' = bind{ patsyn_args = details' - , patsyn_def = pat' - , patsyn_dir = dir' - , bind_fvs = fvs' } + ; let bind' = bind{ psb_args = details' + , psb_def = pat' + , psb_dir = dir' + , psb_fvs = fvs' } ; fvs' `seq` -- See Note [Free-variable space leak] - return (bind', [name], fvs) + return (bind', [name], fvs1) + -- See Note [Pattern synonym wrappers don't yield dependencies] } where lookupVar = wrapLocM lookupOccRn @@ -565,20 +592,34 @@ rnBind _sig_fn bind@(PatSynBind { patsyn_id = L _ name = hang (ptext (sLit "Illegal pattern synonym declaration")) 2 (ptext (sLit "Use -XPatternSynonyms to enable this extension")) +{- +Note [Pattern synonym wrappers don't yield dependencies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -rnBind _ b = pprPanic "rnBind" (ppr b) +When renaming a pattern synonym that has an explicit wrapper, +references in the wrapper definition should not be used when +calculating dependencies. For example, consider the following pattern +synonym definition: -{- -Note [Free-variable space leak] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have - fvs' = trim fvs -and we seq fvs' before turning it as part of a record. +pattern P x <- C1 x where + P x = f (C1 x) + +f (P x) = C2 x + +In this case, 'P' needs to be typechecked in two passes: + +1. Typecheck the pattern definition of 'P', which fully determines the +type of 'P'. This step doesn't require knowing anything about 'f', +since the wrapper definition is not looked at. + +2. Typecheck the wrapper definition, which needs the typechecked +definition of 'f' to be in scope. + +This behaviour is implemented in 'tcValBinds', but it crucially +depends on 'P' not being put in a recursive group with 'f' (which +would make it look like a recursive pattern synonym a la 'pattern P = +P' which is unsound and rejected). -The reason is that trim is sometimes something like - \xs -> intersectNameSet (mkNameSet bound_names) xs -and we don't want to retain the list bound_names. This showed up in -trac ticket #1136. -} --------------------- diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 262fde8d7a..697303f276 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -40,6 +40,7 @@ import UniqSet import Data.List import Util import ListSetOps ( removeDups ) +import ErrUtils import Outputable import SrcLoc import FastString @@ -47,16 +48,6 @@ import Control.Monad import TysWiredIn ( nilDataConName ) \end{code} - -\begin{code} --- XXX -thenM :: Monad a => a b -> (b -> a c) -> a c -thenM = (>>=) - -thenM_ :: Monad a => a b -> a c -> a c -thenM_ = (>>) -\end{code} - %************************************************************************ %* * \subsubsection{Expressions} @@ -68,16 +59,13 @@ rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars) rnExprs ls = rnExprs' ls emptyUniqSet where rnExprs' [] acc = return ([], acc) - rnExprs' (expr:exprs) acc - = rnLExpr expr `thenM` \ (expr', fvExpr) -> - + rnExprs' (expr:exprs) acc = + do { (expr', fvExpr) <- rnLExpr expr -- 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 - in - acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) -> - return (expr':exprs', fvExprs) + ; let acc' = acc `plusFV` fvExpr + ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc' + ; return (expr':exprs', fvExprs) } \end{code} Variables. We look up the variable and return the resulting name. @@ -122,27 +110,25 @@ rnExpr (HsIPVar v) = return (HsIPVar v, emptyFVs) rnExpr (HsLit lit@(HsString s)) - = do { - opt_OverloadedStrings <- xoptM Opt_OverloadedStrings + = do { opt_OverloadedStrings <- xoptM Opt_OverloadedStrings ; if opt_OverloadedStrings then rnExpr (HsOverLit (mkHsIsString s placeHolderType)) - else -- Same as below - rnLit lit `thenM_` - return (HsLit lit, emptyFVs) - } + else do { + ; rnLit lit + ; return (HsLit lit, emptyFVs) } } rnExpr (HsLit lit) - = rnLit lit `thenM_` - return (HsLit lit, emptyFVs) + = do { rnLit lit + ; return (HsLit lit, emptyFVs) } rnExpr (HsOverLit lit) - = rnOverLit lit `thenM` \ (lit', fvs) -> - return (HsOverLit lit', fvs) + = do { (lit', fvs) <- rnOverLit lit + ; return (HsOverLit lit', fvs) } rnExpr (HsApp fun arg) - = rnLExpr fun `thenM` \ (fun',fvFun) -> - rnLExpr arg `thenM` \ (arg',fvArg) -> - return (HsApp fun' arg', fvFun `plusFV` fvArg) + = do { (fun',fvFun) <- rnLExpr fun + ; (arg',fvArg) <- rnLExpr arg + ; return (HsApp fun' arg', fvFun `plusFV` fvArg) } rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2) = do { (e1', fv_e1) <- rnLExpr e1 @@ -165,10 +151,10 @@ rnExpr (OpApp _ 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 -> - return (final_e, fv_e `plusFV` fv_neg) + = do { (e', fv_e) <- rnLExpr e + ; (neg_name, fv_neg) <- lookupSyntaxName negateName + ; final_e <- mkNegAppRn e' neg_name + ; return (final_e, fv_e `plusFV` fv_neg) } ------------------------------------------ -- Template Haskell extensions @@ -180,10 +166,10 @@ rnExpr (HsSpliceE is_typed splice) = rnSpliceExpr is_typed splice rnExpr (HsQuasiQuoteE qq) - = runQuasiQuoteExpr qq `thenM` \ lexpr' -> - -- Wrap the result of the quasi-quoter in parens so that we don't - -- lose the outermost location set by runQuasiQuote (#7918) - rnExpr (HsPar lexpr') + = do { lexpr' <- runQuasiQuoteExpr qq + -- Wrap the result of the quasi-quoter in parens so that we don't + -- lose the outermost location set by runQuasiQuote (#7918) + ; rnExpr (HsPar lexpr') } --------------------------------------------- -- Sections @@ -207,33 +193,33 @@ rnExpr expr@(SectionR {}) --------------------------------------------- rnExpr (HsCoreAnn ann expr) - = rnLExpr expr `thenM` \ (expr', fvs_expr) -> - return (HsCoreAnn ann expr', fvs_expr) + = do { (expr', fvs_expr) <- rnLExpr expr + ; return (HsCoreAnn ann expr', fvs_expr) } rnExpr (HsSCC lbl expr) - = rnLExpr expr `thenM` \ (expr', fvs_expr) -> - return (HsSCC lbl expr', fvs_expr) + = do { (expr', fvs_expr) <- rnLExpr expr + ; return (HsSCC lbl expr', fvs_expr) } rnExpr (HsTickPragma info expr) - = rnLExpr expr `thenM` \ (expr', fvs_expr) -> - return (HsTickPragma info expr', fvs_expr) + = do { (expr', fvs_expr) <- rnLExpr expr + ; return (HsTickPragma info expr', fvs_expr) } rnExpr (HsLam matches) - = rnMatchGroup LambdaExpr rnLExpr matches `thenM` \ (matches', fvMatch) -> - return (HsLam matches', fvMatch) + = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches + ; return (HsLam matches', fvMatch) } rnExpr (HsLamCase arg matches) - = rnMatchGroup CaseAlt rnLExpr matches `thenM` \ (matches', fvs_ms) -> - return (HsLamCase arg matches', fvs_ms) + = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches + ; return (HsLamCase arg matches', fvs_ms) } rnExpr (HsCase expr matches) - = rnLExpr expr `thenM` \ (new_expr, e_fvs) -> - rnMatchGroup CaseAlt rnLExpr matches `thenM` \ (new_matches, ms_fvs) -> - return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) + = do { (new_expr, e_fvs) <- rnLExpr expr + ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches + ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) } rnExpr (HsLet binds expr) - = rnLocalBindsAndThen binds $ \ binds' -> - rnLExpr expr `thenM` \ (expr',fvExpr) -> - return (HsLet binds' expr', fvExpr) + = rnLocalBindsAndThen binds $ \binds' -> do + { (expr',fvExpr) <- rnLExpr expr + ; return (HsLet binds' expr', fvExpr) } rnExpr (HsDo do_or_lc stmts _) = do { ((stmts', _), fvs) <- rnStmts do_or_lc rnLExpr stmts (\ _ -> return ((), emptyFVs)) @@ -250,8 +236,8 @@ rnExpr (ExplicitList _ _ exps) return (ExplicitList placeHolderType Nothing exps', fvs) } rnExpr (ExplicitPArr _ exps) - = rnExprs exps `thenM` \ (exps', fvs) -> - return (ExplicitPArr placeHolderType exps', fvs) + = do { (exps', fvs) <- rnExprs exps + ; return (ExplicitPArr placeHolderType exps', fvs) } rnExpr (ExplicitTuple tup_args boxity) = do { checkTupleSection tup_args @@ -292,8 +278,8 @@ rnExpr (HsMultiIf ty alts) ; return (HsMultiIf ty alts', fvs) } rnExpr (HsType a) - = rnLHsType HsTypeCtx a `thenM` \ (t, fvT) -> - return (HsType t, fvT) + = do { (t, fvT) <- rnLHsType HsTypeCtx a + ; return (HsType t, fvT) } rnExpr (ArithSeq _ _ seq) = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists @@ -306,8 +292,8 @@ rnExpr (ArithSeq _ _ seq) return (ArithSeq noPostTcExpr Nothing new_seq, fvs) } rnExpr (PArrSeq _ seq) - = rnArithSeq seq `thenM` \ (new_seq, fvs) -> - return (PArrSeq noPostTcExpr new_seq, fvs) + = do { (new_seq, fvs) <- rnArithSeq seq + ; return (PArrSeq noPostTcExpr new_seq, fvs) } \end{code} These three are pattern syntax appearing in expressions. @@ -334,9 +320,9 @@ rnExpr e@(ELazyPat {}) = patSynErr e \begin{code} rnExpr (HsProc pat body) = newArrowScope $ - rnPat ProcExpr pat $ \ pat' -> - rnCmdTop body `thenM` \ (body',fvBody) -> - return (HsProc pat' body', fvBody) + rnPat ProcExpr pat $ \ pat' -> do + { (body',fvBody) <- rnCmdTop body + ; return (HsProc pat' body', fvBody) } -- Ideally, these would be done in parsing, but to keep parsing simple, we do it here. rnExpr e@(HsArrApp {}) = arrowFail e @@ -404,9 +390,9 @@ rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd }) rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars) rnCmdArgs [] = return ([], emptyFVs) rnCmdArgs (arg:args) - = rnCmdTop arg `thenM` \ (arg',fvArg) -> - rnCmdArgs args `thenM` \ (args',fvArgs) -> - return (arg':args', fvArg `plusFV` fvArgs) + = do { (arg',fvArg) <- rnCmdTop arg + ; (args',fvArgs) <- rnCmdArgs args + ; return (arg':args', fvArg `plusFV` fvArgs) } rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars) rnCmdTop = wrapLocFstM rnCmdTop' @@ -427,10 +413,10 @@ rnLCmd = wrapLocFstM rnCmd rnCmd :: HsCmd RdrName -> RnM (HsCmd Name, FreeVars) rnCmd (HsCmdArrApp arrow arg _ ho rtl) - = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) -> - rnLExpr arg `thenM` \ (arg',fvArg) -> - return (HsCmdArrApp arrow' arg' placeHolderType ho rtl, - fvArrow `plusFV` fvArg) + = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow) + ; (arg',fvArg) <- rnLExpr arg + ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl, + fvArrow `plusFV` fvArg) } where select_arrow_scope tc = case ho of HsHigherOrderApp -> tc @@ -443,42 +429,37 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl) -- infix form rnCmd (HsCmdArrForm op (Just _) [arg1, arg2]) - = escapeArrowScope (rnLExpr op) - `thenM` \ (op',fv_op) -> - let L _ (HsVar op_name) = op' in - rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) -> - rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) -> - + = do { (op',fv_op) <- escapeArrowScope (rnLExpr op) + ; let L _ (HsVar op_name) = op' + ; (arg1',fv_arg1) <- rnCmdTop arg1 + ; (arg2',fv_arg2) <- rnCmdTop arg2 -- Deal with fixity - - lookupFixityRn op_name `thenM` \ fixity -> - mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e -> - - return (final_e, - fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) + ; fixity <- lookupFixityRn op_name + ; final_e <- mkOpFormRn arg1' op' fixity arg2' + ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) } rnCmd (HsCmdArrForm op fixity cmds) - = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) -> - rnCmdArgs cmds `thenM` \ (cmds',fvCmds) -> - return (HsCmdArrForm op' fixity cmds', fvOp `plusFV` fvCmds) + = do { (op',fvOp) <- escapeArrowScope (rnLExpr op) + ; (cmds',fvCmds) <- rnCmdArgs cmds + ; return (HsCmdArrForm op' fixity cmds', fvOp `plusFV` fvCmds) } rnCmd (HsCmdApp fun arg) - = rnLCmd fun `thenM` \ (fun',fvFun) -> - rnLExpr arg `thenM` \ (arg',fvArg) -> - return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) + = do { (fun',fvFun) <- rnLCmd fun + ; (arg',fvArg) <- rnLExpr arg + ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) } rnCmd (HsCmdLam matches) - = rnMatchGroup LambdaExpr rnLCmd matches `thenM` \ (matches', fvMatch) -> - return (HsCmdLam matches', fvMatch) + = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches + ; return (HsCmdLam matches', fvMatch) } rnCmd (HsCmdPar e) = do { (e', fvs_e) <- rnLCmd e ; return (HsCmdPar e', fvs_e) } rnCmd (HsCmdCase expr matches) - = rnLExpr expr `thenM` \ (new_expr, e_fvs) -> - rnMatchGroup CaseAlt rnLCmd matches `thenM` \ (new_matches, ms_fvs) -> - return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) + = do { (new_expr, e_fvs) <- rnLExpr expr + ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches + ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) } rnCmd (HsCmdIf _ p b1 b2) = do { (p', fvP) <- rnLExpr p @@ -488,9 +469,9 @@ rnCmd (HsCmdIf _ p b1 b2) ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } rnCmd (HsCmdLet binds cmd) - = rnLocalBindsAndThen binds $ \ binds' -> - rnLCmd cmd `thenM` \ (cmd',fvExpr) -> - return (HsCmdLet binds' cmd', fvExpr) + = rnLocalBindsAndThen binds $ \ binds' -> do + { (cmd',fvExpr) <- rnLCmd cmd + ; return (HsCmdLet binds' cmd', fvExpr) } rnCmd (HsCmdDo stmts _) = do { ((stmts', _), fvs) <- rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) @@ -580,25 +561,25 @@ methodNamesStmt (TransStmt {}) = emptyFVs \begin{code} rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars) rnArithSeq (From expr) - = rnLExpr expr `thenM` \ (expr', fvExpr) -> - return (From expr', fvExpr) + = do { (expr', fvExpr) <- rnLExpr expr + ; return (From expr', fvExpr) } rnArithSeq (FromThen expr1 expr2) - = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> - rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> - return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) + = do { (expr1', fvExpr1) <- rnLExpr expr1 + ; (expr2', fvExpr2) <- rnLExpr expr2 + ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) } rnArithSeq (FromTo expr1 expr2) - = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> - rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> - return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) + = do { (expr1', fvExpr1) <- rnLExpr expr1 + ; (expr2', fvExpr2) <- rnLExpr expr2 + ; 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) -> - return (FromThenTo expr1' expr2' expr3', - plusFVs [fvExpr1, fvExpr2, fvExpr3]) + = do { (expr1', fvExpr1) <- rnLExpr expr1 + ; (expr2', fvExpr2) <- rnLExpr expr2 + ; (expr3', fvExpr3) <- rnLExpr expr3 + ; return (FromThenTo expr1' expr2' expr3', + plusFVs [fvExpr1, fvExpr2, fvExpr3]) } \end{code} %************************************************************************ @@ -961,21 +942,19 @@ rn_rec_stmt rnBody _ (L loc (LastStmt body _)) _ 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) -> - return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, - L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] + = do { (body', fvs) <- rnBody body + ; (then_op, fvs1) <- lookupSyntaxName thenMName + ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, + 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) -> - let - 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))] + = do { (body', fv_expr) <- rnBody body + ; (bind_op, fvs1) <- lookupSyntaxName bindMName + ; (fail_op, fvs2) <- lookupSyntaxName failMName + ; let bndrs = mkNameSet (collectPatBinders pat') + fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 + ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, + L loc (BindStmt pat' body' bind_op fail_op))] } rn_rec_stmt _ _ (L _ (LetStmt binds@(HsIPBinds _))) _ = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds) @@ -1005,9 +984,9 @@ rn_rec_stmts :: Outputable (body RdrName) => -> [Name] -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)] -> RnM [Segment (LStmt Name (Located (body Name)))] -rn_rec_stmts rnBody bndrs stmts = - mapM (uncurry (rn_rec_stmt rnBody bndrs)) stmts `thenM` \ segs_s -> - return (concat segs_s) +rn_rec_stmts rnBody bndrs stmts + = do { segs_s <- mapM (uncurry (rn_rec_stmt rnBody bndrs)) stmts + ; return (concat segs_s) } --------------------------------------------- segmentRecStmts :: HsStmtContext Name @@ -1247,8 +1226,8 @@ checkStmt :: HsStmtContext Name checkStmt ctxt (L _ stmt) = do { dflags <- getDynFlags ; case okStmt dflags ctxt stmt of - Nothing -> return () - Just extra -> addErr (msg $$ extra) } + IsValid -> return () + NotValid extra -> addErr (msg $$ extra) } where msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement") , ptext (sLit "in") <+> pprAStmtContext ctxt ] @@ -1263,13 +1242,12 @@ pprStmtCat (RecStmt {}) = ptext (sLit "rec") pprStmtCat (ParStmt {}) = ptext (sLit "parallel") ------------ -isOK, notOK :: Maybe SDoc -isOK = Nothing -notOK = Just empty +emptyInvalid :: Validity -- Payload is the empty document +emptyInvalid = NotValid empty okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt :: DynFlags -> HsStmtContext Name - -> Stmt RdrName (Located (body RdrName)) -> Maybe SDoc + -> Stmt RdrName (Located (body RdrName)) -> Validity -- Return Nothing if OK, (Just extra) if not ok -- The "extra" is an SDoc that is appended to an generic error message @@ -1287,59 +1265,59 @@ okStmt dflags ctxt stmt TransStmtCtxt ctxt -> okStmt dflags ctxt stmt ------------- -okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Maybe SDoc +okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Validity okPatGuardStmt stmt = case stmt of - BodyStmt {} -> isOK - BindStmt {} -> isOK - LetStmt {} -> isOK - _ -> notOK + BodyStmt {} -> IsValid + BindStmt {} -> IsValid + LetStmt {} -> IsValid + _ -> emptyInvalid ------------- okParStmt dflags ctxt stmt = case stmt of - LetStmt (HsIPBinds {}) -> notOK + LetStmt (HsIPBinds {}) -> emptyInvalid _ -> okStmt dflags ctxt stmt ---------------- okDoStmt dflags ctxt stmt = case stmt of RecStmt {} - | Opt_RecursiveDo `xopt` dflags -> isOK - | ArrowExpr <- ctxt -> isOK -- Arrows allows 'rec' - | otherwise -> Just (ptext (sLit "Use RecursiveDo")) - BindStmt {} -> isOK - LetStmt {} -> isOK - BodyStmt {} -> isOK - _ -> notOK + | Opt_RecursiveDo `xopt` dflags -> IsValid + | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec' + | otherwise -> NotValid (ptext (sLit "Use RecursiveDo")) + BindStmt {} -> IsValid + LetStmt {} -> IsValid + BodyStmt {} -> IsValid + _ -> emptyInvalid ---------------- okCompStmt dflags _ stmt = case stmt of - BindStmt {} -> isOK - LetStmt {} -> isOK - BodyStmt {} -> isOK + BindStmt {} -> IsValid + LetStmt {} -> IsValid + BodyStmt {} -> IsValid ParStmt {} - | Opt_ParallelListComp `xopt` dflags -> isOK - | otherwise -> Just (ptext (sLit "Use ParallelListComp")) + | Opt_ParallelListComp `xopt` dflags -> IsValid + | otherwise -> NotValid (ptext (sLit "Use ParallelListComp")) TransStmt {} - | Opt_TransformListComp `xopt` dflags -> isOK - | otherwise -> Just (ptext (sLit "Use TransformListComp")) - RecStmt {} -> notOK - LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt) + | Opt_TransformListComp `xopt` dflags -> IsValid + | otherwise -> NotValid (ptext (sLit "Use TransformListComp")) + RecStmt {} -> emptyInvalid + LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) ---------------- okPArrStmt dflags _ stmt = case stmt of - BindStmt {} -> isOK - LetStmt {} -> isOK - BodyStmt {} -> isOK + BindStmt {} -> IsValid + LetStmt {} -> IsValid + BodyStmt {} -> IsValid ParStmt {} - | Opt_ParallelListComp `xopt` dflags -> isOK - | otherwise -> Just (ptext (sLit "Use ParallelListComp")) - TransStmt {} -> notOK - RecStmt {} -> notOK - LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt) + | Opt_ParallelListComp `xopt` dflags -> IsValid + | otherwise -> NotValid (ptext (sLit "Use ParallelListComp")) + TransStmt {} -> emptyInvalid + RecStmt {} -> emptyInvalid + LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) --------- checkTupleSection :: [HsTupArg RdrName] -> RnM () diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index db4258607a..5071828e4d 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -259,7 +259,7 @@ rnImportDecl this_mod imp_mod : dep_finsts deps | otherwise = dep_finsts deps - pkg = modulePackageId (mi_module iface) + pkg = modulePackageKey (mi_module iface) -- Does this import mean we now require our own pkg -- to be trusted? See Note [Trust Own Package] diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 2618792e82..a3bd38a3ec 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -384,8 +384,8 @@ rnHsForeignDecl (ForeignImport name ty _ spec) ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty -- Mark any PackageTarget style imports as coming from the current package - ; let packageId = thisPackage $ hsc_dflags topEnv - spec' = patchForeignImport packageId spec + ; let packageKey = thisPackage $ hsc_dflags topEnv + spec' = patchForeignImport packageKey spec ; return (ForeignImport name' ty' noForeignImportCoercionYet spec', fvs) } @@ -402,20 +402,20 @@ rnHsForeignDecl (ForeignExport name ty _ spec) -- package, so if they get inlined across a package boundry we'll still -- know where they're from. -- -patchForeignImport :: PackageId -> ForeignImport -> ForeignImport -patchForeignImport packageId (CImport cconv safety fs spec) - = CImport cconv safety fs (patchCImportSpec packageId spec) +patchForeignImport :: PackageKey -> ForeignImport -> ForeignImport +patchForeignImport packageKey (CImport cconv safety fs spec) + = CImport cconv safety fs (patchCImportSpec packageKey spec) -patchCImportSpec :: PackageId -> CImportSpec -> CImportSpec -patchCImportSpec packageId spec +patchCImportSpec :: PackageKey -> CImportSpec -> CImportSpec +patchCImportSpec packageKey spec = case spec of - CFunction callTarget -> CFunction $ patchCCallTarget packageId callTarget + CFunction callTarget -> CFunction $ patchCCallTarget packageKey callTarget _ -> spec -patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget -patchCCallTarget packageId callTarget = +patchCCallTarget :: PackageKey -> CCallTarget -> CCallTarget +patchCCallTarget packageKey callTarget = case callTarget of - StaticTarget label Nothing isFun -> StaticTarget label (Just packageId) isFun + StaticTarget label Nothing isFun -> StaticTarget label (Just packageKey) isFun _ -> callTarget @@ -445,12 +445,14 @@ rnSrcInstDecl (ClsInstD { cid_inst = cid }) rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars) rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds , cid_sigs = uprags, cid_tyfam_insts = ats + , cid_overlap_mode = oflag , cid_datafam_insts = adts }) -- Used for both source and interface file decls = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty ; case splitLHsInstDeclTy_maybe inst_ty' of { Nothing -> return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds , cid_sigs = [], cid_tyfam_insts = [] + , cid_overlap_mode = oflag , cid_datafam_insts = [] } , inst_fvs) ; Just (inst_tyvars, _, L _ cls,_) -> @@ -463,7 +465,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds ; traceRn (text "rnSrcInstDecl" <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names) ; ((ats', adts', other_sigs'), more_fvs) <- extendTyVarEnvFVRn ktv_names $ - do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats + do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls inst_tyvars adts ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs ; return ( (ats', adts', other_sigs') @@ -493,6 +495,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds `plusFV` inst_fvs ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds' , cid_sigs = uprags', cid_tyfam_insts = ats' + , cid_overlap_mode = oflag , cid_datafam_insts = adts' }, all_fvs) } } } -- We return the renamed associated data type declarations so @@ -561,14 +564,29 @@ rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn }) rnTyFamInstEqn :: Maybe (Name, [Name]) -> TyFamInstEqn RdrName -> RnM (TyFamInstEqn Name, FreeVars) -rnTyFamInstEqn mb_cls (TyFamInstEqn { tfie_tycon = tycon - , tfie_pats = HsWB { hswb_cts = pats } - , tfie_rhs = rhs }) +rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon + , tfe_pats = HsWB { hswb_cts = pats } + , tfe_rhs = rhs }) = do { (tycon', pats', rhs', fvs) <- rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn - ; return (TyFamInstEqn { tfie_tycon = tycon' - , tfie_pats = pats' - , tfie_rhs = rhs' }, fvs) } + ; return (TyFamEqn { tfe_tycon = tycon' + , tfe_pats = pats' + , tfe_rhs = rhs' }, fvs) } + +rnTyFamDefltEqn :: Name + -> TyFamDefltEqn RdrName + -> RnM (TyFamDefltEqn Name, FreeVars) +rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon + , tfe_pats = tyvars + , tfe_rhs = rhs }) + = bindHsTyVars ctx (Just cls) [] tyvars $ \ tyvars' -> + do { tycon' <- lookupFamInstName (Just cls) tycon + ; (rhs', fvs) <- rnLHsType ctx rhs + ; return (TyFamEqn { tfe_tycon = tycon' + , tfe_pats = tyvars' + , tfe_rhs = rhs' }, fvs) } + where + ctx = TyFamilyCtx tycon rnDataFamInstDecl :: Maybe (Name, [Name]) -> DataFamInstDecl RdrName @@ -587,7 +605,7 @@ rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon Renaming of the associated types in instances. \begin{code} --- rename associated type family decl in class +-- Rename associated type family decl in class rnATDecls :: Name -- Class -> [LFamilyDecl RdrName] -> RnM ([LFamilyDecl Name], FreeVars) @@ -637,11 +655,11 @@ extendTyVarEnvForMethodBinds ktv_names thing_inside \begin{code} rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars) -rnSrcDerivDecl (DerivDecl ty) +rnSrcDerivDecl (DerivDecl ty overlap) = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving ; unless standalone_deriv_ok (addErr standaloneDerivErr) ; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty - ; return (DerivDecl ty', fvs) } + ; return (DerivDecl ty' overlap, fvs) } standaloneDerivErr :: SDoc standaloneDerivErr @@ -865,10 +883,10 @@ packages, it is safe not to add the dependencies on the .hs-boot stuff to B2. See also Note [Grouping of type and class declarations] in TcTyClsDecls. \begin{code} -isInPackage :: PackageId -> Name -> Bool +isInPackage :: PackageKey -> Name -> Bool isInPackage pkgId nm = case nameModule_maybe nm of Nothing -> False - Just m -> pkgId == modulePackageId m + Just m -> pkgId == modulePackageKey m -- We use nameModule_maybe because we might be in a TH splice, in which case -- there is no module name. In that case we cannot have mutual dependencies, -- so it's fine to return False here. @@ -938,7 +956,7 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs }) do { (rhs', fvs) <- rnTySyn doc rhs ; return ((tyvars', rhs'), fvs) } ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars' - , tcdRhs = rhs', tcdFVs = fvs }, fvs) } + , tcdRhs = rhs', tcdFVs = fvs }, fvs) } -- "data", "newtype" declarations -- both top level and (for an associated type) in an instance decl @@ -963,20 +981,20 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls, -- kind signatures on the tyvars -- Tyvars scope over superclass context and method signatures - ; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs) + ; ((tyvars', context', fds', ats', sigs'), stuff_fvs) <- bindHsTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do -- Checks for distinct tyvars { (context', cxt_fvs) <- rnContext cls_doc context - ; fds' <- rnFds (docOfHsDocContext cls_doc) fds + ; fds' <- rnFds fds -- The fundeps have no free variables ; (ats', fv_ats) <- rnATDecls cls' ats - ; (at_defs', fv_at_defs) <- rnATInstDecls rnTyFamInstDecl cls' tyvars' at_defs ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs ; let fvs = cxt_fvs `plusFV` sig_fvs `plusFV` - fv_ats `plusFV` - fv_at_defs - ; return ((tyvars', context', fds', ats', at_defs', sigs'), fvs) } + fv_ats + ; return ((tyvars', context', fds', ats', sigs'), fvs) } + + ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs -- No need to check for duplicate associated type decls -- since that is done by RnNames.extendGlobalRdrEnvRn @@ -1008,7 +1026,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls, -- Haddock docs ; docs' <- mapM (wrapLocM rnDocDecl) docs - ; let all_fvs = meth_fvs `plusFV` stuff_fvs + ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', @@ -1406,21 +1424,20 @@ extendRecordFieldEnv tycl_decls inst_decls %********************************************************* \begin{code} -rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)] - -rnFds doc fds +rnFds :: [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)] +rnFds fds = mapM (wrapLocM rn_fds) fds where rn_fds (tys1, tys2) - = do { tys1' <- rnHsTyVars doc tys1 - ; tys2' <- rnHsTyVars doc tys2 + = do { tys1' <- rnHsTyVars tys1 + ; tys2' <- rnHsTyVars tys2 ; return (tys1', tys2') } -rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name] -rnHsTyVars doc tvs = mapM (rnHsTyVar doc) tvs +rnHsTyVars :: [RdrName] -> RnM [Name] +rnHsTyVars tvs = mapM rnHsTyVar tvs -rnHsTyVar :: SDoc -> RdrName -> RnM Name -rnHsTyVar _doc tyvar = lookupOccRn tyvar +rnHsTyVar :: RdrName -> RnM Name +rnHsTyVar tyvar = lookupOccRn tyvar \end{code} diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index 2cf886c5c6..f00768a9f5 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -26,16 +26,17 @@ module FloatIn ( floatInwards ) where import CoreSyn import MkCore -import CoreUtils ( exprIsDupable, exprIsExpandable, exprOkForSideEffects ) +import CoreUtils ( exprIsDupable, exprIsExpandable, exprType, exprOkForSideEffects ) import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars ) import Id ( isOneShotBndr, idType ) import Var -import Type ( isUnLiftedType ) +import Type ( Type, isUnLiftedType, splitFunTy, applyTy ) import VarSet import Util import UniqFM import DynFlags import Outputable +import Data.List( mapAccumL ) \end{code} Top-level interface function, @floatInwards@. Note that we do not @@ -155,18 +156,42 @@ need to get at all the arguments. The next simplifier run will pull out any silly ones. \begin{code} -fiExpr dflags to_drop (_,AnnApp fun arg@(arg_fvs, ann_arg)) - | noFloatIntoRhs ann_arg = wrapFloats drop_here $ wrapFloats arg_drop $ - App (fiExpr dflags fun_drop fun) (fiExpr dflags [] arg) - -- It's inconvenient to test for an unlifted arg here, - -- and it really doesn't matter if we float into one - | otherwise = wrapFloats drop_here $ - App (fiExpr dflags fun_drop fun) (fiExpr dflags arg_drop arg) +fiExpr dflags to_drop ann_expr@(_,AnnApp {}) + = wrapFloats drop_here $ wrapFloats extra_drop $ + mkApps (fiExpr dflags fun_drop ann_fun) + (zipWith (fiExpr dflags) arg_drops ann_args) where - [drop_here, fun_drop, arg_drop] - = sepBindsByDropPoint dflags False [freeVarsOf fun, arg_fvs] to_drop + (ann_fun@(fun_fvs, _), ann_args) = collectAnnArgs ann_expr + fun_ty = exprType (deAnnotate ann_fun) + ((_,extra_fvs), arg_fvs) = mapAccumL mk_arg_fvs (fun_ty, emptyVarSet) ann_args + + -- All this faffing about is so that we can get hold of + -- the types of the arguments, to pass to noFloatIntoRhs + mk_arg_fvs :: (Type, FreeVarSet) -> CoreExprWithFVs -> ((Type, FreeVarSet), FreeVarSet) + mk_arg_fvs (fun_ty, extra_fvs) (_, AnnType ty) + = ((applyTy fun_ty ty, extra_fvs), emptyVarSet) + + mk_arg_fvs (fun_ty, extra_fvs) (arg_fvs, ann_arg) + | noFloatIntoRhs ann_arg arg_ty + = ((res_ty, extra_fvs `unionVarSet` arg_fvs), emptyVarSet) + | otherwise + = ((res_ty, extra_fvs), arg_fvs) + where + (arg_ty, res_ty) = splitFunTy fun_ty + + drop_here : extra_drop : fun_drop : arg_drops + = sepBindsByDropPoint dflags False (extra_fvs : fun_fvs : arg_fvs) to_drop \end{code} +Note [Do not destroy the let/app invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Watch out for + f (x +# y) +We don't want to float bindings into here + f (case ... of { x -> x +# y }) +because that might destroy the let/app invariant, which requires +unlifted function arguments to be ok-for-speculation. + Note [Floating in past a lambda group] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * We must be careful about floating inside inside a value lambda. @@ -275,8 +300,8 @@ arrange to dump bindings that bind extra_fvs before the entire let. Note [extra_fvs (2): free variables of rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - let x{rule mentioning y} = rhs in body +Consider + let x{rule mentioning y} = rhs in body Here y is not free in rhs or body; but we still want to dump bindings that bind y outside the let. So we augment extra_fvs with the idRuleAndUnfoldingVars of x. No need for type variables, hence not using @@ -288,11 +313,11 @@ fiExpr dflags to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) = fiExpr dflags new_to_drop body where body_fvs = freeVarsOf body `delVarSet` id + rhs_ty = idType id rule_fvs = idRuleAndUnfoldingVars id -- See Note [extra_fvs (2): free variables of rules] - extra_fvs | noFloatIntoRhs ann_rhs - || isUnLiftedType (idType id) = rule_fvs `unionVarSet` rhs_fvs - | otherwise = rule_fvs + extra_fvs | noFloatIntoRhs ann_rhs rhs_ty = rule_fvs `unionVarSet` rhs_fvs + | otherwise = rule_fvs -- See Note [extra_fvs (1): avoid floating into RHS] -- No point in floating in only to float straight out again -- Ditto ok-for-speculation unlifted RHSs @@ -322,7 +347,7 @@ fiExpr dflags to_drop (_,AnnLet (AnnRec bindings) body) rule_fvs = foldr (unionVarSet . idRuleAndUnfoldingVars) emptyVarSet ids extra_fvs = rule_fvs `unionVarSet` unionVarSets [ fvs | (fvs, rhs) <- rhss - , noFloatIntoRhs rhs ] + , noFloatIntoExpr rhs ] (shared_binds:extra_binds:body_binds:rhss_binds) = sepBindsByDropPoint dflags False (extra_fvs:body_fvs:rhss_fvs) to_drop @@ -364,6 +389,7 @@ floating in cases with a single alternative that may bind values. fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) | isUnLiftedType (idType case_bndr) , exprOkForSideEffects (deAnnotate scrut) + -- See PrimOp, Note [PrimOp can_fail and has_side_effects] = wrapFloats shared_binds $ fiExpr dflags (case_float : rhs_binds) rhs where @@ -403,8 +429,15 @@ okToFloatInside bndrs = all ok bndrs ok b = not (isId b) || isOneShotBndr b -- Push the floats inside there are no non-one-shot value binders -noFloatIntoRhs :: AnnExpr' Var (UniqFM Var) -> Bool -noFloatIntoRhs (AnnLam bndr e) +noFloatIntoRhs :: AnnExpr' Var (UniqFM Var) -> Type -> Bool +-- ^ True if it's a bad idea to float bindings into this RHS +-- Preconditio: rhs :: rhs_ty +noFloatIntoRhs rhs rhs_ty + = isUnLiftedType rhs_ty -- See Note [Do not destroy the let/app invariant] + || noFloatIntoExpr rhs + +noFloatIntoExpr :: AnnExpr' Var (UniqFM Var) -> Bool +noFloatIntoExpr (AnnLam bndr e) = not (okToFloatInside (bndr:bndrs)) -- NB: Must line up with fiExpr (AnnLam...); see Trac #7088 where @@ -418,7 +451,7 @@ noFloatIntoRhs (AnnLam bndr e) -- boxing constructor into it, else we box it every time which is very bad -- news indeed. -noFloatIntoRhs rhs = exprIsExpandable (deAnnotate' rhs) +noFloatIntoExpr rhs = exprIsExpandable (deAnnotate' rhs) -- We'd just float right back out again... -- Should match the test in SimplEnv.doFloatFromRhs \end{code} diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs index dbab552431..37d6dc8568 100644 --- a/compiler/simplCore/FloatOut.lhs +++ b/compiler/simplCore/FloatOut.lhs @@ -458,11 +458,6 @@ data FloatBinds = FB !(Bag FloatLet) -- Destined for top level !MajorEnv -- Levels other than top -- See Note [Representation of FloatBinds] -instance Outputable FloatBind where - ppr (FloatLet b) = ptext (sLit "LET") <+> ppr b - ppr (FloatCase e b c bs) = hang (ptext (sLit "CASE") <+> ppr e <+> ptext (sLit "of") <+> ppr b) - 2 (ppr c <+> ppr bs) - instance Outputable FloatBinds where ppr (FB fbs defs) = ptext (sLit "FB") <+> (braces $ vcat diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 1c5ebc501b..d8aec03b03 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -31,8 +31,8 @@ module SimplEnv ( -- Floats Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats, - wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats, - doFloatFromRhs, getFloatBinds, getFloats, mapFloats + wrapFloats, setFloats, zapFloats, addRecFloats, + doFloatFromRhs, getFloatBinds ) where #include "HsVersions.h" @@ -47,7 +47,7 @@ import VarEnv import VarSet import OrdList import Id -import MkCore +import MkCore ( mkWildValBinder ) import TysWiredIn import qualified CoreSubst import qualified Type @@ -344,15 +344,21 @@ Note [Simplifier floats] ~~~~~~~~~~~~~~~~~~~~~~~~~ The Floats is a bunch of bindings, classified by a FloatFlag. +* All of them satisfy the let/app invariant + +Examples + NonRec x (y:ys) FltLifted Rec [(x,rhs)] FltLifted + NonRec x* (p:q) FltOKSpec -- RHS is WHNF. Question: why not FltLifted? NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n - NonRec x# (a /# b) FltCareful NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge - NonRec x# (f y) FltCareful -- Unboxed binding: might fail or diverge - -- (where f :: Int -> Int#) + +Can't happen: + NonRec x# (a /# b) -- Might fail; does not satisfy let/app + NonRec x# (f y) -- Might diverge; does not satisfy let/app \begin{code} data Floats = Floats (OrdList OutBind) FloatFlag @@ -388,13 +394,6 @@ andFF FltOkSpec FltCareful = FltCareful andFF FltOkSpec _ = FltOkSpec andFF FltLifted flt = flt -classifyFF :: CoreBind -> FloatFlag -classifyFF (Rec _) = FltLifted -classifyFF (NonRec bndr rhs) - | not (isStrictId bndr) = FltLifted - | exprOkForSpeculation rhs = FltOkSpec - | otherwise = FltCareful - doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool -- If you change this function look also at FloatIn.noFloatFromRhs doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff}) @@ -423,8 +422,16 @@ emptyFloats :: Floats emptyFloats = Floats nilOL FltLifted unitFloat :: OutBind -> Floats --- A single-binding float -unitFloat bind = Floats (unitOL bind) (classifyFF bind) +-- This key function constructs a singleton float with the right form +unitFloat bind = Floats (unitOL bind) (flag bind) + where + flag (Rec {}) = FltLifted + flag (NonRec bndr rhs) + | not (isStrictId bndr) = FltLifted + | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) + | otherwise = ASSERT2( not (isUnLiftedType (idType bndr)), ppr bndr ) + FltCareful + -- Unlifted binders can only be let-bound if exprOkForSpeculation holds addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv -- Add a non-recursive binding and extend the in-scope set @@ -437,13 +444,6 @@ addNonRec env id rhs env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs), seInScope = extendInScopeSet (seInScope env) id } -mapFloats :: SimplEnv -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> SimplEnv -mapFloats env@SimplEnv { seFloats = Floats fs ff } fun - = env { seFloats = Floats (mapOL app fs) ff } - where - app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e' - app (Rec bs) = Rec (map fun bs) - extendFloats :: SimplEnv -> OutBind -> SimplEnv -- Add these bindings to the floats, and extend the in-scope env too extendFloats env bind @@ -477,31 +477,30 @@ addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff}) env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))} wrapFloats :: SimplEnv -> OutExpr -> OutExpr -wrapFloats env expr = wrapFlts (seFloats env) expr - -wrapFlts :: Floats -> OutExpr -> OutExpr --- Wrap the floats around the expression, using case-binding where necessary -wrapFlts (Floats bs _) body = foldrOL wrap body bs - where - wrap (Rec prs) body = Let (Rec prs) body - wrap (NonRec b r) body = bindNonRec b r body +-- Wrap the floats around the expression; they should all +-- satisfy the let/app invariant, so mkLets should do the job just fine +wrapFloats (SimplEnv {seFloats = Floats bs _}) body + = foldrOL Let body bs getFloatBinds :: SimplEnv -> [CoreBind] -getFloatBinds env = floatBinds (seFloats env) - -getFloats :: SimplEnv -> Floats -getFloats env = seFloats env +getFloatBinds (SimplEnv {seFloats = Floats bs _}) + = fromOL bs isEmptyFloats :: SimplEnv -> Bool -isEmptyFloats env = isEmptyFlts (seFloats env) - -isEmptyFlts :: Floats -> Bool -isEmptyFlts (Floats bs _) = isNilOL bs - -floatBinds :: Floats -> [OutBind] -floatBinds (Floats bs _) = fromOL bs +isEmptyFloats (SimplEnv {seFloats = Floats bs _}) + = isNilOL bs \end{code} +-- mapFloats commented out: used only in a commented-out bit of Simplify, +-- concerning ticks +-- +-- mapFloats :: SimplEnv -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> SimplEnv +-- mapFloats env@SimplEnv { seFloats = Floats fs ff } fun +-- = env { seFloats = Floats (mapOL app fs) ff } +-- where +-- app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e' +-- app (Rec bs) = Rec (map fun bs) + %************************************************************************ %* * diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 14789c44a4..888c923254 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -854,6 +854,10 @@ the former. \begin{code} preInlineUnconditionally :: DynFlags -> SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool +-- Precondition: rhs satisfies the let/app invariant +-- See Note [CoreSyn let/app invariant] in CoreSyn +-- Reason: we don't want to inline single uses, or discard dead bindings, +-- for unlifted, side-effect-full bindings preInlineUnconditionally dflags env top_lvl bndr rhs | not active = False | isStableUnfolding (idUnfolding bndr) = False -- Note [InlineRule and preInlineUnconditionally] @@ -963,6 +967,10 @@ postInlineUnconditionally -> OutExpr -> Unfolding -> Bool +-- Precondition: rhs satisfies the let/app invariant +-- See Note [CoreSyn let/app invariant] in CoreSyn +-- Reason: we don't want to inline single uses, or discard dead bindings, +-- for unlifted, side-effect-full bindings postInlineUnconditionally dflags env top_lvl bndr occ_info rhs unfolding | not active = False | isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 1125c2e883..cc214f7513 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -326,7 +326,7 @@ simplLazyBind :: SimplEnv -- The OutId has IdInfo, except arity, unfolding -> InExpr -> SimplEnv -- The RHS and its environment -> SimplM SimplEnv - +-- Precondition: rhs obeys the let/app invariant simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ do { let rhs_env = rhs_se `setInScope` env @@ -378,11 +378,12 @@ simplNonRecX :: SimplEnv -> InId -- Old binder -> OutExpr -- Simplified RHS -> SimplM SimplEnv - +-- Precondition: rhs satisfies the let/app invariant simplNonRecX env bndr new_rhs | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } - = return env -- Here c is dead, and we avoid creating - -- the binding c = (a,b) + = return env -- Here c is dead, and we avoid creating + -- the binding c = (a,b) + | Coercion co <- new_rhs = return (extendCvSubst env bndr co) @@ -397,6 +398,8 @@ completeNonRecX :: TopLevelFlag -> SimplEnv -> OutId -- New binder -> OutExpr -- Simplified RHS -> SimplM SimplEnv +-- Precondition: rhs satisfies the let/app invariant +-- See Note [CoreSyn let/app invariant] in CoreSyn completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs = do { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs @@ -644,7 +647,8 @@ completeBind :: SimplEnv -- completeBind may choose to do its work -- * by extending the substitution (e.g. let x = y in ...) -- * or by adding to the floats in the envt - +-- +-- Precondition: rhs obeys the let/app invariant completeBind env top_lvl old_bndr new_bndr new_rhs | isCoVar old_bndr = case new_rhs of @@ -1177,6 +1181,8 @@ rebuild env expr cont Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr + -- expr satisfies let/app since it started life + -- in a call to simplNonRecE ; simplLam env' bs body cont } ApplyTo dup_flag arg se cont -- See Note [Avoid redundant simplification] | isSimplified dup_flag -> rebuild env (App expr arg) cont @@ -1327,6 +1333,9 @@ simplNonRecE :: SimplEnv -- It deals with strict bindings, via the StrictBind continuation, -- which may abort the whole process -- +-- Precondition: rhs satisfies the let/app invariant +-- Note [CoreSyn let/app invariant] in CoreSyn +-- -- The "body" of the binding comes as a pair of ([InId],InExpr) -- representing a lambda; so we recurse back to simplLam -- Why? Because of the binder-occ-info-zapping done before @@ -1342,22 +1351,21 @@ simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont = do dflags <- getDynFlags case () of - _ - | preInlineUnconditionally dflags env NotTopLevel bndr rhs -> - do { tick (PreInlineUnconditionally bndr) - ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ + _ | preInlineUnconditionally dflags env NotTopLevel bndr rhs + -> do { tick (PreInlineUnconditionally bndr) + ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont } - | isStrictId bndr -> -- Includes coercions - do { simplExprF (rhs_se `setFloats` env) rhs - (StrictBind bndr bndrs body env cont) } + | isStrictId bndr -- Includes coercions + -> simplExprF (rhs_se `setFloats` env) rhs + (StrictBind bndr bndrs body env cont) - | otherwise -> - ASSERT( not (isTyVar bndr) ) - do { (env1, bndr1) <- simplNonRecBndr env bndr - ; let (env2, bndr2) = addBndrRules env1 bndr bndr1 - ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se - ; simplLam env3 bndrs body cont } + | otherwise + -> ASSERT( not (isTyVar bndr) ) + do { (env1, bndr1) <- simplNonRecBndr env bndr + ; let (env2, bndr2) = addBndrRules env1 bndr bndr1 + ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se + ; simplLam env3 bndrs body cont } \end{code} %************************************************************************ @@ -1717,7 +1725,13 @@ transformation: or (b) 'x' is not used at all and e is ok-for-speculation The ok-for-spec bit checks that we don't lose any - exceptions or divergence + exceptions or divergence. + + NB: it'd be *sound* to switch from case to let if the + scrutinee was not yet WHNF but was guaranteed to + converge; but sticking with case means we won't build a + thunk + or (c) 'x' is used strictly in the body, and 'e' is a variable Then we can just substitute 'e' for 'x' in the body. @@ -1863,6 +1877,8 @@ rebuildCase env scrut case_bndr alts cont where simple_rhs bs rhs = ASSERT( null bs ) do { env' <- simplNonRecX env case_bndr scrut + -- scrut is a constructor application, + -- hence satisfies let/app invariant ; simplExprF env' rhs cont } @@ -1870,56 +1886,41 @@ rebuildCase env scrut case_bndr alts cont -- 2. Eliminate the case if scrutinee is evaluated -------------------------------------------------- -rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont +rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont -- See if we can get rid of the case altogether -- See Note [Case elimination] -- mkCase made sure that if all the alternatives are equal, -- then there is now only one (DEFAULT) rhs - | all isDeadBinder bndrs -- bndrs are [InId] - - , if isUnLiftedType (idType case_bndr) - then elim_unlifted -- Satisfy the let-binding invariant - else elim_lifted - = do { -- pprTrace "case elim" (vcat [ppr case_bndr, ppr (exprIsHNF scrut), - -- ppr ok_for_spec, - -- ppr scrut]) $ - tick (CaseElim case_bndr) - ; env' <- simplNonRecX env case_bndr scrut - -- If case_bndr is dead, simplNonRecX will discard - ; simplExprF env' rhs cont } - where - elim_lifted -- See Note [Case elimination: lifted case] - = exprIsHNF scrut - || (is_plain_seq && ok_for_spec) - -- Note: not the same as exprIsHNF - || (strict_case_bndr && scrut_is_var scrut) - -- See Note [Eliminating redundant seqs] - - elim_unlifted - | is_plain_seq = exprOkForSideEffects scrut - -- The entire case is dead, so we can drop it, - -- _unless_ the scrutinee has side effects - | otherwise = ok_for_spec - -- The case-binder is alive, but we may be able - -- turn the case into a let, if the expression is ok-for-spec - -- See Note [Case elimination: unlifted case] - ok_for_spec = exprOkForSpeculation scrut - is_plain_seq = isDeadBinder case_bndr -- Evaluation *only* for effect - strict_case_bndr = isStrictDmd (idDemandInfo case_bndr) - - scrut_is_var :: CoreExpr -> Bool - scrut_is_var (Cast s _) = scrut_is_var s - scrut_is_var (Var _) = True - scrut_is_var _ = False - - --------------------------------------------------- --- 3. Try seq rules; see Note [User-defined RULES for seq] in MkId --------------------------------------------------- - -rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont - | all isDeadBinder (case_bndr : bndrs) -- So this is just 'seq' + -- 2a. Dropping the case altogether, if + -- a) it binds nothing (so it's really just a 'seq') + -- b) evaluating the scrutinee has no side effects + | is_plain_seq + , exprOkForSideEffects scrut + -- The entire case is dead, so we can drop it + -- if the scrutinee converges without having imperative + -- side effects or raising a Haskell exception + -- See Note [PrimOp can_fail and has_side_effects] in PrimOp + = simplExprF env rhs cont + + -- 2b. Turn the case into a let, if + -- a) it binds only the case-binder + -- b) unlifted case: the scrutinee is ok-for-speculation + -- lifted case: the scrutinee is in HNF (or will later be demanded) + | all_dead_bndrs + , if is_unlifted + then exprOkForSpeculation scrut -- See Note [Case elimination: unlifted case] + else exprIsHNF scrut -- See Note [Case elimination: lifted case] + || scrut_is_demanded_var scrut + = do { tick (CaseElim case_bndr) + ; env' <- simplNonRecX env case_bndr scrut + ; simplExprF env' rhs cont } + + -- 2c. Try the seq rules if + -- a) it binds only the case binder + -- b) a rule for seq applies + -- See Note [User-defined RULES for seq] in MkId + | is_plain_seq = do { let rhs' = substExpr (text "rebuild-case") env rhs env' = zapSubstEnv env out_args = [Type (substTy env (idType case_bndr)), @@ -1931,6 +1932,17 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont ; case mb_rule of Just (rule_rhs, cont') -> simplExprF env' rule_rhs cont' Nothing -> reallyRebuildCase env scrut case_bndr alts cont } + where + is_unlifted = isUnLiftedType (idType case_bndr) + all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] + is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect + + scrut_is_demanded_var :: CoreExpr -> Bool + -- See Note [Eliminating redundant seqs] + scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s + scrut_is_demanded_var (Var _) = isStrictDmd (idDemandInfo case_bndr) + scrut_is_demanded_var _ = False + rebuildCase env scrut case_bndr alts cont = reallyRebuildCase env scrut case_bndr alts cont @@ -2267,7 +2279,7 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont -- it via postInlineUnconditionally. -- Nevertheless we must keep it if the case-binder is alive, -- because it may be used in the con_app. See Note [knownCon occ info] - ; env'' <- simplNonRecX env' b' arg + ; env'' <- simplNonRecX env' b' arg -- arg satisfies let/app invariant ; bind_args env'' bs' args } bind_args _ _ _ = diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index f240be4cd7..a3b7c0b72a 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -115,7 +115,7 @@ dmdAnalStar :: AnalEnv -> Demand -- This one takes a *Demand* -> CoreExpr -> (BothDmdArg, CoreExpr) dmdAnalStar env dmd e - | (cd, defer_and_use) <- toCleanDmd dmd + | (cd, defer_and_use) <- toCleanDmd dmd (exprType e) , (dmd_ty, e') <- dmdAnal env cd e = (postProcessDmdTypeM defer_and_use dmd_ty, e') diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 4d5eeeacf7..d0b2d0da5a 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -217,9 +217,12 @@ tcLookupFamInst tycon tys | 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" $ + vcat [ ppr tycon <+> ppr tys + , pprTvBndrs (varSetElems (tyVarsOfTypes tys)) + , ppr mb_match + -- , ppr instEnv + ] ; case mb_match of [] -> return Nothing (match:_) @@ -297,8 +300,11 @@ 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) + ; traceTc "checkForConflicts" $ + vcat [ ppr (map fim_instance conflicts) + , ppr fam_inst + -- , ppr inst_envs + ] ; unless no_conflicts $ conflictInstErr fam_inst conflicts ; return no_conflicts } diff --git a/compiler/typecheck/FunDeps.lhs b/compiler/typecheck/FunDeps.lhs index e5cd356712..5cfd22664a 100644 --- a/compiler/typecheck/FunDeps.lhs +++ b/compiler/typecheck/FunDeps.lhs @@ -28,8 +28,8 @@ import Unify import InstEnv import VarSet import VarEnv -import Maybes( firstJusts ) import Outputable +import ErrUtils( Validity(..), allValid ) import Util import FastString @@ -417,7 +417,7 @@ makes instance inference go into a loop, because it requires the constraint \begin{code} checkInstCoverage :: Bool -- Be liberal -> Class -> [PredType] -> [Type] - -> Maybe SDoc + -> Validity -- "be_liberal" flag says whether to use "liberal" coverage of -- See Note [Coverage Condition] below -- @@ -426,14 +426,14 @@ checkInstCoverage :: Bool -- Be liberal -- Just msg => coverage problem described by msg checkInstCoverage be_liberal clas theta inst_taus - = firstJusts (map fundep_ok fds) + = allValid (map fundep_ok fds) where (tyvars, fds) = classTvsFds clas fundep_ok fd | if be_liberal then liberal_ok else conservative_ok - = Nothing + = IsValid | otherwise - = Just msg + = NotValid msg where (ls,rs) = instFD fd tyvars inst_taus ls_tvs = closeOverKinds (tyVarsOfTypes ls) -- See Note [Closing over kinds in coverage] diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 2bcf981e06..a27c0bd0f6 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -49,7 +49,6 @@ import TcMType import Type import Coercion ( Role(..) ) import TcType -import Unify import HscTypes import Id import Name @@ -60,9 +59,9 @@ import PrelNames import SrcLoc import DynFlags import Bag -import Maybes import Util import Outputable +import Control.Monad( unless ) import Data.List( mapAccumL ) \end{code} @@ -383,14 +382,15 @@ syntaxNameCtxt name orig ty tidy_env \begin{code} getOverlapFlag :: TcM OverlapFlag -getOverlapFlag +getOverlapFlag = do { dflags <- getDynFlags ; let overlap_ok = xopt Opt_OverlappingInstances dflags incoherent_ok = xopt Opt_IncoherentInstances dflags - safeOverlap = safeLanguageOn dflags - overlap_flag | incoherent_ok = Incoherent safeOverlap - | overlap_ok = OverlapOk safeOverlap - | otherwise = NoOverlap safeOverlap + use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags + , overlapMode = x } + overlap_flag | incoherent_ok = use Incoherent + | overlap_ok = use Overlaps + | otherwise = use NoOverlap ; return overlap_flag } @@ -409,22 +409,24 @@ tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a tcExtendLocalInstEnv dfuns thing_inside = do { traceDFuns dfuns ; env <- getGblEnv - ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns - ; let env' = env { tcg_insts = dfuns ++ tcg_insts env, - tcg_inst_env = inst_env' } + ; (inst_env', cls_insts') <- foldlM addLocalInst + (tcg_inst_env env, tcg_insts env) + dfuns + ; let env' = env { tcg_insts = cls_insts' + , tcg_inst_env = inst_env' } ; setGblEnv env' thing_inside } -addLocalInst :: InstEnv -> ClsInst -> TcM InstEnv --- Check that the proposed new instance is OK, +addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst]) +-- Check that the proposed new instance is OK, -- and then add it to the home inst env -- If overwrite_inst, then we can overwrite a direct match -addLocalInst home_ie ispec +addLocalInst (home_ie, my_insts) ispec = do { -- Instantiate the dfun type so that we extend the instance -- envt with completely fresh template variables -- This is important because the template variables must -- not overlap with anything in the things being looked up - -- (since we do unification). + -- (since we do unification). -- -- We use tcInstSkolType because we don't want to allocate fresh -- *meta* type variables. @@ -437,9 +439,23 @@ addLocalInst home_ie ispec -- Load imported instances, so that we report -- duplicates correctly - eps <- getEps - ; let inst_envs = (eps_inst_env eps, home_ie) - (tvs, cls, tys) = instanceHead ispec + + -- 'matches' are existing instance declarations that are less + -- specific than the new one + -- 'dups' are those 'matches' that are equal to the new one + ; isGHCi <- getIsGHCi + ; eps <- getEps + ; let (home_ie', my_insts') + | isGHCi = ( deleteFromInstEnv home_ie ispec + , filterOut (identicalInstHead ispec) my_insts) + | otherwise = (home_ie, my_insts) + -- If there is a home-package duplicate instance, + -- silently delete it + + (_tvs, cls, tys) = instanceHead ispec + inst_envs = (eps_inst_env eps, home_ie') + (matches, _, _) = lookupInstEnv inst_envs cls tys + dups = filter (identicalInstHead ispec) (map fst matches) -- Check functional dependencies ; case checkFunDeps inst_envs ispec of @@ -447,31 +463,10 @@ addLocalInst home_ie ispec Nothing -> return () -- Check for duplicate instance decls - ; let (matches, unifs, _) = lookupInstEnv inst_envs cls tys - dup_ispecs = [ dup_ispec - | (dup_ispec, _) <- matches - , let dup_tys = is_tys dup_ispec - , isJust (tcMatchTys (mkVarSet tvs) tys dup_tys)] - - -- Find memebers of the match list which ispec itself matches. - -- If the match is 2-way, it's a duplicate - -- If it's a duplicate, but we can overwrite home package dups, then overwrite - ; isGHCi <- getIsGHCi - ; overlapFlag <- getOverlapFlag - ; case isGHCi of - False -> case dup_ispecs of - dup : _ -> dupInstErr ispec dup >> return (extendInstEnv home_ie ispec) - [] -> return (extendInstEnv home_ie ispec) - True -> case (dup_ispecs, home_ie_matches, unifs, overlapFlag) of - (_, _:_, _, _) -> return (overwriteInstEnv home_ie ispec) - (dup:_, [], _, _) -> dupInstErr ispec dup >> return (extendInstEnv home_ie ispec) - ([], _, u:_, NoOverlap _) -> overlappingInstErr ispec u >> return (extendInstEnv home_ie ispec) - _ -> return (extendInstEnv home_ie ispec) - where (homematches, _) = lookupInstEnv' home_ie cls tys - home_ie_matches = [ dup_ispec - | (dup_ispec, _) <- homematches - , let dup_tys = is_tys dup_ispec - , isJust (tcMatchTys (mkVarSet tvs) tys dup_tys)] } + ; unless (null dups) $ + dupInstErr ispec (head dups) + + ; return (extendInstEnv home_ie' ispec, ispec:my_insts') } traceDFuns :: [ClsInst] -> TcRn () traceDFuns ispecs @@ -491,11 +486,6 @@ dupInstErr ispec dup_ispec = addClsInstsErr (ptext (sLit "Duplicate instance declarations:")) [ispec, dup_ispec] -overlappingInstErr :: ClsInst -> ClsInst -> TcRn () -overlappingInstErr ispec dup_ispec - = addClsInstsErr (ptext (sLit "Overlapping instance declarations:")) - [ispec, dup_ispec] - addClsInstsErr :: SDoc -> [ClsInst] -> TcRn () addClsInstsErr herald ispecs = setSrcSpan (getSrcSpan (head sorted)) $ diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index bf9d24be0a..eab8941956 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -6,16 +6,10 @@ Typecheck arrow notation \begin{code} {-# LANGUAGE RankNTypes #-} -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details module TcArrows ( tcProc ) where -import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr ) +import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr ) import HsSyn import TcMatches @@ -78,32 +72,32 @@ Note that %************************************************************************ -%* * - Proc -%* * +%* * + Proc +%* * %************************************************************************ \begin{code} -tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr - -> TcRhoType -- Expected type of whole proc expression +tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr + -> TcRhoType -- Expected type of whole proc expression -> TcM (OutPat TcId, LHsCmdTop TcId, TcCoercion) tcProc pat cmd exp_ty = newArrowScope $ - do { (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty - ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 - ; let cmd_env = CmdEnv { cmd_arr = arr_ty } + do { (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty + ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 + ; let cmd_env = CmdEnv { cmd_arr = arr_ty } ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $ - tcCmdTop cmd_env cmd (unitTy, res_ty) + tcCmdTop cmd_env cmd (unitTy, res_ty) ; let res_co = mkTcTransCo co (mkTcAppCo co1 (mkTcNomReflCo res_ty)) ; return (pat', cmd', res_co) } \end{code} %************************************************************************ -%* * - Commands -%* * +%* * + Commands +%* * %************************************************************************ \begin{code} @@ -113,7 +107,7 @@ type CmdArgType = TcTauType -- carg_type, a nested tuple data CmdEnv = CmdEnv { - cmd_arr :: TcType -- arrow type constructor, of kind *->*->* + cmd_arr :: TcType -- arrow type constructor, of kind *->*->* } mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType @@ -127,27 +121,27 @@ tcCmdTop :: CmdEnv tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_ty@(cmd_stk, res_ty) = setSrcSpan loc $ - do { cmd' <- tcCmd env cmd cmd_ty - ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names - ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') } + do { cmd' <- tcCmd env cmd cmd_ty + ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names + ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') } ---------------------------------------- tcCmd :: CmdEnv -> LHsCmd Name -> CmdType -> TcM (LHsCmd TcId) - -- The main recursive function + -- The main recursive function tcCmd env (L loc cmd) res_ty = setSrcSpan loc $ do - { cmd' <- tc_cmd env cmd res_ty - ; return (L loc cmd') } + { cmd' <- tc_cmd env cmd res_ty + ; return (L loc cmd') } tc_cmd :: CmdEnv -> HsCmd Name -> CmdType -> TcM (HsCmd TcId) tc_cmd env (HsCmdPar cmd) res_ty - = do { cmd' <- tcCmd env cmd res_ty - ; return (HsCmdPar cmd') } + = do { cmd' <- tcCmd env cmd res_ty + ; return (HsCmdPar cmd') } tc_cmd env (HsCmdLet binds (L body_loc body)) res_ty - = do { (binds', body') <- tcLocalBinds binds $ - setSrcSpan body_loc $ - tc_cmd env body res_ty - ; return (HsCmdLet binds' (L body_loc body')) } + = do { (binds', body') <- tcLocalBinds binds $ + setSrcSpan body_loc $ + tc_cmd env body res_ty + ; return (HsCmdLet binds' (L body_loc body')) } tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ do @@ -167,25 +161,25 @@ tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty -- Ordinary 'if' } tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if - = do { pred_ty <- newFlexiTyVarTy openTypeKind + = do { pred_ty <- newFlexiTyVarTy openTypeKind -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r -- because we're going to apply it to the environment, not -- the return value. ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] - ; let r_ty = mkTyVarTy r_tv + ; let r_ty = mkTyVarTy r_tv ; let if_ty = mkFunTys [pred_ty, r_ty, r_ty] r_ty ; checkTc (not (r_tv `elemVarSet` tyVarsOfType pred_ty)) (ptext (sLit "Predicate type of `ifThenElse' depends on result type")) - ; fun' <- tcSyntaxOp IfOrigin fun if_ty - ; pred' <- tcMonoExpr pred pred_ty - ; b1' <- tcCmd env b1 res_ty - ; b2' <- tcCmd env b2 res_ty + ; fun' <- tcSyntaxOp IfOrigin fun if_ty + ; pred' <- tcMonoExpr pred pred_ty + ; b1' <- tcCmd env b1 res_ty + ; b2' <- tcCmd env b2 res_ty ; return (HsCmdIf (Just fun') pred' b1' b2') } ------------------------------------------- --- Arrow application --- (f -< a) or (f -<< a) +-- Arrow application +-- (f -< a) or (f -<< a) -- -- D |- fun :: a t1 t2 -- D,G |- arg :: t1 @@ -200,16 +194,16 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if -- (plus -<< requires ArrowApply) tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) - = addErrCtxt (cmdCtxt cmd) $ + = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newFlexiTyVarTy openTypeKind - ; let fun_ty = mkCmdArrTy env arg_ty res_ty - ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty) + ; let fun_ty = mkCmdArrTy env arg_ty res_ty + ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty) -- ToDo: There should be no need for the escapeArrowScope stuff -- See Note [Escaping the arrow scope] in TcRnTypes - ; arg' <- tcMonoExpr arg arg_ty + ; arg' <- tcMonoExpr arg arg_ty - ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) } + ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) } where -- Before type-checking f, use the environment of the enclosing -- proc for the (-<) case. @@ -220,7 +214,7 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) HsFirstOrderApp -> escapeArrowScope tc ------------------------------------------- --- Command application +-- Command application -- -- D,G |- exp : t -- D;G |-a cmd : (t,stk) --> res @@ -228,14 +222,14 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) -- D;G |-a cmd exp : stk --> res tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) - = addErrCtxt (cmdCtxt cmd) $ + = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newFlexiTyVarTy openTypeKind - ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) - ; arg' <- tcMonoExpr arg arg_ty - ; return (HsCmdApp fun' arg') } + ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) + ; arg' <- tcMonoExpr arg arg_ty + ; return (HsCmdApp fun' arg') } ------------------------------------------- --- Lambda +-- Lambda -- -- D;G,x:t |-a cmd : stk --> res -- ------------------------------ @@ -244,60 +238,60 @@ tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) tc_cmd env (HsCmdLam (MG { mg_alts = [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))], mg_origin = origin })) (cmd_stk, res_ty) - = addErrCtxt (pprMatchInCtxt match_ctxt match) $ - do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk + = addErrCtxt (pprMatchInCtxt match_ctxt match) $ + do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk - -- Check the patterns, and the GRHSs inside - ; (pats', grhss') <- setSrcSpan mtch_loc $ + -- Check the patterns, and the GRHSs inside + ; (pats', grhss') <- setSrcSpan mtch_loc $ tcPats LambdaExpr pats arg_tys $ tc_grhss grhss cmd_stk' res_ty - ; let match' = L mtch_loc (Match pats' Nothing grhss') + ; let match' = L mtch_loc (Match pats' Nothing grhss') arg_tys = map hsLPatType pats' cmd' = HsCmdLam (MG { mg_alts = [match'], mg_arg_tys = arg_tys , mg_res_ty = res_ty, mg_origin = origin }) - ; return (mkHsCmdCast co cmd') } + ; return (mkHsCmdCast co cmd') } where n_pats = length pats - match_ctxt = (LambdaExpr :: HsMatchContext Name) -- Maybe KappaExpr? + match_ctxt = (LambdaExpr :: HsMatchContext Name) -- Maybe KappaExpr? pg_ctxt = PatGuard match_ctxt tc_grhss (GRHSs grhss binds) stk_ty res_ty - = do { (binds', grhss') <- tcLocalBinds binds $ - mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss - ; return (GRHSs grhss' binds') } + = do { (binds', grhss') <- tcLocalBinds binds $ + mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss + ; return (GRHSs grhss' binds') } tc_grhs stk_ty res_ty (GRHS guards body) - = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ - \ res_ty -> tcCmd env body (stk_ty, res_ty) - ; return (GRHS guards' rhs') } + = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ + \ res_ty -> tcCmd env body (stk_ty, res_ty) + ; return (GRHS guards' rhs') } ------------------------------------------- --- Do notation +-- Do notation tc_cmd env (HsCmdDo stmts _) (cmd_stk, res_ty) - = do { co <- unifyType unitTy cmd_stk -- Expecting empty argument stack - ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty - ; return (mkHsCmdCast co (HsCmdDo stmts' res_ty)) } + = do { co <- unifyType unitTy cmd_stk -- Expecting empty argument stack + ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty + ; return (mkHsCmdCast co (HsCmdDo stmts' res_ty)) } ----------------------------------------------------------------- --- Arrow ``forms'' (| e c1 .. cn |) +-- Arrow ``forms'' (| e c1 .. cn |) -- --- D; G |-a1 c1 : stk1 --> r1 --- ... --- D; G |-an cn : stkn --> rn --- D |- e :: forall e. a1 (e, stk1) t1 +-- D; G |-a1 c1 : stk1 --> r1 +-- ... +-- D; G |-an cn : stkn --> rn +-- D |- e :: forall e. a1 (e, stk1) t1 -- ... -- -> an (e, stkn) tn -- -> a (e, stk) t --- e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn) --- ---------------------------------------------- --- D; G |-a (| e c1 ... cn |) : stk --> t +-- e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn) +-- ---------------------------------------------- +-- D; G |-a (| e c1 ... cn |) : stk --> t -tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) - = addErrCtxt (cmdCtxt cmd) $ - do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args +tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) + = addErrCtxt (cmdCtxt cmd) $ + do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args ; let e_ty = mkForAllTy alphaTyVar $ -- We use alphaTyVar for 'w' mkFunTys cmd_tys $ mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty @@ -308,19 +302,19 @@ tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) tc_cmd_arg :: LHsCmdTop Name -> TcM (LHsCmdTop TcId, TcType) tc_cmd_arg cmd = do { arr_ty <- newFlexiTyVarTy arrowTyConKind - ; stk_ty <- newFlexiTyVarTy liftedTypeKind - ; res_ty <- newFlexiTyVarTy liftedTypeKind - ; let env' = env { cmd_arr = arr_ty } - ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty) - ; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } + ; stk_ty <- newFlexiTyVarTy liftedTypeKind + ; res_ty <- newFlexiTyVarTy liftedTypeKind + ; let env' = env { cmd_arr = arr_ty } + ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty) + ; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } ----------------------------------------------------------------- --- Base case for illegal commands +-- Base case for illegal commands -- This is where expressions that aren't commands get rejected tc_cmd _ cmd _ = failWithTc (vcat [ptext (sLit "The expression"), nest 2 (ppr cmd), - ptext (sLit "was found where an arrow command was expected")]) + ptext (sLit "was found where an arrow command was expected")]) matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercion, [TcType], TcType) @@ -334,34 +328,34 @@ matchExpectedCmdArgs n ty %************************************************************************ -%* * - Stmts -%* * +%* * + Stmts +%* * %************************************************************************ \begin{code} -------------------------------- --- Mdo-notation +-- Mdo-notation -- The distinctive features here are --- (a) RecStmts, and --- (b) no rebindable syntax +-- (a) RecStmts, and +-- (b) no rebindable syntax tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker tcArrDoStmt env _ (LastStmt rhs _) res_ty thing_inside - = do { rhs' <- tcCmd env rhs (unitTy, res_ty) - ; thing <- thing_inside (panic "tcArrDoStmt") - ; return (LastStmt rhs' noSyntaxExpr, thing) } + = do { rhs' <- tcCmd env rhs (unitTy, res_ty) + ; thing <- thing_inside (panic "tcArrDoStmt") + ; return (LastStmt rhs' noSyntaxExpr, thing) } tcArrDoStmt env _ (BodyStmt rhs _ _ _) res_ty thing_inside - = do { (rhs', elt_ty) <- tc_arr_rhs env rhs - ; thing <- thing_inside res_ty - ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) } + = do { (rhs', elt_ty) <- tc_arr_rhs env rhs + ; thing <- thing_inside res_ty + ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) } tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside - = do { (rhs', pat_ty) <- tc_arr_rhs env rhs - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ + = do { (rhs', pat_ty) <- tc_arr_rhs env rhs + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ thing_inside res_ty - ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } + ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names , recS_rec_ids = rec_names }) res_ty thing_inside @@ -370,15 +364,15 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys ; tcExtendIdEnv tup_ids $ do { (stmts', tup_rets) - <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> - -- ToDo: res_ty not really right + <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> + -- ToDo: res_ty not really right zipWithM tcCheckId tup_names tup_elt_tys ; thing <- thing_inside res_ty - -- NB: The rec_ids for the recursive things - -- already scope over this part. This binding may shadow - -- some of them with polymorphic things with the same Name - -- (see note [RecStmt] in HsExpr) + -- NB: The rec_ids for the recursive things + -- already scope over this part. This binding may shadow + -- some of them with polymorphic things with the same Name + -- (see note [RecStmt] in HsExpr) ; let rec_ids = takeList rec_names tup_ids ; later_ids <- tcLookupLocalIds later_names @@ -391,22 +385,22 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names , recS_later_rets = later_rets , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets , recS_ret_ty = res_ty }, thing) - }} + }} tcArrDoStmt _ _ stmt _ _ = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt) tc_arr_rhs :: CmdEnv -> LHsCmd Name -> TcM (LHsCmd TcId, TcType) tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcCmd env rhs (unitTy, ty) - ; return (rhs', ty) } + ; rhs' <- tcCmd env rhs (unitTy, ty) + ; return (rhs', ty) } \end{code} %************************************************************************ -%* * - Helpers -%* * +%* * + Helpers +%* * %************************************************************************ @@ -414,15 +408,15 @@ tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind mkPairTy :: Type -> Type -> Type mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2] -arrowTyConKind :: Kind -- *->*->* +arrowTyConKind :: Kind -- *->*->* arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind \end{code} %************************************************************************ -%* * - Errors -%* * +%* * + Errors +%* * %************************************************************************ \begin{code} diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 887e41c0d5..34db200ab6 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -16,7 +16,7 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) -import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl ) +import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynWrapper ) import DynFlags import HsSyn @@ -315,16 +315,21 @@ tcValBinds top_lvl binds sigs thing_inside -- Extend the envt right away with all -- the Ids declared with type signatures -- Use tcExtendIdEnv2 to avoid extending the TcIdBinder stack - ; tcExtendIdEnv2 [(idName id, id) | id <- poly_ids] $ - tcBindGroups top_lvl sig_fn prag_fn - binds thing_inside } + ; tcExtendIdEnv2 [(idName id, id) | id <- poly_ids] $ do + { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do + { thing <- thing_inside + -- See Note [Pattern synonym wrappers don't yield dependencies] + ; patsyn_wrappers <- mapM tcPatSynWrapper patsyns + ; let extra_binds = [ (NonRecursive, wrapper) | wrapper <- patsyn_wrappers ] + ; return (extra_binds, thing) } + ; return (binds' ++ extra_binds', thing) }} where + patsyns + = [psb | (_, lbinds) <- binds, L _ (PatSynBind psb) <- bagToList lbinds] patsyn_placeholder_kinds -- See Note [Placeholder PatSyn kinds] - = [ (name, placeholder_patsyn_tything) - | (_, lbinds) <- binds - , L _ (PatSynBind{ patsyn_id = L _ name }) <- bagToList lbinds ] + = [(name, placeholder_patsyn_tything)| PSB{ psb_id = L _ name } <- patsyns ] placeholder_patsyn_tything - = AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon" + = AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon" ------------------------ tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun @@ -413,9 +418,8 @@ tc_single :: forall thing. TopLevelFlag -> TcSigFun -> PragFun -> LHsBind Name -> TcM thing -> TcM (LHsBinds TcId, thing) -tc_single _top_lvl _sig_fn _prag_fn (L _ ps@PatSynBind{}) thing_inside - = do { (pat_syn, aux_binds) <- - tcPatSynDecl (patsyn_id ps) (patsyn_args ps) (patsyn_def ps) (patsyn_dir ps) +tc_single _top_lvl _sig_fn _prag_fn (L _ (PatSynBind psb)) thing_inside + = do { (pat_syn, aux_binds) <- tcPatSynDecl psb ; let tything = AConLike (PatSynCon pat_syn) implicit_ids = (patSynMatcher pat_syn) : @@ -457,7 +461,7 @@ mkEdges sig_fn binds bindersOfHsBind :: HsBind Name -> [Name] bindersOfHsBind (PatBind { pat_lhs = pat }) = collectPatBinders pat bindersOfHsBind (FunBind { fun_id = L _ f }) = [f] -bindersOfHsBind (PatSynBind { patsyn_id = L _ psyn }) = [psyn] +bindersOfHsBind (PatSynBind PSB{ psb_id = L _ psyn }) = [psyn] bindersOfHsBind (AbsBinds {}) = panic "bindersOfHsBind AbsBinds" bindersOfHsBind (VarBind {}) = panic "bindersOfHsBind VarBind" @@ -835,7 +839,7 @@ tcSpec _ prag = pprPanic "tcSpec" (ppr prag) -------------- tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag] --- SPECIALISE pragamas for imported things +-- SPECIALISE pragmas for imported things tcImpPrags prags = do { this_mod <- getModule ; dflags <- getDynFlags diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 43cbb2c49d..d58d5db40f 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -1186,6 +1186,9 @@ canEqTyVar2 dflags ev swapped tv1 xi2 co2 ; case mb of Nothing -> return () Just new_ev -> emitInsoluble (mkNonCanonical new_ev) + -- If we have a ~ [a], it is not canonical, and in particular + -- we don't want to rewrite existing inerts with it, otherwise + -- we'd risk divergence in the constraint solver ; return Stop } where xi1 = mkTyVarTy tv1 diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 1d7936dcd2..6812ac7387 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -20,7 +20,7 @@ import FamInst import TcErrors( reportAllUnsolved ) import TcValidity( validDerivPred ) import TcEnv -import TcTyClsDecls( tcFamTyPats, tcAddDataFamInstCtxt ) +import TcTyClsDecls( tcFamTyPats, famTyConShape, tcAddDataFamInstCtxt, kcDataDefn ) import TcClassDcl( tcAddDeclCtxt ) -- Small helper import TcGenDeriv -- Deriv stuff import TcGenGenerics @@ -86,13 +86,14 @@ Overall plan \begin{code} -- DerivSpec is purely local to this module data DerivSpec theta = DS { ds_loc :: SrcSpan - , ds_name :: Name + , ds_name :: Name -- DFun name , ds_tvs :: [TyVar] , ds_theta :: theta , ds_cls :: Class , ds_tys :: [Type] , ds_tc :: TyCon , ds_tc_args :: [Type] + , ds_overlap :: Maybe OverlapMode , ds_newtype :: Bool } -- This spec implies a dfun declaration of the form -- df :: forall tvs. theta => C tys @@ -106,7 +107,7 @@ data DerivSpec theta = DS { ds_loc :: SrcSpan -- the theta is either the given and final theta, in standalone deriving, -- or the not-yet-simplified list of constraints together with their origin - -- ds_newtype = True <=> Newtype deriving + -- ds_newtype = True <=> Generalised Newtype Deriving (GND) -- False <=> Vanilla deriving \end{code} @@ -597,28 +598,44 @@ deriveInstDecl (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam ------------------------------------------------------------------ deriveFamInst :: DataFamInstDecl Name -> TcM [EarlyDerivSpec] deriveFamInst decl@(DataFamInstDecl { dfid_tycon = L _ tc_name, dfid_pats = pats - , dfid_defn = HsDataDefn { dd_derivs = Just preds } }) + , dfid_defn = defn@(HsDataDefn { dd_derivs = Just preds }) }) = tcAddDataFamInstCtxt decl $ do { fam_tc <- tcLookupTyCon tc_name - ; tcFamTyPats tc_name (tyConKind fam_tc) pats (\_ -> return ()) $ + ; tcFamTyPats (famTyConShape fam_tc) pats (kcDataDefn defn) $ + -- kcDataDefn defn: see Note [Finding the LHS patterns] \ tvs' pats' _ -> concatMapM (deriveTyData True 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) - -- data instance TF Int b = ... deriving( Eq ) - -- Here, the lhs is (TF Int b) - -- But if we just look up the tycon_name, we get is the *family* - -- tycon, but not pattern types -- they are in the *rep* tycon. deriveFamInst _ = return [] +\end{code} + +Note [Finding the LHS patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When kind polymorphism is in play, we need to be careful. Here is +Trac #9359: + data Cmp a where + Sup :: Cmp a + V :: a -> Cmp a + + data family CmpInterval (a :: Cmp k) (b :: Cmp k) :: * + data instance CmpInterval (V c) Sup = Starting c deriving( Show ) + +So CmpInterval is kind-polymorphic, but the data instance is not + CmpInterval :: forall k. Cmp k -> Cmp k -> * + data instance CmpInterval * (V (c::*)) Sup = Starting c deriving( Show ) + +Hence, when deriving the type patterns in deriveFamInst, we must kind +check the RHS (the data constructor 'Starting c') as well as the LHS, +so that we correctly see the instantiation to *. + +\begin{code} ------------------------------------------------------------------ deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec] -- Standalone deriving declarations -- e.g. deriving instance Show a => Show (T a) -- Rather like tcLocalInstDecl -deriveStandalone (L loc (DerivDecl deriv_ty)) +deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode)) = setSrcSpan loc $ addErrCtxt (standaloneCtxt deriv_ty) $ do { traceTc "Standalone deriving decl for" (ppr deriv_ty) @@ -647,7 +664,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) ; mkPolyKindedTypeableEqn cls tc } | isAlgTyCon tc -- All other classes - -> do { spec <- mkEqnHelp tvs cls cls_tys tc tc_args (Just theta) + -> do { spec <- mkEqnHelp overlap_mode tvs cls cls_tys tc tc_args (Just theta) ; return [spec] } _ -> -- Complain about functions, primitive types, etc, @@ -769,7 +786,7 @@ deriveTyData is_instance tvs tc tc_args (L loc deriv_pred) -- newtype T a s = ... deriving( ST s ) -- newtype K a a = ... deriving( Monad ) - ; spec <- mkEqnHelp (univ_kvs' ++ univ_tvs') + ; spec <- mkEqnHelp Nothing (univ_kvs' ++ univ_tvs') cls final_cls_tys tc final_tc_args Nothing ; return [spec] } } @@ -851,7 +868,8 @@ and occurrence sites. \begin{code} -mkEqnHelp :: [TyVar] +mkEqnHelp :: Maybe OverlapMode + -> [TyVar] -> Class -> [Type] -> TyCon -> [Type] -> DerivContext -- Just => context supplied (standalone deriving) @@ -862,12 +880,12 @@ mkEqnHelp :: [TyVar] -- where the 'theta' is optional (that's the Maybe part) -- Assumes that this declaration is well-kinded -mkEqnHelp tvs cls cls_tys tycon tc_args mtheta +mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta | className cls `elem` oldTypeableClassNames = do { dflags <- getDynFlags ; case checkOldTypeableConditions (dflags, tycon, tc_args) of - Just err -> bale_out err - Nothing -> mkOldTypeableEqn tvs cls tycon tc_args mtheta } + NotValid err -> bale_out err + IsValid -> mkOldTypeableEqn tvs cls tycon tc_args mtheta } | otherwise = do { (rep_tc, rep_tc_args) <- lookup_data_fam tycon tc_args @@ -898,10 +916,10 @@ mkEqnHelp tvs cls cls_tys tycon tc_args mtheta ; dflags <- getDynFlags ; if isDataTyCon rep_tc then - mkDataTypeEqn dflags tvs cls cls_tys + mkDataTypeEqn dflags overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta else - mkNewTypeEqn dflags tvs cls cls_tys + mkNewTypeEqn dflags overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta } where bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg) @@ -991,6 +1009,7 @@ See Note [Eta reduction for data family axioms] in TcInstDcls. \begin{code} mkDataTypeEqn :: DynFlags + -> Maybe OverlapMode -> [Var] -- Universally quantified type variables in the instance -> Class -- Class for which we need to derive an instance -> [Type] -- Other parameters to the class except the last @@ -1002,7 +1021,7 @@ mkDataTypeEqn :: DynFlags -> DerivContext -- Context of the instance, for standalone deriving -> TcRn EarlyDerivSpec -- Return 'Nothing' if error -mkDataTypeEqn dflags tvs cls cls_tys +mkDataTypeEqn dflags overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta = case checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args of -- NB: pass the *representation* tycon to checkSideConditions @@ -1010,13 +1029,13 @@ mkDataTypeEqn dflags tvs cls cls_tys NonDerivableClass -> bale_out (nonStdErr cls) DerivableClassError msg -> bale_out msg where - go_for_it = mk_data_eqn tvs cls tycon tc_args rep_tc rep_tc_args mtheta + go_for_it = mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg) -mk_data_eqn :: [TyVar] -> Class +mk_data_eqn :: Maybe OverlapMode -> [TyVar] -> Class -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext -> TcM EarlyDerivSpec -mk_data_eqn tvs cls tycon tc_args rep_tc rep_tc_args mtheta +mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta = do loc <- getSrcSpanM dfun_name <- new_dfun_name cls tycon case mtheta of @@ -1028,6 +1047,7 @@ mk_data_eqn tvs cls tycon tc_args rep_tc rep_tc_args mtheta , ds_cls = cls, ds_tys = inst_tys , ds_tc = rep_tc, ds_tc_args = rep_tc_args , ds_theta = inferred_constraints + , ds_overlap = overlap_mode , ds_newtype = False } Just theta -> do -- Specified context return $ GivenTheta $ DS @@ -1036,6 +1056,7 @@ mk_data_eqn tvs cls tycon tc_args rep_tc rep_tc_args mtheta , ds_cls = cls, ds_tys = inst_tys , ds_tc = rep_tc, ds_tc_args = rep_tc_args , ds_theta = theta + , ds_overlap = overlap_mode , ds_newtype = False } where inst_tys = [mkTyConApp tycon tc_args] @@ -1073,7 +1094,9 @@ mkOldTypeableEqn tvs cls tycon tc_args mtheta DS { ds_loc = loc, ds_name = dfun_name, ds_tvs = [] , ds_cls = cls, ds_tys = [mkTyConApp tycon []] , ds_tc = tycon, ds_tc_args = [] - , ds_theta = mtheta `orElse` [], ds_newtype = False }) } + , ds_theta = mtheta `orElse` [] + , ds_overlap = Nothing -- Or, Just NoOverlap? + , ds_newtype = False }) } mkPolyKindedTypeableEqn :: Class -> TyCon -> TcM [EarlyDerivSpec] -- We can arrive here from a 'deriving' clause @@ -1098,6 +1121,9 @@ mkPolyKindedTypeableEqn cls tc -- so we must instantiate it appropiately , ds_tc = tc, ds_tc_args = tc_args , ds_theta = [] -- Context is empty for polykinded Typeable + , ds_overlap = Nothing + -- Perhaps this should be `Just NoOverlap`? + , ds_newtype = False } } where (kvs,tc_app_kind) = splitForAllTys (tyConKind tc) @@ -1218,10 +1244,10 @@ checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType] checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args | Just cond <- sideConditions mtheta cls = case (cond (dflags, rep_tc, rep_tc_args)) of - Just err -> DerivableClassError err -- Class-specific error - Nothing | null cls_tys -> CanDerive -- All derivable classes are unary, so - -- cls_tys (the type args other than last) - -- should be null + NotValid err -> DerivableClassError err -- Class-specific error + IsValid | null cls_tys -> CanDerive -- All derivable classes are unary, so + -- cls_tys (the type args other than last) + -- should be null | otherwise -> DerivableClassError (classArgsErr cls cls_tys) -- e.g. deriving( Eq s ) | otherwise = NonDerivableClass -- Not a standard class @@ -1269,7 +1295,7 @@ sideConditions mtheta cls cond_vanilla = cond_stdOK mtheta True -- Vanilla data constructors but -- allow no data cons or polytype arguments -type Condition = (DynFlags, TyCon, [Type]) -> Maybe SDoc +type Condition = (DynFlags, TyCon, [Type]) -> Validity -- first Bool is whether or not we are allowed to derive Data and Typeable -- second Bool is whether or not we are allowed to derive Functor -- TyCon is the *representation* tycon if the data type is an indexed one @@ -1278,17 +1304,14 @@ type Condition = (DynFlags, TyCon, [Type]) -> Maybe SDoc orCond :: Condition -> Condition -> Condition orCond c1 c2 tc - = case c1 tc of - Nothing -> Nothing -- c1 succeeds - Just x -> case c2 tc of -- c1 fails - Nothing -> Nothing - Just y -> Just (x $$ ptext (sLit " or") $$ y) - -- Both fail + = case (c1 tc, c2 tc) of + (IsValid, _) -> IsValid -- c1 succeeds + (_, IsValid) -> IsValid -- c21 succeeds + (NotValid x, NotValid y) -> NotValid (x $$ ptext (sLit " or") $$ y) + -- Both fail andCond :: Condition -> Condition -> Condition -andCond c1 c2 tc = case c1 tc of - Nothing -> c2 tc -- c1 succeeds - Just x -> Just x -- c1 fails +andCond c1 c2 tc = c1 tc `andValid` c2 tc cond_stdOK :: DerivContext -- Says whether this is standalone deriving or not; -- if standalone, we just say "yes, go for it" @@ -1296,27 +1319,27 @@ cond_stdOK :: DerivContext -- Says whether this is standalone deriving or not; -- args and no data constructors -> Condition cond_stdOK (Just _) _ _ - = Nothing -- Don't check these conservative conditions for + = IsValid -- Don't check these conservative conditions for -- standalone deriving; just generate the code -- and let the typechecker handle the result cond_stdOK Nothing permissive (_, rep_tc, _) | null data_cons - , not permissive = Just (no_cons_why rep_tc $$ suggestion) - | not (null con_whys) = Just (vcat con_whys $$ suggestion) - | otherwise = Nothing + , not permissive = NotValid (no_cons_why rep_tc $$ suggestion) + | not (null con_whys) = NotValid (vcat con_whys $$ suggestion) + | otherwise = IsValid where suggestion = ptext (sLit "Possible fix: use a standalone deriving declaration instead") data_cons = tyConDataCons rep_tc - con_whys = mapMaybe check_con data_cons + con_whys = getInvalids (map check_con data_cons) - check_con :: DataCon -> Maybe SDoc + check_con :: DataCon -> Validity check_con con | not (isVanillaDataCon con) - = Just (badCon con (ptext (sLit "has existentials or constraints in its type"))) + = NotValid (badCon con (ptext (sLit "has existentials or constraints in its type"))) | not (permissive || all isTauTy (dataConOrigArgTys con)) - = Just (badCon con (ptext (sLit "has a higher-rank type"))) + = NotValid (badCon con (ptext (sLit "has a higher-rank type"))) | otherwise - = Nothing + = IsValid no_cons_why :: TyCon -> SDoc no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> @@ -1337,9 +1360,9 @@ cond_args :: Class -> Condition -- by generating specialised code. For others (eg Data) we don't. cond_args cls (_, tc, _) = case bad_args of - [] -> Nothing - (ty:_) -> Just (hang (ptext (sLit "Don't know how to derive") <+> quotes (ppr cls)) - 2 (ptext (sLit "for type") <+> quotes (ppr ty))) + [] -> IsValid + (ty:_) -> NotValid (hang (ptext (sLit "Don't know how to derive") <+> quotes (ppr cls)) + 2 (ptext (sLit "for type") <+> quotes (ppr ty))) where bad_args = [ arg_ty | con <- tyConDataCons tc , arg_ty <- dataConOrigArgTys con @@ -1359,8 +1382,8 @@ cond_args cls (_, tc, _) cond_isEnumeration :: Condition cond_isEnumeration (_, rep_tc, _) - | isEnumerationTyCon rep_tc = Nothing - | otherwise = Just why + | isEnumerationTyCon rep_tc = IsValid + | otherwise = NotValid why where why = sep [ quotes (pprSourceTyCon rep_tc) <+> ptext (sLit "must be an enumeration type") @@ -1369,8 +1392,8 @@ cond_isEnumeration (_, rep_tc, _) cond_isProduct :: Condition cond_isProduct (_, rep_tc, _) - | isProductTyCon rep_tc = Nothing - | otherwise = Just why + | isProductTyCon rep_tc = IsValid + | otherwise = NotValid why where why = quotes (pprSourceTyCon rep_tc) <+> ptext (sLit "must have precisely one constructor") @@ -1380,10 +1403,10 @@ cond_oldTypeableOK :: Condition -- Currently: (a) args all of kind * -- (b) 7 or fewer args cond_oldTypeableOK (_, tc, _) - | tyConArity tc > 7 = Just too_many + | tyConArity tc > 7 = NotValid too_many | not (all (isSubOpenTypeKind . tyVarKind) (tyConTyVars tc)) - = Just bad_kind - | otherwise = Nothing + = NotValid bad_kind + | otherwise = IsValid where too_many = quotes (pprSourceTyCon tc) <+> ptext (sLit "must have 7 or fewer arguments") @@ -1402,15 +1425,15 @@ cond_functorOK :: Bool -> Condition -- (e) no "stupid context" on data type cond_functorOK allowFunctions (_, rep_tc, _) | null tc_tvs - = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) - <+> ptext (sLit "must have some type parameters")) + = NotValid (ptext (sLit "Data type") <+> quotes (ppr rep_tc) + <+> ptext (sLit "must have some type parameters")) | not (null bad_stupid_theta) - = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) - <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta) + = NotValid (ptext (sLit "Data type") <+> quotes (ppr rep_tc) + <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta) | otherwise - = msum (map check_con data_cons) -- msum picks the first 'Just', if any + = allValid (map check_con data_cons) where tc_tvs = tyConTyVars rep_tc Just (_, last_tv) = snocView tc_tvs @@ -1418,25 +1441,25 @@ cond_functorOK allowFunctions (_, rep_tc, _) is_bad pred = last_tv `elemVarSet` tyVarsOfType pred data_cons = tyConDataCons rep_tc - check_con con = msum (check_universal con : foldDataConArgs (ft_check con) con) + check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con) - check_universal :: DataCon -> Maybe SDoc + check_universal :: DataCon -> Validity check_universal con | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) , tv `elem` dataConUnivTyVars con , not (tv `elemVarSet` tyVarsOfTypes (dataConTheta con)) - = Nothing -- See Note [Check that the type variable is truly universal] + = IsValid -- See Note [Check that the type variable is truly universal] | otherwise - = Just (badCon con existential) - - ft_check :: DataCon -> FFoldType (Maybe SDoc) - ft_check con = FT { ft_triv = Nothing, ft_var = Nothing - , ft_co_var = Just (badCon con covariant) - , ft_fun = \x y -> if allowFunctions then x `mplus` y - else Just (badCon con functions) - , ft_tup = \_ xs -> msum xs + = NotValid (badCon con existential) + + ft_check :: DataCon -> FFoldType Validity + ft_check con = FT { ft_triv = IsValid, ft_var = IsValid + , ft_co_var = NotValid (badCon con covariant) + , ft_fun = \x y -> if allowFunctions then x `andValid` y + else NotValid (badCon con functions) + , ft_tup = \_ xs -> allValid xs , ft_ty_app = \_ x -> x - , ft_bad_app = Just (badCon con wrong_arg) + , ft_bad_app = NotValid (badCon con wrong_arg) , ft_forall = \_ x -> x } existential = ptext (sLit "must be truly polymorphic in the last argument of the data type") @@ -1446,8 +1469,8 @@ cond_functorOK allowFunctions (_, rep_tc, _) checkFlag :: ExtensionFlag -> Condition checkFlag flag (dflags, _, _) - | xopt flag dflags = Nothing - | otherwise = Just why + | xopt flag dflags = IsValid + | otherwise = NotValid why where why = ptext (sLit "You need ") <> text flag_str <+> ptext (sLit "to derive an instance for this class") @@ -1545,11 +1568,11 @@ a context for the Data instances: %************************************************************************ \begin{code} -mkNewTypeEqn :: DynFlags -> [Var] -> Class +mkNewTypeEqn :: DynFlags -> Maybe OverlapMode -> [Var] -> Class -> [Type] -> TyCon -> [Type] -> TyCon -> [Type] -> DerivContext -> TcRn EarlyDerivSpec -mkNewTypeEqn dflags tvs +mkNewTypeEqn dflags overlap_mode tvs cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ... | ASSERT( length cls_tys + 1 == classArity cls ) @@ -1564,6 +1587,7 @@ mkNewTypeEqn dflags tvs , ds_cls = cls, ds_tys = inst_tys , ds_tc = rep_tycon, ds_tc_args = rep_tc_args , ds_theta = theta + , ds_overlap = overlap_mode , ds_newtype = True } Nothing -> return $ InferTheta $ DS { ds_loc = loc @@ -1571,6 +1595,7 @@ mkNewTypeEqn dflags tvs , ds_cls = cls, ds_tys = inst_tys , ds_tc = rep_tycon, ds_tc_args = rep_tc_args , ds_theta = all_preds + , ds_overlap = overlap_mode , ds_newtype = True } | otherwise = case checkSideConditions dflags mtheta cls cls_tys rep_tycon rep_tc_args of @@ -1584,7 +1609,7 @@ mkNewTypeEqn dflags tvs | otherwise -> bale_out non_std where newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags - go_for_it = mk_data_eqn tvs cls tycon tc_args rep_tycon rep_tc_args mtheta + go_for_it = mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tycon rep_tc_args mtheta bale_out msg = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg) non_std = nonStdErr cls @@ -2042,12 +2067,14 @@ the renamer. What a great hack! genInst :: Bool -- True <=> standalone deriving -> OverlapFlag -> CommonAuxiliaries - -> DerivSpec ThetaType -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name) -genInst standalone_deriv oflag comauxs + -> DerivSpec ThetaType + -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name) +genInst standalone_deriv default_oflag comauxs spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args , ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys - , ds_name = name, ds_cls = clas, ds_loc = loc }) - | is_newtype + , ds_overlap = overlap_mode + , ds_name = dfun_name, ds_cls = clas, ds_loc = loc }) + | is_newtype -- See Note [Bindings for Generalised Newtype Deriving] = do { inst_spec <- mkInstance oflag theta spec ; traceTc "genInst/is_newtype" (vcat [ppr loc, ppr clas, ppr tvs, ppr tys, ppr rhs_ty]) ; return ( InstInfo @@ -2063,9 +2090,8 @@ genInst standalone_deriv oflag comauxs -- See Note [Newtype deriving and unused constructors] | otherwise - = do { fix_env <- getFixityEnv - ; (meth_binds, deriv_stuff) <- genDerivStuff (getSrcSpan name) - fix_env clas name rep_tycon + = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas + dfun_name rep_tycon (lookup rep_tycon comauxs) ; inst_spec <- mkInstance oflag theta spec ; let inst_info = InstInfo { iSpec = inst_spec @@ -2076,52 +2102,49 @@ genInst standalone_deriv oflag comauxs , ib_standalone_deriving = standalone_deriv } } ; return ( inst_info, deriv_stuff, Nothing ) } where + oflag = setOverlapModeMaybe default_oflag overlap_mode rhs_ty = newTyConInstRhs rep_tycon rep_tc_args -genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon +genDerivStuff :: SrcSpan -> Class -> Name -> TyCon -> Maybe CommonAuxiliary -> TcM (LHsBinds RdrName, BagDerivStuff) -genDerivStuff loc fix_env clas name tycon comaux_maybe - | className clas `elem` oldTypeableClassNames - = do dflags <- getDynFlags - return (gen_old_Typeable_binds dflags loc tycon, emptyBag) - - | className clas == typeableClassName - = do dflags <- getDynFlags - return (gen_Typeable_binds dflags loc tycon, emptyBag) - - | ck `elem` [genClassKey, gen1ClassKey] -- Special case because monadic - = let gk = if ck == genClassKey then Gen0 else Gen1 -- TODO NSF: correctly identify when we're building Both instead of One +genDerivStuff loc clas dfun_name tycon comaux_maybe + | let ck = classKey clas + , ck `elem` [genClassKey, gen1ClassKey] -- Special case because monadic + = let gk = if ck == genClassKey then Gen0 else Gen1 + -- TODO NSF: correctly identify when we're building Both instead of One Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst in do - (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule name) + (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule dfun_name) return (binds, DerivFamInst faminst `consBag` emptyBag) | otherwise -- Non-monadic generators = do dflags <- getDynFlags - case assocMaybe (gen_list dflags) (getUnique clas) of - Just gen_fn -> return (gen_fn loc tycon) - Nothing -> pprPanic "genDerivStuff: bad derived class" (ppr clas) - where - ck = classKey clas - - gen_list :: DynFlags - -> [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))] - gen_list dflags - = [(eqClassKey, gen_Eq_binds) - ,(ordClassKey, gen_Ord_binds) - ,(enumClassKey, gen_Enum_binds) - ,(boundedClassKey, gen_Bounded_binds) - ,(ixClassKey, gen_Ix_binds) - ,(showClassKey, gen_Show_binds fix_env) - ,(readClassKey, gen_Read_binds fix_env) - ,(dataClassKey, gen_Data_binds dflags) - ,(functorClassKey, gen_Functor_binds) - ,(foldableClassKey, gen_Foldable_binds) - ,(traversableClassKey, gen_Traversable_binds) - ] + fix_env <- getFixityEnv + return (genDerivedBinds dflags fix_env clas loc tycon) \end{code} +Note [Bindings for Generalised Newtype Deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class Eq a => C a where + f :: a -> a + newtype N a = MkN [a] deriving( C ) + instance Eq (N a) where ... + +The 'deriving C' clause generates, in effect + instance (C [a], Eq a) => C (N a) where + f = coerce (f :: [a] -> [a]) + +This generates a cast for each method, but allows the superclasse to +be worked out in the usual way. In this case the superclass (Eq (N +a)) will be solved by the explicit Eq (N a) instance. We do *not* +create the superclasses by casting the superclass dictionaries for the +representation type. + +See the paper "Safe zero-cost coercions for Hsakell". + + %************************************************************************ %* * \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?} diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 6020797449..f4c7c10063 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -18,8 +18,8 @@ module TcEnv( tcExtendGlobalEnv, tcExtendGlobalEnvImplicit, setGlobalTypeEnv, tcExtendGlobalValEnv, tcLookupLocatedGlobal, tcLookupGlobal, - tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon, - tcLookupConLike, + tcLookupField, tcLookupTyCon, tcLookupClass, + tcLookupDataCon, tcLookupPatSyn, tcLookupConLike, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, tcLookupLocatedClass, tcLookupInstance, tcLookupAxiom, @@ -73,7 +73,8 @@ import Var import VarSet import RdrName import InstEnv -import DataCon +import DataCon ( DataCon ) +import PatSyn ( PatSyn ) import ConLike import TyCon import CoAxiom @@ -160,6 +161,13 @@ tcLookupDataCon name = do AConLike (RealDataCon con) -> return con _ -> wrongThingErr "data constructor" (AGlobal thing) name +tcLookupPatSyn :: Name -> TcM PatSyn +tcLookupPatSyn name = do + thing <- tcLookupGlobal name + case thing of + AConLike (PatSynCon ps) -> return ps + _ -> wrongThingErr "pattern synonym" (AGlobal thing) name + tcLookupConLike :: Name -> TcM ConLike tcLookupConLike name = do thing <- tcLookupGlobal name @@ -819,7 +827,7 @@ mkWrapperName what nameBase thisMod <- getModule let -- Note [Generating fresh names for ccall wrapper] wrapperRef = nextWrapperNum dflags - pkg = packageIdString (modulePackageId thisMod) + pkg = packageKeyString (modulePackageKey thisMod) mod = moduleNameString (moduleName thisMod) wrapperNum <- liftIO $ atomicModifyIORef wrapperRef $ \mod_env -> let num = lookupWithDefaultModuleEnv mod_env 0 thisMod diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 8fe97519e1..c8f3d06997 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -903,7 +903,7 @@ sameOccExtra ty1 ty2 , let n1 = tyConName tc1 n2 = tyConName tc2 same_occ = nameOccName n1 == nameOccName n2 - same_pkg = modulePackageId (nameModule n1) == modulePackageId (nameModule n2) + same_pkg = modulePackageKey (nameModule n1) == modulePackageKey (nameModule n2) , n1 /= n2 -- Different Names , same_occ -- but same OccName = ptext (sLit "NB:") <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) @@ -917,10 +917,10 @@ sameOccExtra ty1 ty2 | otherwise -- Imported things have an UnhelpfulSrcSpan = hang (quotes (ppr nm)) 2 (sep [ ptext (sLit "is defined in") <+> quotes (ppr (moduleName mod)) - , ppUnless (same_pkg || pkg == mainPackageId) $ + , ppUnless (same_pkg || pkg == mainPackageKey) $ nest 4 $ ptext (sLit "in package") <+> quotes (ppr pkg) ]) where - pkg = modulePackageId mod + pkg = modulePackageKey mod mod = nameModule nm loc = nameSrcSpan nm \end{code} diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 48c4cbfd87..7e6c495506 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -76,7 +76,7 @@ import qualified Data.Set as Set \begin{code} tcPolyExpr, tcPolyExprNC :: LHsExpr Name -- Expression to type check - -> TcSigmaType -- Expected type (could be a polytpye) + -> TcSigmaType -- Expected type (could be a polytype) -> TcM (LHsExpr TcId) -- Generalised expr with expected type -- tcPolyExpr is a convenient place (frequent but not too frequent) @@ -202,7 +202,7 @@ tcExpr (HsIPVar x) res_ty ; ip_var <- emitWanted origin (mkClassPred ipClass [ip_name, ip_ty]) ; tcWrapResult (fromDict ipClass ip_name ip_ty (HsVar ip_var)) ip_ty res_ty } where - -- Coerces a dictionry for `IP "x" t` into `t`. + -- Coerces a dictionary for `IP "x" t` into `t`. fromDict ipClass x ty = case unwrapNewTyCon_maybe (classTyCon ipClass) of Just (_,_,ax) -> HsWrap $ mkWpCast $ mkTcUnbranchedAxInstCo Representational ax [x,ty] @@ -565,7 +565,7 @@ Note that because MkT3 doesn't contain all the fields being updated, its RHS is simply an error, so it doesn't impose any type constraints. Hence the use of 'relevant_cont'. -Note [Implict type sharing] +Note [Implicit 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; ... } @@ -751,7 +751,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty -- Universally-quantified tyvars that -- appear in any of the *implicit* -- arguments to the constructor are fixed - -- See Note [Implict type sharing] + -- See Note [Implicit type sharing] fixed_tys = [ty | (fld,ty) <- zip flds arg_tys , not (fld `elem` upd_fld_names)] @@ -807,7 +807,7 @@ tcExpr (PArrSeq _ _) _ \begin{code} tcExpr (HsSpliceE is_ty splice) res_ty - = ASSERT( is_ty ) -- Untyped splices are expanced by the renamer + = ASSERT( is_ty ) -- Untyped splices are expanded by the renamer tcSpliceExpr splice res_ty tcExpr (HsBracket brack) res_ty = tcTypedBracket brack res_ty @@ -966,7 +966,7 @@ tcInferFun 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 + -- We can see the rank-2 type of the lambda in time to generalise e ; fun_ty' <- zonkTcType fun_ty ; (wrap, rho) <- deeplyInstantiate AppOrigin fun_ty' diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 8370e0aa06..303391fcdd 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -250,7 +250,7 @@ tcFImport (L dloc fo@(ForeignImport (L nloc nm) hs_ty _ imp_decl)) -- things are LocalIds. However, it does not need zonking, -- (so TcHsSyn.zonkForeignExports ignores it). - ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl + ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl -- Can't use sig_ty here because sig_ty :: Type and -- we need HsType Id hence the undefined ; let fi_decl = ForeignImport (L nloc id) undefined (mkSymCo norm_co) imp_decl' @@ -261,18 +261,18 @@ tcFImport d = pprPanic "tcFImport" (ppr d) ------------ Checking types for foreign import ---------------------- \begin{code} -tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport +tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport -tcCheckFIType sig_ty arg_tys res_ty (CImport cconv safety mh l@(CLabel _)) +tcCheckFIType arg_tys res_ty (CImport cconv safety mh l@(CLabel _)) -- Foreign import label = do checkCg checkCOrAsmOrLlvmOrInterp -- NB check res_ty not sig_ty! -- In case sig_ty is (forall a. ForeignPtr a) - check (null arg_tys && isFFILabelTy res_ty) (illegalForeignLabelErr sig_ty) + check (isFFILabelTy (mkFunTys arg_tys res_ty)) (illegalForeignTyErr empty) cconv' <- checkCConv cconv return (CImport cconv' safety mh l) -tcCheckFIType sig_ty arg_tys res_ty (CImport cconv safety mh CWrapper) = do +tcCheckFIType arg_tys res_ty (CImport cconv safety mh CWrapper) = do -- Foreign wrapper (former f.e.d.) -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid -- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too. @@ -285,32 +285,32 @@ tcCheckFIType sig_ty arg_tys res_ty (CImport cconv safety mh CWrapper) = do checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty - _ -> addErrTc (illegalForeignTyErr empty sig_ty) + _ -> addErrTc (illegalForeignTyErr empty (ptext (sLit "One argument expected"))) return (CImport cconv' safety mh CWrapper) -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction target)) +tcCheckFIType arg_tys res_ty idecl@(CImport cconv safety mh (CFunction target)) | isDynamicTarget target = do -- Foreign import dynamic checkCg checkCOrAsmOrLlvmOrInterp cconv' <- checkCConv cconv case arg_tys of -- The first arg must be Ptr or FunPtr - [] -> do - check False (illegalForeignTyErr empty sig_ty) + [] -> + addErrTc (illegalForeignTyErr empty (ptext (sLit "At least one argument expected"))) (arg1_ty:arg_tys) -> do dflags <- getDynFlags let curried_res_ty = foldr FunTy res_ty arg_tys check (isFFIDynTy curried_res_ty arg1_ty) - (illegalForeignTyErr argument arg1_ty) + (illegalForeignTyErr argument) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty return $ CImport cconv' safety mh (CFunction target) | cconv == PrimCallConv = do dflags <- getDynFlags - check (xopt Opt_GHCForeignImportPrim dflags) - (text "Use GHCForeignImportPrim to allow `foreign import prim'.") + checkTc (xopt Opt_GHCForeignImportPrim dflags) + (text "Use GHCForeignImportPrim to allow `foreign import prim'.") checkCg checkCOrAsmOrLlvmOrInterp checkCTarget target - check (playSafe safety) - (text "The safe/unsafe annotation should not be used with `foreign import prim'.") + checkTc (playSafe safety) + (text "The safe/unsafe annotation should not be used with `foreign import prim'.") checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys -- prim import result is more liberal, allows (#,,#) checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty @@ -336,7 +336,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction ta checkCTarget :: CCallTarget -> TcM () checkCTarget (StaticTarget str _ _) = do checkCg checkCOrAsmOrLlvmOrInterp - check (isCLabelString str) (badCName str) + checkTc (isCLabelString str) (badCName str) checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" @@ -404,7 +404,7 @@ tcFExport d = pprPanic "tcFExport" (ppr d) tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do checkCg checkCOrAsmOrLlvm - check (isCLabelString str) (badCName str) + checkTc (isCLabelString str) (badCName str) cconv' <- checkCConv cconv checkForeignArgs isFFIExternalTy arg_tys checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty @@ -426,9 +426,10 @@ tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do \begin{code} ------------ Checking argument types for foreign import ---------------------- -checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM () +checkForeignArgs :: (Type -> Validity) -> [Type] -> TcM () checkForeignArgs pred tys = mapM_ go tys - where go ty = check (pred ty) (illegalForeignTyErr argument ty) + where + go ty = check (pred ty) (illegalForeignTyErr argument) ------------ Checking result types for foreign calls ---------------------- -- | Check that the type has the form @@ -439,32 +440,34 @@ checkForeignArgs pred tys = mapM_ go tys -- We also check that the Safe Haskell condition of FFI imports having -- results in the IO monad holds. -- -checkForeignRes :: Bool -> Bool -> (Type -> Bool) -> Type -> TcM () +checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM () checkForeignRes non_io_result_ok check_safe pred_res_ty ty - = case tcSplitIOType_maybe ty of - -- Got an IO result type, that's always fine! - Just (_, res_ty) | pred_res_ty res_ty -> return () - - -- Case for non-IO result type with FFI Import - _ -> do - dflags <- getDynFlags - case (pred_res_ty ty && non_io_result_ok) of - -- handle normal typecheck fail, we want to handle this first and - -- only report safe haskell errors if the normal type check is OK. - False -> addErrTc $ illegalForeignTyErr result ty + | Just (_, res_ty) <- tcSplitIOType_maybe ty + = -- Got an IO result type, that's always fine! + check (pred_res_ty res_ty) (illegalForeignTyErr result) - -- handle safe infer fail - _ | check_safe && safeInferOn dflags - -> recordUnsafeInfer + -- Case for non-IO result type with FFI Import + | not non_io_result_ok + = addErrTc $ illegalForeignTyErr result (ptext (sLit "IO result type expected")) + + | otherwise + = do { dflags <- getDynFlags + ; case pred_res_ty ty of + -- Handle normal typecheck fail, we want to handle this first and + -- only report safe haskell errors if the normal type check is OK. + NotValid msg -> addErrTc $ illegalForeignTyErr result msg - -- handle safe language typecheck fail - _ | check_safe && safeLanguageOn dflags - -> addErrTc $ illegalForeignTyErr result ty $+$ safeHsErr + -- handle safe infer fail + _ | check_safe && safeInferOn dflags + -> recordUnsafeInfer - -- sucess! non-IO return is fine - _ -> return () + -- handle safe language typecheck fail + _ | check_safe && safeLanguageOn dflags + -> addErrTc (illegalForeignTyErr result safeHsErr) - where + -- sucess! non-IO return is fine + _ -> return () } + where safeHsErr = ptext $ sLit "Safe Haskell is on, all FFI imports must be in the IO monad" nonIOok, mustBeIO :: Bool @@ -479,22 +482,22 @@ noCheckSafe = False Checking a supported backend is in use \begin{code} -checkCOrAsmOrLlvm :: HscTarget -> Maybe SDoc -checkCOrAsmOrLlvm HscC = Nothing -checkCOrAsmOrLlvm HscAsm = Nothing -checkCOrAsmOrLlvm HscLlvm = Nothing +checkCOrAsmOrLlvm :: HscTarget -> Validity +checkCOrAsmOrLlvm HscC = IsValid +checkCOrAsmOrLlvm HscAsm = IsValid +checkCOrAsmOrLlvm HscLlvm = IsValid checkCOrAsmOrLlvm _ - = Just (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)") + = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)") -checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc -checkCOrAsmOrLlvmOrInterp HscC = Nothing -checkCOrAsmOrLlvmOrInterp HscAsm = Nothing -checkCOrAsmOrLlvmOrInterp HscLlvm = Nothing -checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing +checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity +checkCOrAsmOrLlvmOrInterp HscC = IsValid +checkCOrAsmOrLlvmOrInterp HscAsm = IsValid +checkCOrAsmOrLlvmOrInterp HscLlvm = IsValid +checkCOrAsmOrLlvmOrInterp HscInterpreted = IsValid checkCOrAsmOrLlvmOrInterp _ - = Just (text "requires interpreted, unregisterised, llvm or native code generation") + = NotValid (text "requires interpreted, unregisterised, llvm or native code generation") -checkCg :: (HscTarget -> Maybe SDoc) -> TcM () +checkCg :: (HscTarget -> Validity) -> TcM () checkCg check = do dflags <- getDynFlags let target = hscTarget dflags @@ -502,8 +505,8 @@ checkCg check = do HscNothing -> return () _ -> case check target of - Nothing -> return () - Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) + IsValid -> return () + NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err) \end{code} Calling conventions @@ -532,20 +535,16 @@ checkCConv JavaScriptCallConv = do dflags <- getDynFlags Warnings \begin{code} -check :: Bool -> MsgDoc -> TcM () -check True _ = return () -check _ the_err = addErrTc the_err - -illegalForeignLabelErr :: Type -> SDoc -illegalForeignLabelErr ty - = vcat [ illegalForeignTyErr empty ty - , ptext (sLit "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)") ] - -illegalForeignTyErr :: SDoc -> Type -> SDoc -illegalForeignTyErr arg_or_res ty - = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res, - ptext (sLit "type in foreign declaration:")]) - 2 (hsep [ppr ty]) +check :: Validity -> (MsgDoc -> MsgDoc) -> TcM () +check IsValid _ = return () +check (NotValid doc) err_fn = addErrTc (err_fn doc) + +illegalForeignTyErr :: SDoc -> SDoc -> SDoc +illegalForeignTyErr arg_or_res extra + = hang msg 2 extra + where + msg = hsep [ ptext (sLit "Unacceptable"), arg_or_res + , ptext (sLit "type in foreign declaration:")] -- Used for 'arg_or_res' argument to illegalForeignTyErr argument, result :: SDoc diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 960e3faaa3..2967630da1 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -16,20 +16,9 @@ This is where we do all the grimy bindings' generation. module TcGenDeriv ( BagDerivStuff, DerivStuff(..), - gen_Bounded_binds, - gen_Enum_binds, - gen_Eq_binds, - gen_Ix_binds, - gen_Ord_binds, - gen_Read_binds, - gen_Show_binds, - gen_Data_binds, - gen_old_Typeable_binds, gen_Typeable_binds, - gen_Functor_binds, + genDerivedBinds, FFoldType(..), functorLikeTraverse, deepSubtypesContaining, foldDataConArgs, - gen_Foldable_binds, - gen_Traversable_binds, mkCoerceClassMethEqn, gen_Newtype_binds, genAuxBinds, @@ -75,6 +64,7 @@ import Bag import Fingerprint import TcEnv (InstInfo) +import ListSetOps( assocMaybe ) import Data.List ( partition, intersperse ) \end{code} @@ -101,6 +91,39 @@ data DerivStuff -- Please add this auxiliary stuff | DerivInst (InstInfo RdrName) -- New, auxiliary instances \end{code} +%************************************************************************ +%* * + Top level function +%* * +%************************************************************************ + +\begin{code} +genDerivedBinds :: DynFlags -> FixityEnv -> Class -> SrcSpan -> TyCon + -> (LHsBinds RdrName, BagDerivStuff) +genDerivedBinds dflags fix_env clas loc tycon + | className clas `elem` oldTypeableClassNames + = gen_old_Typeable_binds dflags loc tycon + + | Just gen_fn <- assocMaybe gen_list (getUnique clas) + = gen_fn loc tycon + + | otherwise + = pprPanic "genDerivStuff: bad derived class" (ppr clas) + where + gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))] + gen_list = [ (eqClassKey, gen_Eq_binds) + , (typeableClassKey, gen_Typeable_binds dflags) + , (ordClassKey, gen_Ord_binds) + , (enumClassKey, gen_Enum_binds) + , (boundedClassKey, gen_Bounded_binds) + , (ixClassKey, gen_Ix_binds) + , (showClassKey, gen_Show_binds fix_env) + , (readClassKey, gen_Read_binds fix_env) + , (dataClassKey, gen_Data_binds dflags) + , (functorClassKey, gen_Functor_binds) + , (foldableClassKey, gen_Foldable_binds) + , (traversableClassKey, gen_Traversable_binds) ] +\end{code} %************************************************************************ %* * @@ -1210,20 +1233,22 @@ we generate We are passed the Typeable2 class as well as T \begin{code} -gen_old_Typeable_binds :: DynFlags -> SrcSpan -> TyCon -> LHsBinds RdrName +gen_old_Typeable_binds :: DynFlags -> SrcSpan -> TyCon + -> (LHsBinds RdrName, BagDerivStuff) gen_old_Typeable_binds dflags loc tycon - = unitBag $ + = ( unitBag $ mk_easy_FunBind loc (old_mk_typeOf_RDR tycon) -- Name of appropriate type0f function [nlWildPat] (nlHsApps oldMkTyConApp_RDR [tycon_rep, nlList []]) + , emptyBag ) where tycon_name = tyConName tycon modl = nameModule tycon_name - pkg = modulePackageId modl + pkg = modulePackageKey modl modl_fs = moduleNameFS (moduleName modl) - pkg_fs = packageIdFS pkg + pkg_fs = packageKeyFS pkg name_fs = occNameFS (nameOccName tycon_name) tycon_rep = nlHsApps oldMkTyCon_RDR @@ -1270,17 +1295,19 @@ we generate We are passed the Typeable2 class as well as T \begin{code} -gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon -> LHsBinds RdrName +gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon + -> (LHsBinds RdrName, BagDerivStuff) gen_Typeable_binds dflags loc tycon - = unitBag $ mk_easy_FunBind loc typeRep_RDR [nlWildPat] - (nlHsApps mkTyConApp_RDR [tycon_rep, nlList []]) + = ( unitBag $ mk_easy_FunBind loc typeRep_RDR [nlWildPat] + (nlHsApps mkTyConApp_RDR [tycon_rep, nlList []]) + , emptyBag ) where tycon_name = tyConName tycon modl = nameModule tycon_name - pkg = modulePackageId modl + pkg = modulePackageKey modl modl_fs = moduleNameFS (moduleName modl) - pkg_fs = packageIdFS pkg + pkg_fs = packageKeyFS pkg name_fs = occNameFS (nameOccName tycon_name) tycon_rep = nlHsApps mkTyCon_RDR diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index 8b7243048f..f2601beff2 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -37,6 +37,7 @@ import TcEnv import MkId import TcRnMonad import HscTypes +import ErrUtils( Validity(..), andValid ) import BuildTyCl import SrcLoc import Bag @@ -125,11 +126,11 @@ metaTyConsToDerivStuff tc metaDts = fix_env <- getFixityEnv let - safeOverlap = safeLanguageOn dflags (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc mk_inst clas ty dfun_name = mkLocalInstance (mkDictFunId dfun_name [] [] clas tys) - (NoOverlap safeOverlap) + OverlapFlag { overlapMode = NoOverlap + , isSafeOverlap = safeLanguageOn dflags } [] clas tys where tys = [ty] @@ -238,7 +239,7 @@ following constraints are satisfied. -} -canDoGenerics :: TyCon -> [Type] -> Maybe SDoc +canDoGenerics :: TyCon -> [Type] -> Validity -- canDoGenerics rep_tc tc_args determines if Generic/Rep can be derived for a -- type expression (rep_tc tc_arg0 tc_arg1 ... tc_argn). -- @@ -250,17 +251,17 @@ canDoGenerics tc tc_args = mergeErrors ( -- Check (c) from Note [Requirements for deriving Generic and Rep]. (if (not (null (tyConStupidTheta tc))) - then (Just (tc_name <+> text "must not have a datatype context")) - else Nothing) : + then (NotValid (tc_name <+> text "must not have a datatype context")) + else IsValid) : -- Check (a) from Note [Requirements for deriving Generic and Rep]. -- -- Data family indices can be instantiated; the `tc_args` here are -- the representation tycon args (if (all isTyVarTy (filterOut isKind tc_args)) - then Nothing - else Just (tc_name <+> text "must not be instantiated;" <+> - text "try deriving `" <> tc_name <+> tc_tys <> - text "' instead")) + then IsValid + else NotValid (tc_name <+> text "must not be instantiated;" <+> + text "try deriving `" <> tc_name <+> tc_tys <> + text "' instead")) -- See comment below : (map bad_con (tyConDataCons tc))) where @@ -278,28 +279,28 @@ canDoGenerics tc tc_args -- it relies on instantiating *polymorphic* sum and product types -- at the argument types of the constructors bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc)) - then (Just (ppr dc <+> text "must not have unlifted or polymorphic arguments")) + then (NotValid (ppr dc <+> text "must not have unlifted or polymorphic arguments")) else (if (not (isVanillaDataCon dc)) - then (Just (ppr dc <+> text "must be a vanilla data constructor")) - else Nothing) + then (NotValid (ppr dc <+> text "must be a vanilla data constructor")) + else IsValid) -- Nor can we do the job if it's an existential data constructor, -- Nor if the args are polymorphic types (I don't think) bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty) -mergeErrors :: [Maybe SDoc] -> Maybe SDoc -mergeErrors [] = Nothing -mergeErrors ((Just s):t) = case mergeErrors t of - Nothing -> Just s - Just s' -> Just (s <> text ", and" $$ s') -mergeErrors (Nothing :t) = mergeErrors t +mergeErrors :: [Validity] -> Validity +mergeErrors [] = IsValid +mergeErrors (NotValid s:t) = case mergeErrors t of + IsValid -> NotValid s + NotValid s' -> NotValid (s <> text ", and" $$ s') +mergeErrors (IsValid : t) = mergeErrors t -- A datatype used only inside of canDoGenerics1. It's the result of analysing -- a type term. data Check_for_CanDoGenerics1 = CCDG1 { _ccdg1_hasParam :: Bool -- does the parameter of interest occurs in -- this type? - , _ccdg1_errors :: Maybe SDoc -- errors generated by this type + , _ccdg1_errors :: Validity -- errors generated by this type } {- @@ -334,13 +335,13 @@ explicitly, even though foldDataConArgs is also doing this internally. -- are taken care of by the call to canDoGenerics. -- -- It returns Nothing if deriving is possible. It returns (Just reason) if not. -canDoGenerics1 :: TyCon -> [Type] -> Maybe SDoc +canDoGenerics1 :: TyCon -> [Type] -> Validity canDoGenerics1 rep_tc tc_args = - canDoGenerics rep_tc tc_args `mplus` additionalChecks + canDoGenerics rep_tc tc_args `andValid` additionalChecks where additionalChecks -- check (f) from Note [Requirements for deriving Generic and Rep] - | null (tyConTyVars rep_tc) = Just $ + | null (tyConTyVars rep_tc) = NotValid $ ptext (sLit "Data type") <+> quotes (ppr rep_tc) <+> ptext (sLit "must have some type parameters") @@ -348,19 +349,19 @@ canDoGenerics1 rep_tc tc_args = data_cons = tyConDataCons rep_tc check_con con = case check_vanilla con of - j@(Just _) -> [j] - Nothing -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con + j@(NotValid {}) -> [j] + IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con bad :: DataCon -> SDoc -> SDoc bad con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg - check_vanilla :: DataCon -> Maybe SDoc - check_vanilla con | isVanillaDataCon con = Nothing - | otherwise = Just (bad con existential) + check_vanilla :: DataCon -> Validity + check_vanilla con | isVanillaDataCon con = IsValid + | otherwise = NotValid (bad con existential) - bmzero = CCDG1 False Nothing - bmbad con s = CCDG1 True $ Just $ bad con s - bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (mplus m1 m2) + bmzero = CCDG1 False IsValid + bmbad con s = CCDG1 True $ NotValid $ bad con s + bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2) -- check (g) from Note [degenerate use of FFoldType] ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1 @@ -388,7 +389,7 @@ canDoGenerics1 rep_tc tc_args = , ft_forall = \_ body -> body -- polytypes are handled elsewhere } where - caseVar = CCDG1 True Nothing + caseVar = CCDG1 True IsValid existential = text "must not have existential arguments" @@ -653,7 +654,7 @@ tc_mkRepTy gk_ tycon metaDts = -- Meta-information -------------------------------------------------------------------------------- -data MetaTyCons = MetaTyCons { -- One meta datatype per dataype +data MetaTyCons = MetaTyCons { -- One meta datatype per datatype metaD :: Type -- One meta datatype per constructor , metaC :: [Type] diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index f90cfca317..f4d5cf262c 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -468,18 +468,19 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs , abe_mono = zonkIdOcc env mono_id , abe_prags = new_prags }) -zonk_bind env _sig_warn bind@(PatSynBind { patsyn_id = L loc id - , patsyn_args = details - , patsyn_def = lpat - , patsyn_dir = dir }) +zonk_bind env _sig_warn (PatSynBind bind@(PSB { psb_id = L loc id + , psb_args = details + , psb_def = lpat + , psb_dir = dir })) = do { id' <- zonkIdBndr env id ; details' <- zonkPatSynDetails env details ;(env1, lpat') <- zonkPat env lpat ; (_env2, dir') <- zonkPatSynDir env1 dir - ; return (bind { patsyn_id = L loc id' - , patsyn_args = details' - , patsyn_def = lpat' - , patsyn_dir = dir' }) } + ; return $ PatSynBind $ + bind { psb_id = L loc id' + , psb_args = details' + , psb_def = lpat' + , psb_dir = dir' } } zonkPatSynDetails :: ZonkEnv -> HsPatSynDetails (Located TcId) @@ -489,6 +490,9 @@ zonkPatSynDetails env = traverse (wrapLocM $ zonkIdBndr env) zonkPatSynDir :: ZonkEnv -> HsPatSynDir TcId -> TcM (ZonkEnv, HsPatSynDir Id) zonkPatSynDir env Unidirectional = return (env, Unidirectional) zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional) +zonkPatSynDir env (ExplicitBidirectional mg) = do + mg' <- zonkMatchGroup env zonkLExpr mg + return (env, ExplicitBidirectional mg') zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index eb3dd32997..cdeb191489 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -76,7 +76,7 @@ import Util import Data.Maybe( isNothing ) import Control.Monad ( unless, when, zipWithM ) -import PrelNames( ipClassName, funTyConKey ) +import PrelNames( ipClassName, funTyConKey, allNameStrings ) \end{code} @@ -1307,6 +1307,11 @@ 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 + -- In the case of associated types, the renamer has + -- ensured that the names are in commmon + -- e.g. class C a_29 where + -- type T b_30 a_29 :: * + -- Here the a_29 is shared 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 @@ -1325,7 +1330,7 @@ tcDataKindSig kind ; us <- newUniqueSupply ; rdr_env <- getLocalRdrEnv ; let uniqs = uniqsFromSupply us - occs = [ occ | str <- strs + occs = [ occ | str <- allNameStrings , let occ = mkOccName tvName str , isNothing (lookupLocalRdrOcc rdr_env occ) ] -- Note [Avoid name clashes for associated data types] @@ -1337,9 +1342,6 @@ tcDataKindSig kind mk_tv loc uniq occ kind = mkTyVar (mkInternalName uniq occ loc) kind - strs :: [String] - strs = [ c:cs | cs <- "" : strs, c <- ['a'..'z'] ] - badKindSig :: Kind -> SDoc badKindSig kind = hang (ptext (sLit "Kind signature on data type declaration has non-* return kind")) diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 7fa83cc344..2b123ffab6 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -38,7 +38,7 @@ import TcDeriv import TcEnv import TcHsType import TcUnify -import Coercion ( pprCoAxiom, pprCoAxBranch ) +import Coercion ( pprCoAxiom ) import MkCore ( nO_METHOD_BINDING_ERROR_ID ) import Type import TcEvidence @@ -51,8 +51,8 @@ import VarEnv import VarSet import CoreUnfold ( mkDFunUnfolding ) import CoreSyn ( Expr(Var, Type), CoreExpr, mkTyApps, mkVarApps ) -import PrelNames ( tYPEABLE_INTERNAL, typeableClassName, oldTypeableClassNames ) - +import PrelNames ( tYPEABLE_INTERNAL, typeableClassName, + oldTypeableClassNames, genericClassNames ) import Bag import BasicTypes import DynFlags @@ -70,6 +70,7 @@ import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) import Control.Monad import Maybes ( isNothing, isJust, whenIsJust ) +import Data.List ( mapAccumL ) \end{code} Typechecking instance declarations is done in two passes. The first @@ -414,13 +415,17 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- hand written instances of old Typeable as then unsafe casts could be -- performed. Derived instances are OK. ; dflags <- getDynFlags - ; when (safeLanguageOn dflags) $ - mapM_ (\x -> when (typInstCheck x) - (addErrAt (getSrcSpan $ iSpec x) typInstErr)) - local_infos + ; when (safeLanguageOn dflags) $ forM_ local_infos $ \x -> case x of + _ | typInstCheck x -> addErrAt (getSrcSpan $ iSpec x) (typInstErr x) + _ | genInstCheck x -> addErrAt (getSrcSpan $ iSpec x) (genInstErr x) + _ -> return () + -- As above but for Safe Inference mode. - ; when (safeInferOn dflags) $ - mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_infos + ; when (safeInferOn dflags) $ forM_ local_infos $ \x -> case x of + _ | typInstCheck x -> recordUnsafeInfer + _ | genInstCheck x -> recordUnsafeInfer + _ | overlapCheck x -> recordUnsafeInfer + _ -> return () ; return ( gbl_env , bagToList deriv_inst_info ++ local_infos @@ -441,8 +446,18 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls else (typeableInsts, i:otherInsts) typInstCheck ty = is_cls_nm (iSpec ty) `elem` oldTypeableClassNames - typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe" - ++ " Haskell! Can only derive them" + typInstErr i = hang (ptext (sLit $ "Typeable instances can only be " + ++ "derived in Safe Haskell.") $+$ + ptext (sLit "Replace the following instance:")) + 2 (pprInstanceHdr (iSpec i)) + + overlapCheck ty = overlapMode (is_flag $ iSpec ty) `elem` + [Overlappable, Overlapping, Overlaps] + genInstCheck ty = is_cls_nm (iSpec ty) `elem` genericClassNames + genInstErr i = hang (ptext (sLit $ "Generic instances can only be " + ++ "derived in Safe Haskell.") $+$ + ptext (sLit "Replace the following instance:")) + 2 (pprInstanceHdr (iSpec i)) instMsg i = hang (ptext (sLit $ "Typeable instances can only be derived; replace " ++ "the following instance:")) @@ -506,6 +521,7 @@ tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) 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_overlap_mode = overlap_mode , cid_datafam_insts = adts })) = setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ @@ -527,47 +543,20 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds -- Check for missing associated types and build them -- from their defaults (if available) - ; let defined_ats = mkNameSet $ map (tyFamInstDeclName . unLoc) ats - defined_adts = mkNameSet $ map (unLoc . dfid_tycon . unLoc) adts - - 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 - || tyConName fam_tc `elemNameSet` defined_adts - = return [] - - -- No defaults ==> generate a warning - | null defs - = do { warnMissingMethodOrAT "associated type" (tyConName fam_tc) - ; return [] } - - -- No user instance, have defaults ==> instatiate them - -- Example: class C a where { type F a b :: *; type F a b = () } - -- instance C [x] - -- Then we want to generate the decl: type F [x] b = () - | otherwise - = forM defs $ \br@(CoAxBranch { cab_lhs = pat_tys, cab_rhs = rhs }) -> - do { let pat_tys' = substTys mini_subst pat_tys - rhs' = substTy mini_subst rhs - tv_set' = tyVarsOfTypes pat_tys' - tvs' = varSetElemsKvsFirst tv_set' - ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys' - ; let axiom = mkSingleCoAxiom rep_tc_name tvs' fam_tc pat_tys' rhs' - ; traceTc "mk_deflt_at_instance" (vcat [ ppr (tyvars, theta, clas, inst_tys) - , pprCoAxBranch fam_tc br - , pprCoAxiom axiom ]) - ; ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) - newFamInst SynFamilyInst axiom } - - ; tyfam_insts1 <- mapM mk_deflt_at_instances (classATItems clas) + ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats) + `unionNameSets` + mkNameSet (map (unLoc . dfid_tycon . unLoc) adts) + ; tyfam_insts1 <- mapM (tcATDefault mini_subst defined_ats) + (classATItems clas) -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty) -- Dfun location is that of instance *header* - ; overlap_flag <- getOverlapFlag + ; overlap_flag <- + do defaultOverlapFlag <- getOverlapFlag + return $ setOverlapModeMaybe defaultOverlapFlag overlap_mode ; (subst, tyvars') <- tcInstSkolTyVars tyvars ; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys ispec = mkLocalInstance dfun overlap_flag tyvars' clas (substTys subst inst_tys) @@ -582,6 +571,48 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts) } + +tcATDefault :: TvSubst -> NameSet -> ClassATItem -> TcM [FamInst] +-- ^ Construct default instances for any associated types that +-- aren't given a user definition +-- Returns [] or singleton +tcATDefault inst_subst defined_ats (ATI fam_tc defs) + -- User supplied instances ==> everything is OK + | tyConName fam_tc `elemNameSet` defined_ats + = return [] + + -- No user instance, have defaults ==> instatiate them + -- Example: class C a where { type F a b :: *; type F a b = () } + -- instance C [x] + -- Then we want to generate the decl: type F [x] b = () + | Just rhs_ty <- defs + = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst + (tyConTyVars fam_tc) + rhs' = substTy subst' rhs_ty + tv_set' = tyVarsOfTypes pat_tys' + tvs' = varSetElemsKvsFirst tv_set' + ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys' + ; let axiom = mkSingleCoAxiom rep_tc_name tvs' fam_tc pat_tys' rhs' + ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty + , pprCoAxiom axiom ]) + ; fam_inst <- ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) + newFamInst SynFamilyInst axiom + ; return [fam_inst] } + + -- No defaults ==> generate a warning + | otherwise -- defs = Nothing + = do { warnMissingMethodOrAT "associated type" (tyConName fam_tc) + ; return [] } + where + subst_tv subst tc_tv + | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv + = (subst, ty) + | otherwise + = (extendTvSubst subst tc_tv ty', ty') + where + ty' = mkTyVarTy (updateTyVarKind (substTy subst) tc_tv) + + -------------- tcAssocTyDecl :: Class -- Class of associated type -> VarEnv Type -- Instantiation of class TyVars @@ -630,7 +661,7 @@ tcTyFamInstDecl :: Maybe (Class, VarEnv Type) -- the class & mini_env if applica tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) = setSrcSpan loc $ tcAddTyFamInstCtxt decl $ - do { let fam_lname = tfie_tycon (unLoc eqn) + do { let fam_lname = tfe_tycon (unLoc eqn) ; fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_lname -- (0) Check it's an open type family @@ -639,14 +670,13 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) ; checkTc (isOpenSynFamilyTyCon fam_tc) (notOpenFamily fam_tc) -- (1) do the work of verifying the synonym group - ; co_ax_branch <- tcSynFamInstDecl fam_tc decl + ; co_ax_branch <- tcTyFamInstEqn (famTyConShape fam_tc) eqn -- (2) check for validity ; checkValidTyFamInst mb_clsinfo fam_tc co_ax_branch -- (3) construct coercion axiom - ; rep_tc_name <- newFamInstAxiomName loc - (tyFamInstDeclName decl) + ; rep_tc_name <- newFamInstAxiomName loc (unLoc fam_lname) [co_ax_branch] ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch ; newFamInst SynFamilyInst axiom } @@ -669,7 +699,7 @@ tcDataFamInstDecl mb_clsinfo ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc) -- Kind check type patterns - ; tcFamTyPats (unLoc fam_tc_name) (tyConKind fam_tc) pats + ; tcFamTyPats (famTyConShape fam_tc) pats (kcDataDefn defn) $ \tvs' pats' res_kind -> do diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 42e04650c1..33249f4b04 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -753,12 +753,16 @@ kickOutRewritable :: CtEvidence -- Flavour of the equality that is -> InertCans -> TcS (Int, InertCans) kickOutRewritable new_ev new_tv - (IC { inert_eqs = tv_eqs - , inert_dicts = dictmap - , inert_funeqs = funeqmap - , inert_irreds = irreds - , inert_insols = insols - , inert_no_eqs = no_eqs }) + inert_cans@(IC { inert_eqs = tv_eqs + , inert_dicts = dictmap + , inert_funeqs = funeqmap + , inert_irreds = irreds + , inert_insols = insols + , inert_no_eqs = no_eqs }) + | new_tv `elemVarEnv` tv_eqs -- Fast path: there is at least one equality for tv + -- so kick-out will do nothing + = return (0, inert_cans) + | otherwise = do { traceTcS "kickOutRewritable" $ vcat [ text "tv = " <+> ppr new_tv , ptext (sLit "Kicked out =") <+> ppr kicked_out] @@ -1948,7 +1952,7 @@ getCoercibleInst loc ty1 ty2 = do ev_term <- deferTcSForAllEq Representational loc (tvs1,body1) (tvs2,body2) return $ GenInst [] ev_term - -- Coercible NT a (see case 4 in [Coercible Instances]) + -- Coercible NT a (see case 3 in [Coercible Instances]) | Just (tc,tyArgs) <- splitTyConApp_maybe ty1, Just (concTy, ntCo) <- instNewTyConTF_maybe famenv tc tyArgs, dataConsInScope rdr_env tc -- Do not look at all tyConsOfTyCon @@ -1960,7 +1964,19 @@ getCoercibleInst loc ty1 ty2 = do coercionToTcCoercion ntCo `mkTcTransCo` mkTcCoVarCo local_var return $ GenInst (freshGoals [ct_ev]) (EvCoercion tcCo) - -- Coercible (D ty1 ty2) (D ty1' ty2') (see case 2 in [Coercible Instances]) + -- Coercible a NT (see case 3 in [Coercible Instances]) + | Just (tc,tyArgs) <- splitTyConApp_maybe ty2, + Just (concTy, ntCo) <- instNewTyConTF_maybe famenv tc tyArgs, + dataConsInScope rdr_env tc -- Do not look at all tyConsOfTyCon + = do markDataConsAsUsed rdr_env tc + ct_ev <- requestCoercible loc ty1 concTy + local_var <- mkSysLocalM (fsLit "coev") $ mkCoerciblePred ty1 concTy + let binds = EvBinds (unitBag (EvBind local_var (getEvTerm ct_ev))) + tcCo = TcLetCo binds $ + mkTcCoVarCo local_var `mkTcTransCo` mkTcSymCo (coercionToTcCoercion ntCo) + return $ GenInst (freshGoals [ct_ev]) (EvCoercion tcCo) + + -- Coercible (D ty1 ty2) (D ty1' ty2') (see case 4 in [Coercible Instances]) | Just (tc1,tyArgs1) <- splitTyConApp_maybe ty1, Just (tc2,tyArgs2) <- splitTyConApp_maybe ty2, tc1 == tc2, @@ -1991,18 +2007,6 @@ getCoercibleInst loc ty1 ty2 = do tcCo = TcLetCo binds (mkTcTyConAppCo Representational tc1 arg_cos) return $ GenInst (catMaybes arg_new) (EvCoercion tcCo) - -- Coercible a NT (see case 3 in [Coercible Instances]) - | Just (tc,tyArgs) <- splitTyConApp_maybe ty2, - Just (concTy, ntCo) <- instNewTyConTF_maybe famenv tc tyArgs, - dataConsInScope rdr_env tc -- Do not look at all tyConsOfTyCon - = do markDataConsAsUsed rdr_env tc - ct_ev <- requestCoercible loc ty1 concTy - local_var <- mkSysLocalM (fsLit "coev") $ mkCoerciblePred ty1 concTy - let binds = EvBinds (unitBag (EvBind local_var (getEvTerm ct_ev))) - tcCo = TcLetCo binds $ - mkTcCoVarCo local_var `mkTcTransCo` mkTcSymCo (coercionToTcCoercion ntCo) - return $ GenInst (freshGoals [ct_ev]) (EvCoercion tcCo) - -- Cannot solve this one | otherwise = return NoInstance diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs index 82fa999f34..b5fbc295f5 100644 --- a/compiler/typecheck/TcPatSyn.lhs +++ b/compiler/typecheck/TcPatSyn.lhs @@ -7,7 +7,7 @@ \begin{code} {-# LANGUAGE CPP #-} -module TcPatSyn (tcPatSynDecl) where +module TcPatSyn (tcPatSynDecl, tcPatSynWrapper) where import HsSyn import TcPat @@ -40,12 +40,10 @@ import TypeRep \end{code} \begin{code} -tcPatSynDecl :: Located Name - -> HsPatSynDetails (Located Name) - -> LPat Name - -> HsPatSynDir Name +tcPatSynDecl :: PatSynBind Name Name -> TcM (PatSyn, LHsBinds Id) -tcPatSynDecl lname@(L _ name) details lpat dir +tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, + psb_def = lpat, psb_dir = dir } = do { traceTc "tcPatSynDecl {" $ ppr name $$ ppr lpat ; tcCheckPatSynPat lpat ; pat_ty <- newFlexiTyVarTy openTypeKind @@ -95,9 +93,10 @@ tcPatSynDecl lname@(L _ name) details lpat dir prov_dicts req_dicts prov_theta req_theta pat_ty - ; m_wrapper <- tcPatSynWrapper lname lpat dir args - univ_tvs ex_tvs theta pat_ty - ; let binds = matcher_bind `unionBags` maybe emptyBag snd m_wrapper + + ; wrapper_id <- if isBidirectional dir + then fmap Just $ mkPatSynWrapperId lname args univ_tvs ex_tvs theta pat_ty + else return Nothing ; traceTc "tcPatSynDecl }" $ ppr name ; let patSyn = mkPatSyn name is_infix @@ -105,8 +104,8 @@ tcPatSynDecl lname@(L _ name) details lpat dir univ_tvs ex_tvs prov_theta req_theta pat_ty - matcher_id (fmap fst m_wrapper) - ; return (patSyn, binds) } + matcher_id wrapper_id + ; return (patSyn, matcher_bind) } \end{code} @@ -188,33 +187,51 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d name <- newName . mkVarOccFS . fsLit $ s return $ mkLocalId name ty -tcPatSynWrapper :: Located Name - -> LPat Name - -> HsPatSynDir Name - -> [Var] - -> [TyVar] -> [TyVar] - -> ThetaType - -> TcType - -> TcM (Maybe (Id, LHsBinds Id)) +isBidirectional :: HsPatSynDir a -> Bool +isBidirectional Unidirectional = False +isBidirectional ImplicitBidirectional = True +isBidirectional ExplicitBidirectional{} = True + +tcPatSynWrapper :: PatSynBind Name Name + -> TcM (LHsBinds Id) -- See Note [Matchers and wrappers for pattern synonyms] in PatSyn -tcPatSynWrapper lname lpat dir args univ_tvs ex_tvs theta pat_ty - = do { let argNames = mkNameSet (map Var.varName args) - ; case (dir, tcPatToExpr argNames lpat) of - (Unidirectional, _) -> - return Nothing - (ImplicitBidirectional, Nothing) -> - cannotInvertPatSynErr lpat - (ImplicitBidirectional, Just lexpr) -> - fmap Just $ tc_pat_syn_wrapper_from_expr lname lexpr args univ_tvs ex_tvs theta pat_ty } - -tc_pat_syn_wrapper_from_expr :: Located Name - -> LHsExpr Name - -> [Var] - -> [TyVar] -> [TyVar] - -> ThetaType - -> Type - -> TcM (Id, LHsBinds Id) -tc_pat_syn_wrapper_from_expr (L loc name) lexpr args univ_tvs ex_tvs theta pat_ty +tcPatSynWrapper PSB{ psb_id = L loc name, psb_def = lpat, psb_dir = dir, psb_args = details } + = case dir of + Unidirectional -> return emptyBag + ImplicitBidirectional -> + do { wrapper_id <- tcLookupPatSynWrapper name + ; lexpr <- case tcPatToExpr (mkNameSet args) lpat of + Nothing -> cannotInvertPatSynErr lpat + Just lexpr -> return lexpr + ; let wrapper_args = map (noLoc . VarPat) args + wrapper_lname = L (getLoc lpat) (idName wrapper_id) + wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds + wrapper_bind = mkTopFunBind Generated wrapper_lname [wrapper_match] + ; mkPatSynWrapper wrapper_id wrapper_bind } + ExplicitBidirectional mg -> + do { wrapper_id <- tcLookupPatSynWrapper name + ; mkPatSynWrapper wrapper_id $ + FunBind{ fun_id = L loc (idName wrapper_id) + , fun_infix = False + , fun_matches = mg + , fun_co_fn = idHsWrapper + , bind_fvs = placeHolderNames + , fun_tick = Nothing }} + where + args = map unLoc $ case details of + PrefixPatSyn args -> args + InfixPatSyn arg1 arg2 -> [arg1, arg2] + + tcLookupPatSynWrapper name + = do { patsyn <- tcLookupPatSyn name + ; case patSynWrapper patsyn of + Nothing -> panic "tcLookupPatSynWrapper" + Just wrapper_id -> return wrapper_id } + +mkPatSynWrapperId :: Located Name + -> [Var] -> [TyVar] -> [TyVar] -> ThetaType -> Type + -> TcM Id +mkPatSynWrapperId (L _ name) args univ_tvs ex_tvs theta pat_ty = do { let qtvs = univ_tvs ++ ex_tvs ; (subst, wrapper_tvs) <- tcInstSkolTyVars qtvs ; let wrapper_theta = substTheta subst theta @@ -224,23 +241,24 @@ tc_pat_syn_wrapper_from_expr (L loc name) lexpr args univ_tvs ex_tvs theta pat_t wrapper_sigma = mkSigmaTy wrapper_tvs wrapper_theta wrapper_tau ; wrapper_name <- newImplicitBinder name mkDataConWrapperOcc - ; let wrapper_lname = L loc wrapper_name - wrapper_id = mkExportedLocalId VanillaId wrapper_name wrapper_sigma - - ; let wrapper_args = map (noLoc . VarPat . Var.varName) args' - wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds - bind = mkTopFunBind Generated wrapper_lname [wrapper_match] - lbind = noLoc bind - ; let sig = TcSigInfo{ sig_id = wrapper_id - , sig_tvs = map (\tv -> (Nothing, tv)) wrapper_tvs - , sig_theta = wrapper_theta - , sig_tau = wrapper_tau - , sig_loc = loc - } - ; (wrapper_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig lbind + ; return $ mkExportedLocalId VanillaId wrapper_name wrapper_sigma } + +mkPatSynWrapper :: Id + -> HsBind Name + -> TcM (LHsBinds Id) +mkPatSynWrapper wrapper_id bind + = do { (wrapper_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind) ; traceTc "tcPatSynDecl wrapper" $ ppr wrapper_binds ; traceTc "tcPatSynDecl wrapper type" $ ppr (varType wrapper_id) - ; return (wrapper_id, wrapper_binds) } + ; return wrapper_binds } + where + sig = TcSigInfo{ sig_id = wrapper_id + , sig_tvs = map (\tv -> (Nothing, tv)) wrapper_tvs + , sig_theta = wrapper_theta + , sig_tau = wrapper_tau + , sig_loc = noSrcSpan + } + (wrapper_tvs, wrapper_theta, wrapper_tau) = tcSplitSigmaTy (idType wrapper_id) \end{code} diff --git a/compiler/typecheck/TcPatSyn.lhs-boot b/compiler/typecheck/TcPatSyn.lhs-boot index d0420c0c31..700137c16c 100644 --- a/compiler/typecheck/TcPatSyn.lhs-boot +++ b/compiler/typecheck/TcPatSyn.lhs-boot @@ -3,14 +3,13 @@ module TcPatSyn where import Name ( Name ) import Id ( Id ) -import HsSyn ( LPat, HsPatSynDetails, HsPatSynDir, LHsBinds ) +import HsSyn ( PatSynBind, LHsBinds ) import TcRnTypes ( TcM ) -import SrcLoc ( Located ) import PatSyn ( PatSyn ) -tcPatSynDecl :: Located Name - -> HsPatSynDetails (Located Name) - -> LPat Name - -> HsPatSynDir Name +tcPatSynDecl :: PatSynBind Name Name -> TcM (PatSyn, LHsBinds Id) + +tcPatSynWrapper :: PatSynBind Name Name + -> TcM (LHsBinds Id) \end{code} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 67fa39e0e7..cd27e9d044 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -545,12 +545,35 @@ checkHiBootIface tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds, tcg_insts = local_insts, tcg_type_env = local_type_env, tcg_exports = local_exports }) - (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts, - md_types = boot_type_env, md_exports = boot_exports }) + boot_details | isHsBoot hs_src -- Current module is already a hs-boot file! = return tcg_env | otherwise + = do { mb_dfun_prs <- checkHiBootIface' local_insts local_type_env + local_exports boot_details + ; let dfun_prs = catMaybes mb_dfun_prs + boot_dfuns = map fst dfun_prs + dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) + | (boot_dfun, dfun) <- dfun_prs ] + type_env' = extendTypeEnvWithIds local_type_env boot_dfuns + tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds } + + ; setGlobalTypeEnv tcg_env' type_env' } + -- Update the global type env *including* the knot-tied one + -- so that if the source module reads in an interface unfolding + -- mentioning one of the dfuns from the boot module, then it + -- can "see" that boot dfun. See Trac #4003 + +checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo] + -> ModDetails -> TcM [Maybe (Id, Id)] +-- Variant which doesn't require a full TcGblEnv; you could get the +-- local components from another ModDetails. + +checkHiBootIface' + local_insts local_type_env local_exports + (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts, + md_types = boot_type_env, md_exports = boot_exports }) = do { traceTc "checkHiBootIface" $ vcat [ ppr boot_type_env, ppr boot_insts, ppr boot_exports] @@ -567,19 +590,11 @@ checkHiBootIface -- Check instance declarations ; mb_dfun_prs <- mapM check_inst boot_insts - ; let dfun_prs = catMaybes mb_dfun_prs - boot_dfuns = map fst dfun_prs - dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) - | (boot_dfun, dfun) <- dfun_prs ] - type_env' = extendTypeEnvWithIds local_type_env boot_dfuns - tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds } ; failIfErrsM - ; setGlobalTypeEnv tcg_env' type_env' } - -- Update the global type env *including* the knot-tied one - -- so that if the source module reads in an interface unfolding - -- mentioning one of the dfuns from the boot module, then it - -- can "see" that boot dfun. See Trac #4003 + + ; return mb_dfun_prs } + where check_export boot_avail -- boot_avail is exported by the boot iface | name `elem` dfun_names = return () @@ -681,17 +696,14 @@ checkBootTyCon tc1 tc2 (_, rho_ty2) = splitForAllTys (idType id2) op_ty2 = funResultTy rho_ty2 - eqAT (tc1, def_ats1) (tc2, def_ats2) + eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2) = checkBootTyCon tc1 tc2 && - eqListBy eqATDef def_ats1 def_ats2 + eqATDef def_ats1 def_ats2 -- Ignore the location of the defaults - eqATDef (CoAxBranch { cab_tvs = tvs1, cab_lhs = ty_pats1, cab_rhs = ty1 }) - (CoAxBranch { cab_tvs = tvs2, cab_lhs = ty_pats2, cab_rhs = ty2 }) - | Just env <- eqTyVarBndrs emptyRnEnv2 tvs1 tvs2 - = eqListBy (eqTypeX env) ty_pats1 ty_pats2 && - eqTypeX env ty1 ty2 - | otherwise = False + eqATDef Nothing Nothing = True + eqATDef (Just ty1) (Just ty2) = eqTypeX env ty1 ty2 + eqATDef _ _ = False eqFD (as1,bs1) (as2,bs2) = eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && @@ -1726,7 +1738,7 @@ loadUnqualIfaces hsc_env ictxt , let name = gre_name gre , not (isInternalName name) , let mod = nameModule name - , not (modulePackageId mod == this_pkg || isInteractiveModule mod) + , not (modulePackageKey mod == this_pkg || isInteractiveModule mod) -- Don't attempt to load an interface for stuff -- from the command line, or from the home package , isTcOcc (nameOccName name) -- Types and classes only @@ -1779,7 +1791,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , ptext (sLit "Dependent modules:") <+> ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) , ptext (sLit "Dependent packages:") <+> - ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)] + ppr (sortBy stablePackageKeyCmp $ imp_dep_pkgs imports)] where -- The two uses of sortBy are just to reduce unnecessary -- wobbling in testsuite output cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2) diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 17700e77ce..9dbc4206a5 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -1205,9 +1205,10 @@ recordUnsafeInfer = getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) False finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode finalSafeMode dflags tcg_env = do safeInf <- readIORef (tcg_safeInfer tcg_env) - return $ if safeInferOn dflags && not safeInf - then Sf_None - else safeHaskell dflags + return $ case safeHaskell dflags of + Sf_None | safeInferOn dflags && safeInf -> Sf_Safe + | otherwise -> Sf_None + s -> s \end{code} diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index d054bc21df..f46bdfd2d9 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -325,6 +325,9 @@ data TcGblEnv #endif /* GHCI */ tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings + + -- Things defined in this module, or (in GHCi) in the interactive package + -- For the latter, see Note [The interactive package] in HscTypes tcg_binds :: LHsBinds Id, -- Value bindings in this module tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids @@ -806,17 +809,17 @@ data ImportAvails -- compiling M might not need to consult X.hi, but X -- is still listed in M's dependencies. - imp_dep_pkgs :: [PackageId], + imp_dep_pkgs :: [PackageKey], -- ^ Packages needed by the module being compiled, whether directly, -- or via other modules in this package, or via modules imported -- from other packages. - imp_trust_pkgs :: [PackageId], + imp_trust_pkgs :: [PackageKey], -- ^ This is strictly a subset of imp_dep_pkgs and records the -- packages the current module needs to trust for Safe Haskell -- compilation to succeed. A package is required to be trusted if -- we are dependent on a trustworthy module in that package. - -- While perhaps making imp_dep_pkgs a tuple of (PackageId, Bool) + -- While perhaps making imp_dep_pkgs a tuple of (PackageKey, Bool) -- where True for the bool indicates the package is required to be -- trusted is the more logical design, doing so complicates a lot -- of code not concerned with Safe Haskell. @@ -1852,8 +1855,7 @@ pprO TupleOrigin = ptext (sLit "a tuple") pprO NegateOrigin = ptext (sLit "a use of syntactic negation") pprO ScOrigin = ptext (sLit "the superclasses of an instance declaration") pprO DerivOrigin = ptext (sLit "the 'deriving' clause of a data type declaration") -pprO (DerivOriginDC dc n) = pprTrace "dco" (ppr dc <+> ppr n) $ - hsep [ ptext (sLit "the"), speakNth n, +pprO (DerivOriginDC dc n) = hsep [ ptext (sLit "the"), speakNth n, ptext (sLit "field of"), quotes (ppr dc), parens (ptext (sLit "type") <+> quotes (ppr ty)) ] where ty = dataConOrigArgTys dc !! (n-1) diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index e01b2fe5a4..9891f77795 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -1147,8 +1147,8 @@ nestImplicTcS ref inner_untch inerts (TcS thing_inside) , tcs_ty_binds = ty_binds , tcs_count = count , tcs_inerts = new_inert_var - , tcs_worklist = panic "nextImplicTcS: worklist" - , tcs_implics = panic "nextImplicTcS: implics" + , tcs_worklist = panic "nestImplicTcS: worklist" + , tcs_implics = panic "nestImplicTcS: implics" -- NB: Both these are initialised by withWorkList } ; res <- TcM.setUntouchables inner_untch $ @@ -1176,8 +1176,8 @@ nestTcS (TcS thing_inside) do { inerts <- TcM.readTcRef inerts_var ; new_inert_var <- TcM.newTcRef inerts ; let nest_env = env { tcs_inerts = new_inert_var - , tcs_worklist = panic "nextImplicTcS: worklist" - , tcs_implics = panic "nextImplicTcS: implics" } + , tcs_worklist = panic "nestTcS: worklist" + , tcs_implics = panic "nestTcS: implics" } ; thing_inside nest_env } tryTcS :: TcS a -> TcS a @@ -1195,8 +1195,8 @@ tryTcS (TcS thing_inside) ; let nest_env = env { tcs_ev_binds = ev_binds_var , tcs_ty_binds = ty_binds_var , tcs_inerts = is_var - , tcs_worklist = panic "nextImplicTcS: worklist" - , tcs_implics = panic "nextImplicTcS: implics" } + , tcs_worklist = panic "tryTcS: worklist" + , tcs_implics = panic "tryTcS: implics" } ; thing_inside nest_env } -- Getters and setters of TcEnv fields @@ -1281,8 +1281,7 @@ getUntouchables = wrapTcS TcM.getUntouchables getGivenInfo :: TcS a -> TcS (Bool, [TcTyVar], a) -- See Note [inert_fsks and inert_no_eqs] getGivenInfo thing_inside - = do { - ; updInertTcS reset_vars -- Set inert_fsks and inert_no_eqs to initial values + = do { updInertTcS reset_vars -- Set inert_fsks and inert_no_eqs to initial values ; res <- thing_inside -- Run thing_inside ; is <- getTcSInerts -- Get new values of inert_fsks and inert_no_eqs ; return (inert_no_eqs (inert_cans is), inert_fsks is, res) } @@ -1559,6 +1558,8 @@ data XEvTerm = XEvTerm { ev_preds :: [PredType] -- New predicate types , ev_comp :: [EvTerm] -> EvTerm -- How to compose evidence , ev_decomp :: EvTerm -> [EvTerm] -- How to decompose evidence + -- In both ev_comp and ev_decomp, the [EvTerm] is 1-1 with ev_preds + -- and each EvTerm has type of the corresponding EvPred } data MaybeNew = Fresh CtEvidence | Cached EvTerm @@ -1645,16 +1646,16 @@ Note [xCFlavor] ~~~~~~~~~~~~~~~ A call might look like this: - xCtFlavor ev subgoal-preds evidence-transformer + xCtEvidence ev evidence-transformer - ev is Given => use ev_decomp to create new Givens for subgoal-preds, + ev is Given => use ev_decomp to create new Givens for ev_preds, and return them - ev is Wanted => create new wanteds for subgoal-preds, + ev is Wanted => create new wanteds for ev_preds, use ev_comp to bind ev, return fresh wanteds (ie ones not cached in inert_cans or solved) - ev is Derived => create new deriveds for subgoal-preds + ev is Derived => create new deriveds for ev_preds (unless cached in inert_cans or solved) Note: The [CtEvidence] returned is a subset of the subgoal-preds passed in @@ -1714,7 +1715,7 @@ as an Irreducible (see Note [Equalities with incompatible kinds] in TcCanonical), and will do no harm. \begin{code} -xCtEvidence :: CtEvidence -- Original flavor +xCtEvidence :: CtEvidence -- Original evidence -> XEvTerm -- Instructions about how to manipulate evidence -> TcS [CtEvidence] diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 843e0507dc..dde5902ccc 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -843,39 +843,6 @@ Consider floated_eqs (all wanted or derived): simpl_loop. So we iterate if there any of these \begin{code} -floatEqualities :: [TcTyVar] -> Bool -> WantedConstraints - -> TcS (Cts, WantedConstraints) --- Post: The returned floated constraints (Cts) are only Wanted or Derived --- and come from the input wanted ev vars or deriveds --- Also performs some unifications, adding to monadically-carried ty_binds --- These will be used when processing floated_eqs later -floatEqualities skols no_given_eqs wanteds@(WC { wc_flat = flats }) - | not no_given_eqs -- There are some given equalities, so don't float - = return (emptyBag, wanteds) -- Note [Float Equalities out of Implications] - | otherwise - = do { let (float_eqs, remaining_flats) = partitionBag is_floatable flats - ; untch <- TcS.getUntouchables - ; mapM_ (promoteTyVar untch) (varSetElems (tyVarsOfCts float_eqs)) - -- See Note [Promoting unification variables] - ; ty_binds <- getTcSTyBindsMap - ; traceTcS "floatEqualities" (vcat [ text "Flats =" <+> ppr flats - , text "Floated eqs =" <+> ppr float_eqs - , text "Ty binds =" <+> ppr ty_binds]) - ; return (float_eqs, wanteds { wc_flat = remaining_flats }) } - where - -- See Note [Float equalities from under a skolem binding] - skol_set = fixVarSet mk_next (mkVarSet skols) - mk_next tvs = foldrBag grow_one tvs flats - grow_one (CFunEqCan { cc_tyargs = xis, cc_rhs = rhs }) tvs - | intersectsVarSet tvs (tyVarsOfTypes xis) - = tvs `unionVarSet` tyVarsOfType rhs - grow_one _ tvs = tvs - - is_floatable :: Ct -> Bool - is_floatable ct = isEqPred pred && skol_set `disjointVarSet` tyVarsOfType pred - where - pred = ctPred ct - promoteTyVar :: Untouchables -> TcTyVar -> TcS () -- When we float a constraint out of an implication we must restore -- invariant (MetaTvInv) in Note [Untouchable type variables] in TcType @@ -1036,6 +1003,80 @@ should! If we don't solve the constraint, we'll stupidly quantify over (b:*) instead of (a:OpenKind), which can lead to disaster; see Trac #7332. Trac #7641 is a simpler example. +Note [Promoting unification variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we float an equality out of an implication we must "promote" free +unification variables of the equality, in order to maintain Invariant +(MetaTvInv) from Note [Untouchable type variables] in TcType. for the +leftover implication. + +This is absolutely necessary. Consider the following example. We start +with two implications and a class with a functional dependency. + + class C x y | x -> y + instance C [a] [a] + + (I1) [untch=beta]forall b. 0 => F Int ~ [beta] + (I2) [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c] + +We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2. +They may react to yield that (beta := [alpha]) which can then be pushed inwards +the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that +(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable +beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs: + + class C x y | x -> y where + op :: x -> y -> () + + instance C [a] [a] + + type family F a :: * + + h :: F Int -> () + h = undefined + + data TEx where + TEx :: a -> TEx + + + f (x::beta) = + let g1 :: forall b. b -> () + g1 _ = h [x] + g2 z = case z of TEx y -> (h [[undefined]], op x [y]) + in (g1 '3', g2 undefined) + + + +Note [Solving Family Equations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After we are done with simplification we may be left with constraints of the form: + [Wanted] F xis ~ beta +If 'beta' is a touchable unification variable not already bound in the TyBinds +then we'd like to create a binding for it, effectively "defaulting" it to be 'F xis'. + +When is it ok to do so? + 1) 'beta' must not already be defaulted to something. Example: + + [Wanted] F Int ~ beta <~ Will default [beta := F Int] + [Wanted] F Char ~ beta <~ Already defaulted, can't default again. We + have to report this as unsolved. + + 2) However, we must still do an occurs check when defaulting (F xis ~ beta), to + set [beta := F xis] only if beta is not among the free variables of xis. + + 3) Notice that 'beta' can't be bound in ty binds already because we rewrite RHS + of type family equations. See Inert Set invariants in TcInteract. + +This solving is now happening during zonking, see Note [Unflattening while zonking] +in TcMType. + + +********************************************************************************* +* * +* Floating equalities * +* * +********************************************************************************* + Note [Float Equalities out of Implications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For ordinary pattern matches (including existentials) we float @@ -1081,8 +1122,59 @@ Consequence: classes with functional dependencies don't matter (since there is no evidence for a fundep equality), but equality superclasses do matter (since they carry evidence). +\begin{code} +floatEqualities :: [TcTyVar] -> Bool -> WantedConstraints + -> TcS (Cts, WantedConstraints) +-- Main idea: see Note [Float Equalities out of Implications] +-- +-- Post: The returned floated constraints (Cts) are only Wanted or Derived +-- and come from the input wanted ev vars or deriveds +-- Also performs some unifications (via promoteTyVar), adding to +-- monadically-carried ty_binds. These will be used when processing +-- floated_eqs later +-- +-- Subtleties: Note [Float equalities from under a skolem binding] +-- Note [Skolem escape] +floatEqualities skols no_given_eqs wanteds@(WC { wc_flat = flats }) + | not no_given_eqs -- There are some given equalities, so don't float + = return (emptyBag, wanteds) -- Note [Float Equalities out of Implications] + | otherwise + = do { let (float_eqs, remaining_flats) = partitionBag is_floatable flats + ; untch <- TcS.getUntouchables + ; mapM_ (promoteTyVar untch) (varSetElems (tyVarsOfCts float_eqs)) + -- See Note [Promoting unification variables] + ; ty_binds <- getTcSTyBindsMap + ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols + , text "Flats =" <+> ppr flats + , text "Skol set =" <+> ppr skol_set + , text "Floated eqs =" <+> ppr float_eqs + , text "Ty binds =" <+> ppr ty_binds]) + ; return (float_eqs, wanteds { wc_flat = remaining_flats }) } + where + is_floatable :: Ct -> Bool + is_floatable ct + = case classifyPredType (ctPred ct) of + EqPred ty1 ty2 -> skol_set `disjointVarSet` tyVarsOfType ty1 + && skol_set `disjointVarSet` tyVarsOfType ty2 + _ -> False + + skol_set = fixVarSet mk_next (mkVarSet skols) + mk_next tvs = foldr grow_one tvs flat_eqs + flat_eqs :: [(TcTyVarSet, TcTyVarSet)] + flat_eqs = [ (tyVarsOfType ty1, tyVarsOfType ty2) + | EqPred ty1 ty2 <- map (classifyPredType . ctPred) (bagToList flats)] + grow_one (tvs1,tvs2) tvs + | intersectsVarSet tvs tvs1 = tvs `unionVarSet` tvs2 + | intersectsVarSet tvs tvs2 = tvs `unionVarSet` tvs2 + | otherwise = tvs +\end{code} + Note [When does an implication have given equalities?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + NB: This note is mainly referred to from TcSMonad + but it relates to floating equalities, so I've + left it here + Consider an implication beta => alpha ~ Int where beta is a unification variable that has already been unified @@ -1126,116 +1218,95 @@ This seems like the Right Thing, but it's more code, and more work at runtime, so we are using the FlatSkolOrigin idea intead. It's less obvious that it works, but I think it does, and it's simple and efficient. - Note [Float equalities from under a skolem binding] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might worry about skolem escape with all this floating. -For example, consider - [2] forall a. (a ~ F beta[2] delta, - Maybe beta[2] ~ gamma[1]) - -The (Maybe beta ~ gamma) doesn't mention 'a', so we float it, and -solve with gamma := beta. But what if later delta:=Int, and - F b Int = b. -Then we'd get a ~ beta[2], and solve to get beta:=a, and now the -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 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 - f = error "Urk" :: (forall a. a -> Proxy x -> Proxy (F x)) -> Int - -BUT (sigh) we have to be careful. Here are some edge cases: +Which of the flat equalities can we float out? Obviously, only +ones that don't mention the skolem-bound variables. But that is +over-eager. Consider + [2] forall a. F a beta[1] ~ gamma[2], G beta[1] gamma[2] ~ Int +The second constraint doesn't mention 'a'. But if we float it +we'll promote gamma to gamma'[1]. Now suppose that we learn that +beta := Bool, and F a Bool = a, and G Bool _ = Int. Then we'll +we left with the constraint + [2] forall a. a ~ gamma'[1] +which is insoluble because gamma became untouchable. + +Solution: only promote a constraint if its free variables cannot +possibly be connected with the skolems. Procedurally, start with +the skolems and "grow" that set as follows: + * For each flat equality F ts ~ s, or tv ~ s, + if the current set intersects with the LHS of the equality, + add the free vars of the RHS, and vice versa +That gives us a grown skolem set. Now float an equality if its free +vars don't intersect the grown skolem set. + +This seems very ad hoc (sigh). But here are some tricky edge cases: a) [2]forall a. (F a delta[1] ~ beta[2], delta[1] ~ Maybe beta[2]) -b) [2]forall a. (F b ty ~ beta[2], G beta[2] ~ gamma[2]) +b1) [2]forall a. (F a ty ~ beta[2], G beta[2] ~ gamma[2]) +b2) [2]forall a. (a ~ beta[2], G beta[2] ~ gamma[2]) c) [2]forall a. (F a ty ~ beta[2], delta[1] ~ Maybe beta[2]) +d) [2]forall a. (gamma[1] ~ Tree beta[2], F ty ~ beta[2]) In (a) we *must* float out the second equality, else we can't solve at all (Trac #7804). -In (b) we *must not* float out the second equality. - It will ultimately be solved (by flattening) in situ, but if we - float it we'll promote beta,gamma, and render the first equality insoluble. +In (b1, b2) we *must not* float out the second equality. + It will ultimately be solved (by flattening) in situ, but if we float + it we'll promote beta,gamma, and render the first equality insoluble. + + Trac #9316 was an example of (b2). You may wonder why (a ~ beta[2]) isn't + solved; in #9316 it wasn't solved because (a:*) and (beta:kappa[1]), so the + equality was kind-mismatched, and hence was a CIrredEvCan. There was + another equality alongside, (kappa[1] ~ *). We must first float *that* + one out and *then* we can solve (a ~ beta). In (c) it would be OK to float the second equality but better not to. If we flatten we see (delta[1] ~ Maybe (F a ty)), which is a - skolem-escape problem. If we float the secodn equality we'll + skolem-escape problem. If we float the second equality we'll end up with (F a ty ~ beta'[1]), which is a less explicable error. -Hence we start with the skolems, grow them by the CFunEqCans, and -float ones that don't mention the grown variables. Seems very ad hoc. - -Note [Promoting unification variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we float an equality out of an implication we must "promote" free -unification variables of the equality, in order to maintain Invariant -(MetaTvInv) from Note [Untouchable type variables] in TcType. for the -leftover implication. - -This is absolutely necessary. Consider the following example. We start -with two implications and a class with a functional dependency. - - class C x y | x -> y - instance C [a] [a] - - (I1) [untch=beta]forall b. 0 => F Int ~ [beta] - (I2) [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c] - -We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2. -They may react to yield that (beta := [alpha]) which can then be pushed inwards -the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that -(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable -beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs: - - class C x y | x -> y where - op :: x -> y -> () - - instance C [a] [a] - - type family F a :: * - - h :: F Int -> () - h = undefined - - data TEx where - TEx :: a -> TEx +In (d) we must float the first equality, so that we can unify gamma. + But that promotes beta, so we must float the second equality too, + Trac #7196 exhibits this case +Some notes - f (x::beta) = - let g1 :: forall b. b -> () - g1 _ = h [x] - g2 z = case z of TEx y -> (h [[undefined]], op x [y]) - in (g1 '3', g2 undefined) +* When "growing", do not simply take the free vars of the predicate! + Example [2]forall a. (a:* ~ beta[2]:kappa[1]), (kappa[1] ~ *) + We must float the second, and we must not float the first. + But the first actually looks like ((~) kappa a beta), so if we just + look at its free variables we'll see {a,kappa,beta), and that might + make us think kappa should be in the grown skol set. + (In any case, the kind argument for a kind-mis-matched equality like + this one doesn't really make sense anyway.) + That's why we use classifyPred when growing. -Note [Solving Family Equations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -After we are done with simplification we may be left with constraints of the form: - [Wanted] F xis ~ beta -If 'beta' is a touchable unification variable not already bound in the TyBinds -then we'd like to create a binding for it, effectively "defaulting" it to be 'F xis'. - -When is it ok to do so? - 1) 'beta' must not already be defaulted to something. Example: +* Previously we tried to "grow" the skol_set with *all* the + constraints (not just equalities), 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 + f = error "Urk" :: (forall a. a -> Proxy x -> Proxy (F x)) -> Int - [Wanted] F Int ~ beta <~ Will default [beta := F Int] - [Wanted] F Char ~ beta <~ Already defaulted, can't default again. We - have to report this as unsolved. - 2) However, we must still do an occurs check when defaulting (F xis ~ beta), to - set [beta := F xis] only if beta is not among the free variables of xis. +Note [Skolem escape] +~~~~~~~~~~~~~~~~~~~~ +You might worry about skolem escape with all this floating. +For example, consider + [2] forall a. (a ~ F beta[2] delta, + Maybe beta[2] ~ gamma[1]) - 3) Notice that 'beta' can't be bound in ty binds already because we rewrite RHS - of type family equations. See Inert Set invariants in TcInteract. +The (Maybe beta ~ gamma) doesn't mention 'a', so we float it, and +solve with gamma := beta. But what if later delta:=Int, and + F b Int = b. +Then we'd get a ~ beta[2], and solve to get beta:=a, and now the +skolem has escaped! -This solving is now happening during zonking, see Note [Unflattening while zonking] -in TcMType. +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. ********************************************************************************* diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index de3fbdbe89..bb6af8cb95 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -895,7 +895,7 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where RealSrcSpan s -> return s ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) , TH.loc_module = moduleNameString (moduleName m) - , TH.loc_package = packageIdString (modulePackageId m) + , TH.loc_package = packageKeyString (modulePackageKey m) , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } @@ -1472,7 +1472,7 @@ reifyName thing where name = getName thing mod = ASSERT( isExternalName name ) nameModule name - pkg_str = packageIdString (modulePackageId mod) + pkg_str = packageKeyString (modulePackageKey mod) mod_str = moduleNameString (moduleName mod) occ_str = occNameString occ occ = nameOccName name @@ -1505,7 +1505,7 @@ lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm) lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn)) = return $ ModuleTarget $ - mkModule (stringToPackageId $ TH.pkgString pn) (mkModuleName $ TH.modString mn) + mkModule (stringToPackageKey $ TH.pkgString pn) (mkModuleName $ TH.modString mn) reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a] reifyAnnotations th_name @@ -1519,13 +1519,13 @@ reifyAnnotations th_name ------------------------------ modToTHMod :: Module -> TH.Module -modToTHMod m = TH.Module (TH.PkgName $ packageIdString $ modulePackageId m) +modToTHMod m = TH.Module (TH.PkgName $ packageKeyString $ modulePackageKey m) (TH.ModName $ moduleNameString $ moduleName m) reifyModule :: TH.Module -> TcM TH.ModuleInfo reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do this_mod <- getModule - let reifMod = mkModule (stringToPackageId pkgString) (mkModuleName mString) + let reifMod = mkModule (stringToPackageKey pkgString) (mkModuleName mString) if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod where reifyThisModule = do @@ -1535,10 +1535,10 @@ reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do reifyFromIface reifMod = do iface <- loadInterfaceForModule (ptext (sLit "reifying module from TH for") <+> ppr reifMod) reifMod let usages = [modToTHMod m | usage <- mi_usages iface, - Just m <- [usageToModule (modulePackageId reifMod) usage] ] + Just m <- [usageToModule (modulePackageKey reifMod) usage] ] return $ TH.ModuleInfo usages - usageToModule :: PackageId -> Usage -> Maybe Module + usageToModule :: PackageKey -> Usage -> Maybe Module usageToModule _ (UsageFile {}) = Nothing usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot index ea3848db18..fd19dee7da 100644 --- a/compiler/typecheck/TcSplice.lhs-boot +++ b/compiler/typecheck/TcSplice.lhs-boot @@ -5,7 +5,6 @@ module TcSplice where import HsSyn ( HsSplice, HsBracket, HsQuasiQuote, HsExpr, LHsType, LHsExpr, LPat, LHsDecl ) import HsExpr ( PendingRnSplice ) -import Id ( Id ) import Name ( Name ) import RdrName ( RdrName ) import TcRnTypes( TcM, TcId ) @@ -13,6 +12,7 @@ import TcType ( TcRhoType ) import Annotations ( Annotation, CoreAnnTarget ) #ifdef GHCI +import Id ( Id ) import qualified Language.Haskell.TH as TH #endif @@ -28,20 +28,20 @@ tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId) -tcTopSpliceExpr :: Bool -> TcM (LHsExpr Id) -> TcM (LHsExpr Id) - runQuasiQuoteDecl :: HsQuasiQuote RdrName -> TcM [LHsDecl RdrName] runQuasiQuoteExpr :: HsQuasiQuote RdrName -> TcM (LHsExpr RdrName) runQuasiQuoteType :: HsQuasiQuote RdrName -> TcM (LHsType RdrName) runQuasiQuotePat :: HsQuasiQuote RdrName -> TcM (LPat RdrName) runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation +#ifdef GHCI +tcTopSpliceExpr :: Bool -> TcM (LHsExpr Id) -> TcM (LHsExpr Id) + runMetaE :: LHsExpr Id -> TcM (LHsExpr RdrName) runMetaP :: LHsExpr Id -> TcM (LPat RdrName) runMetaT :: LHsExpr Id -> TcM (LHsType RdrName) runMetaD :: LHsExpr Id -> TcM [LHsDecl RdrName] -#ifdef GHCI lookupThName_maybe :: TH.Name -> TcM (Maybe Name) runQuasi :: TH.Q a -> TcM a #endif diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index c21631f1eb..f09bef8081 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -14,7 +14,7 @@ module TcTyClsDecls ( -- Functions used by TcInstDcls to check -- data/type family instance declarations kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon, - tcSynFamInstDecl, tcFamTyPats, + tcFamTyPats, tcTyFamInstEqn, famTyConShape, tcAddTyFamInstCtxt, tcAddDataFamInstCtxt, wrongKindOfFamily, dataConCtxt, badDataConTyCon ) where @@ -502,10 +502,12 @@ 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 (FamilyDecl { fdLName = L _ fam_tc_name + , fdTyVars = hs_tvs + , fdInfo = ClosedTypeFamily eqns })) + = do { tc_kind <- kcLookupKind fam_tc_name + ; let fam_tc_shape = ( fam_tc_name, length (hsQTvBndrs hs_tvs), tc_kind) + ; mapM_ (kcTyFamInstEqn fam_tc_shape) eqns } kcTyClDecl (FamDecl {}) = return () ------------------- @@ -699,14 +701,11 @@ tcFamDecl1 parent ; checkFamFlag tc_name -- make sure we have -XTypeFamilies - -- 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 + -- Process the equations, creating CoAxBranches + ; tc_kind <- kcLookupKind tc_name + ; let fam_tc_shape = (tc_name, length (hsQTvBndrs tvs), tc_kind) + + ; branches <- mapM (tcTyFamInstEqn fam_tc_shape) eqns -- we need the tycon that we will be creating, but it's in scope. -- just look it up. @@ -836,76 +835,90 @@ Note that: - We can get default definitions only for type families, not data families \begin{code} -tcClassATs :: Name -- The class name (not knot-tied) - -> TyConParent -- The class parent of this associated type - -> [LFamilyDecl Name] -- Associated types. - -> [LTyFamInstDecl Name] -- Associated type defaults. +tcClassATs :: Name -- The class name (not knot-tied) + -> TyConParent -- The class parent of this associated type + -> [LFamilyDecl Name] -- Associated types. + -> [LTyFamDefltEqn Name] -- Associated type defaults. -> TcM [ClassATItem] tcClassATs class_name parent ats at_defs = do { -- Complain about associated type defaults for non associated-types sequence_ [ failWithTc (badATErr class_name n) - | n <- map (tyFamInstDeclName . unLoc) at_defs + | n <- map at_def_tycon at_defs , not (n `elemNameSet` at_names) ] ; mapM tc_at ats } where - at_names = mkNameSet (map (unLoc . fdLName . unLoc) ats) + at_def_tycon :: LTyFamDefltEqn Name -> Name + at_def_tycon (L _ eqn) = unLoc (tfe_tycon eqn) + + at_fam_name :: LFamilyDecl Name -> Name + at_fam_name (L _ decl) = unLoc (fdLName decl) + + at_names = mkNameSet (map at_fam_name ats) - at_defs_map :: NameEnv [LTyFamInstDecl Name] + at_defs_map :: NameEnv [LTyFamDefltEqn Name] -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv - (tyFamInstDeclName (unLoc at_def)) [at_def]) + (at_def_tycon at_def) [at_def]) emptyNameEnv 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 <- mapM (tcDefaultAssocDecl fam_tc) at_defs - ; return (fam_tc, atd) } + ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) + `orElse` [] + ; atd <- tcDefaultAssocDecl fam_tc at_defs + ; return (ATI fam_tc atd) } ------------------------- -tcDefaultAssocDecl :: TyCon -- ^ Family TyCon - -> LTyFamInstDecl Name -- ^ RHS - -> TcM CoAxBranch -- ^ Type checked RHS and free TyVars -tcDefaultAssocDecl fam_tc (L loc decl) +tcDefaultAssocDecl :: TyCon -- ^ Family TyCon + -> [LTyFamDefltEqn Name] -- ^ Defaults + -> TcM (Maybe Type) -- ^ Type checked RHS +tcDefaultAssocDecl _ [] + = return Nothing -- No default declaration + +tcDefaultAssocDecl _ (d1:_:_) + = failWithTc (ptext (sLit "More than one default declaration for") + <+> ppr (tfe_tycon (unLoc d1))) + +tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name + , tfe_pats = hs_tvs + , tfe_rhs = rhs })] = setSrcSpan loc $ - tcAddTyFamInstCtxt decl $ - do { traceTc "tcDefaultAssocDecl" (ppr decl) - ; tcSynFamInstDecl fam_tc decl } + tcAddFamInstCtxt (ptext (sLit "default type instance")) tc_name $ + tcTyClTyVars tc_name hs_tvs $ \ tvs rhs_kind -> + do { traceTc "tcDefaultAssocDecl" (ppr tc_name) + ; checkTc (isSynFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; let (fam_name, fam_pat_arity, _) = famTyConShape fam_tc + ; ASSERT( fam_name == tc_name ) + checkTc (length (hsQTvBndrs hs_tvs) == fam_pat_arity) + (wrongNumberOfParmsErr fam_pat_arity) + ; rhs_ty <- tcCheckLHsType rhs rhs_kind + ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty + ; let fam_tc_tvs = tyConTyVars fam_tc + subst = zipTopTvSubst tvs (mkTyVarTys fam_tc_tvs) + ; return ( ASSERT( equalLength fam_tc_tvs tvs ) + Just (substTy subst rhs_ty) ) } -- We check for well-formedness and validity later, in checkValidClass ------------------------- -tcSynFamInstDecl :: TyCon -> TyFamInstDecl Name -> TcM CoAxBranch --- Placed here because type family instances appear as --- default decls in class declarations -tcSynFamInstDecl fam_tc (TyFamInstDecl { tfid_eqn = eqn }) - = do { checkTc (isSynFamilyTyCon 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 () -tcSynFamInstNames (L _ first) names - = do { let badNames = filter ((/= first) . unLoc) names - ; mapM_ (failLocated (wrongNamesInInstGroup first)) badNames } - where - failLocated :: (Name -> SDoc) -> Located Name -> TcM () - failLocated msg_fun (L loc name) - = setSrcSpan loc $ - failWithTc (msg_fun name) - -kcTyFamInstEqn :: Name -> Kind -> LTyFamInstEqn Name -> TcM () -kcTyFamInstEqn fam_tc_name kind - (L loc (TyFamInstEqn { tfie_pats = pats, tfie_rhs = hs_ty })) +kcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn Name -> TcM () +kcTyFamInstEqn fam_tc_shape + (L loc (TyFamEqn { tfe_pats = pats, tfe_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 })) + tc_fam_ty_pats fam_tc_shape pats (discardResult . (tcCheckLHsType hs_ty)) + +tcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn Name -> TcM CoAxBranch +-- Needs to be here, not in TcInstDcls, because closed families +-- (typechecked here) have TyFamInstEqns +tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_) + (L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name + , tfe_pats = pats + , tfe_rhs = hs_ty })) = setSrcSpan loc $ - tcFamTyPats fam_tc_name kind pats (discardResult . (tcCheckLHsType hs_ty)) $ + tcFamTyPats fam_tc_shape pats (discardResult . (tcCheckLHsType hs_ty)) $ \tvs' pats' res_kind -> - do { rhs_ty <- tcCheckLHsType hs_ty res_kind + do { checkTc (fam_tc_name == eqn_tc_name) + (wrongTyFamName fam_tc_name eqn_tc_name) + ; rhs_ty <- tcCheckLHsType hs_ty res_kind ; rhs_ty <- zonkTcTypeToType emptyZonkEnv 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 @@ -947,6 +960,19 @@ 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). +Note [Type-checking type patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking the patterns of a family instance declaration, we can't +rely on using the family TyCon, because this is sometimes called +from within a type-checking knot. (Specifically for closed type families.) +The type FamTyConShape gives just enough information to do the job. + +The "arity" field of FamTyConShape is the *visible* arity of the family +type constructor, i.e. what the users sees and writes, not including kind +arguments. + +See also Note [tc_fam_ty_pats vs tcFamTyPats] + Note [Failing early in kcDataDefn] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We need to use checkNoErrs when calling kcConDecl. This is because kcConDecl @@ -961,15 +987,18 @@ two bad things could happen: \begin{code} ----------------- --- 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 +type FamTyConShape = (Name, Arity, Kind) -- See Note [Type-checking type patterns] + +famTyConShape :: TyCon -> FamTyConShape +famTyConShape fam_tc + = ( tyConName fam_tc + , length (filterOut isKindVar (tyConTyVars fam_tc)) + , tyConKind fam_tc ) + +tc_fam_ty_pats :: FamTyConShape -> HsWithBndrs [LHsType Name] -- Patterns - -> (TcKind -> TcM ()) -- Kind checker for RHS - -- result is ignored + -> (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> @@ -982,7 +1011,7 @@ tc_fam_ty_pats :: Name -- of the family TyCon -- In that case, the type variable 'a' will *already be in scope* -- (and, if C is poly-kinded, so will its kind parameter). -tc_fam_ty_pats fam_tc_name kind +tc_fam_ty_pats (name, arity, kind) (HsWB { hswb_cts = arg_pats, hswb_kvs = kvars, hswb_tvs = tvars }) kind_checker = do { let (fam_kvs, fam_body) = splitForAllTys kind @@ -994,9 +1023,8 @@ tc_fam_ty_pats fam_tc_name kind -- 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 + ; checkTc (length arg_pats == arity) $ + wrongNumberOfParmsErr arity -- Instantiate with meta kind vars ; fam_arg_kinds <- mapM (const newMetaKindVar) fam_kvs @@ -1011,22 +1039,21 @@ tc_fam_ty_pats fam_tc_name kind -- See Note [Quantifying over family patterns] ; typats <- tcHsTyVarBndrs hs_tvs $ \ _ -> do { kind_checker res_kind - ; tcHsArgTys (quotes (ppr fam_tc_name)) arg_pats arg_kinds } + ; tcHsArgTys (quotes (ppr 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 +tcFamTyPats :: FamTyConShape -> HsWithBndrs [LHsType Name] -- patterns -> (TcKind -> TcM ()) -- kind-checker for RHS -> ([TKVar] -- Kind and type variables -> [TcType] -- Kind and type arguments -> Kind -> TcM a) -> TcM a -tcFamTyPats fam_tc_name kind pats kind_checker thing_inside +tcFamTyPats fam_shape@(name,_,_) pats kind_checker thing_inside = do { (fam_arg_kinds, typats, res_kind) - <- tc_fam_ty_pats fam_tc_name kind pats kind_checker + <- tc_fam_ty_pats fam_shape pats kind_checker ; let all_args = fam_arg_kinds ++ typats -- Find free variables (after zonking) and turn @@ -1040,7 +1067,7 @@ tcFamTyPats fam_tc_name kind pats kind_checker thing_inside ; all_args' <- zonkTcTypeToTypes ze all_args ; res_kind' <- zonkTcTypeToType ze res_kind - ; traceTc "tcFamTyPats" (ppr fam_tc_name) + ; traceTc "tcFamTyPats" (ppr name) -- don't print out too much, as we might be in the knot ; tcExtendTyVarEnv qtkvs' $ thing_inside qtkvs' all_args' res_kind' } @@ -1484,16 +1511,19 @@ checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () checkValidDataCon dflags existential_ok tc con = setSrcSpan (srcLocSpan (getSrcLoc con)) $ addErrCtxt (dataConCtxt con) $ - do { traceTc "checkValidDataCon" (ppr con $$ ppr tc) - - -- Check that the return type of the data constructor + do { -- Check that the return type of the data constructor -- matches the type constructor; eg reject this: -- data T a where { MkT :: Bogus a } -- c.f. Note [Check role annotations in a second pass] -- and Note [Checking GADT return types] - ; let tc_tvs = tyConTyVars tc + let tc_tvs = tyConTyVars tc res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) orig_res_ty = dataConOrigResTy con + ; traceTc "checkValidDataCon" (vcat + [ ppr con, ppr tc, ppr tc_tvs + , ppr res_ty_tmpl <+> dcolon <+> ppr (typeKind res_ty_tmpl) + , ppr orig_res_ty <+> dcolon <+> ppr (typeKind orig_res_ty)]) + ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs) res_ty_tmpl orig_res_ty)) @@ -1578,11 +1608,14 @@ checkValidClass :: Class -> TcM () checkValidClass cls = do { constrained_class_methods <- xoptM Opt_ConstrainedClassMethods ; multi_param_type_classes <- xoptM Opt_MultiParamTypeClasses + ; nullary_type_classes <- xoptM Opt_NullaryTypeClasses ; fundep_classes <- xoptM Opt_FunctionalDependencies -- Check that the class is unary, unless multiparameter type classes - -- are enabled (which allows nullary type classes) - ; checkTc (multi_param_type_classes || arity == 1) + -- are enabled; also recognize deprecated nullary type classes + -- extension (subsumed by multiparameter type classes, Trac #8993) + ; checkTc (multi_param_type_classes || arity == 1 || + (nullary_type_classes && arity == 0)) (classArityErr arity cls) ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls) @@ -1642,15 +1675,10 @@ checkValidClass cls -- in the context of a for-all must mention at least one quantified -- type variable. What a mess! - check_at_defs (fam_tc, defs) + check_at_defs (ATI fam_tc _) = do { traceTc "check-at" (ppr fam_tc $$ ppr (tyConTyVars fam_tc) $$ ppr tyvars) ; checkTc (any (`elem` tyvars) (tyConTyVars fam_tc)) - (noClassTyVarErr cls (ptext (sLit "associated type") <+> quotes (ppr fam_tc))) - - ; tcAddDefaultAssocDeclCtxt (tyConName fam_tc) $ - mapM_ (checkValidTyFamInst mb_clsinfo fam_tc) defs } - - mb_clsinfo = Just (cls, mkVarEnv [ (tv, mkTyVarTy tv) | tv <- tyvars ]) + (noClassTyVarErr cls (ptext (sLit "associated type") <+> quotes (ppr fam_tc))) } checkFamFlag :: Name -> TcM () -- Check that we don't use families without -XTypeFamilies @@ -2007,13 +2035,6 @@ gotten by appying the eq_spec to the univ_tvs of the data con. %************************************************************************ \begin{code} -tcAddDefaultAssocDeclCtxt :: Name -> TcM a -> TcM a -tcAddDefaultAssocDeclCtxt name thing_inside - = addErrCtxt ctxt thing_inside - where - ctxt = hsep [ptext (sLit "In the type synonym instance default declaration for"), - quotes (ppr name)] - tcAddTyFamInstCtxt :: TyFamInstDecl Name -> TcM a -> TcM a tcAddTyFamInstCtxt decl = tcAddFamInstCtxt (ptext (sLit "type instance")) (tyFamInstDeclName decl) @@ -2154,16 +2175,16 @@ 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") +wrongNumberOfParmsErr :: Arity -> SDoc +wrongNumberOfParmsErr max_args + = ptext (sLit "Number of parameters must match family declaration; expected") <+> ppr max_args -wrongNamesInInstGroup :: Name -> Name -> SDoc -wrongNamesInInstGroup first cur - = ptext (sLit "Mismatched type names in closed type family declaration.") $$ - ptext (sLit "First name was") <+> - (ppr first) <> (ptext (sLit "; this one is")) <+> (ppr cur) +wrongTyFamName :: Name -> Name -> SDoc +wrongTyFamName fam_tc_name eqn_tc_name + = hang (ptext (sLit "Mismatched type name in type family instance.")) + 2 (vcat [ ptext (sLit "Expected:") <+> ppr fam_tc_name + , ptext (sLit " Actual:") <+> ppr eqn_tc_name ]) inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc inaccessibleCoAxBranch tc fi diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index 31d522fdeb..262aa519b3 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -121,7 +121,7 @@ synTyConsOfType ty mkSynEdges :: [LTyClDecl Name] -> [(LTyClDecl Name, Name, [Name])] mkSynEdges syn_decls = [ (ldecl, name, nameSetToList fvs) | ldecl@(L _ (SynDecl { tcdLName = L _ name - , tcdFVs = fvs })) <- syn_decls ] + , tcdFVs = fvs })) <- syn_decls ] calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)] calcSynCycles = stronglyConnCompFromEdgedVertices . mkSynEdges @@ -264,7 +264,7 @@ this for all newtypes, we'd get infinite types. So we figure out for each newtype whether it is "recursive", and add a coercion if so. In effect, we are trying to "cut the loops" by identifying a loop-breaker. -2. Avoid infinite unboxing. This is nothing to do with newtypes. +2. Avoid infinite unboxing. This has nothing to do with newtypes. Suppose we have data T = MkT Int T f (MkT x t) = f t diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index a952ce702e..f12ec9d6d5 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -95,8 +95,6 @@ module TcType ( isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool isFFILabelTy, -- :: Type -> Bool - isFFIDotnetTy, -- :: DynFlags -> Type -> Bool - isFFIDotnetObjTy, -- :: Type -> Bool isFFITy, -- :: Type -> Bool isFunPtrTy, -- :: Type -> Bool tcSplitIOType_maybe, -- :: Type -> Maybe Type @@ -175,6 +173,7 @@ import Maybes import ListSetOps import Outputable import FastString +import ErrUtils( Validity(..), isValid ) import Data.IORef import Control.Monad (liftM, ap) @@ -1420,25 +1419,25 @@ tcSplitIOType_maybe ty isFFITy :: Type -> Bool -- True for any TyCon that can possibly be an arg or result of an FFI call -isFFITy ty = checkRepTyCon legalFFITyCon ty +isFFITy ty = isValid (checkRepTyCon legalFFITyCon ty empty) -isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool +isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity -- Checks for valid argument type for a 'foreign import' isFFIArgumentTy dflags safety ty - = checkRepTyCon (legalOutgoingTyCon dflags safety) ty + = checkRepTyCon (legalOutgoingTyCon dflags safety) ty empty -isFFIExternalTy :: Type -> Bool +isFFIExternalTy :: Type -> Validity -- Types that are allowed as arguments of a 'foreign export' -isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty +isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty empty -isFFIImportResultTy :: DynFlags -> Type -> Bool +isFFIImportResultTy :: DynFlags -> Type -> Validity isFFIImportResultTy dflags ty - = checkRepTyCon (legalFIResultTyCon dflags) ty + = checkRepTyCon (legalFIResultTyCon dflags) ty empty -isFFIExportResultTy :: Type -> Bool -isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty +isFFIExportResultTy :: Type -> Validity +isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty empty -isFFIDynTy :: Type -> Type -> Bool +isFFIDynTy :: Type -> Type -> Validity -- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of -- either, and the wrapped function type must be equal to the given type. -- We assume that all types have been run through normalizeFfiType, so we don't @@ -1450,60 +1449,54 @@ isFFIDynTy expected ty | Just (tc, [ty']) <- splitTyConApp_maybe ty , tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey] , eqType ty' expected - = True + = IsValid | otherwise - = False + = NotValid (vcat [ ptext (sLit "Expected: Ptr/FunPtr") <+> pprParendType expected <> comma + , ptext (sLit " Actual:") <+> ppr ty ]) -isFFILabelTy :: Type -> Bool +isFFILabelTy :: Type -> Validity -- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. -isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey] +isFFILabelTy ty = checkRepTyCon ok ty extra + where + ok tc = tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey + extra = ptext (sLit "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)") -isFFIPrimArgumentTy :: DynFlags -> Type -> Bool +isFFIPrimArgumentTy :: DynFlags -> Type -> Validity -- Checks for valid argument type for a 'foreign import prim' -- Currently they must all be simple unlifted types, or the well-known type -- Any, which can be used to pass the address to a Haskell object on the heap to -- the foreign function. isFFIPrimArgumentTy dflags ty - = isAnyTy ty || checkRepTyCon (legalFIPrimArgTyCon dflags) ty + | isAnyTy ty = IsValid + | otherwise = checkRepTyCon (legalFIPrimArgTyCon dflags) ty empty -isFFIPrimResultTy :: DynFlags -> Type -> Bool +isFFIPrimResultTy :: DynFlags -> Type -> Validity -- Checks for valid result type for a 'foreign import prim' -- Currently it must be an unlifted type, including unboxed tuples. isFFIPrimResultTy dflags ty - = checkRepTyCon (legalFIPrimResultTyCon dflags) ty - -isFFIDotnetTy :: DynFlags -> Type -> Bool -isFFIDotnetTy dflags ty - = checkRepTyCon (\ tc -> (legalFIResultTyCon dflags tc || - isFFIDotnetObjTy ty || isStringTy ty)) ty - -- NB: isStringTy used to look through newtypes, but - -- it no longer does so. May need to adjust isFFIDotNetTy - -- if we do want to look through newtypes. - -isFFIDotnetObjTy :: Type -> Bool -isFFIDotnetObjTy ty - = checkRepTyCon check_tc t_ty - where - (_, t_ty) = tcSplitForAllTys ty - check_tc tc = getName tc == objectTyConName + = checkRepTyCon (legalFIPrimResultTyCon dflags) ty empty isFunPtrTy :: Type -> Bool -isFunPtrTy = checkRepTyConKey [funPtrTyConKey] +isFunPtrTy ty = isValid (checkRepTyCon (`hasKey` funPtrTyConKey) ty empty) -- normaliseFfiType gets run before checkRepTyCon, so we don't -- need to worry about looking through newtypes or type functions -- here; that's already been taken care of. -checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool -checkRepTyCon check_tc ty - | Just (tc, _) <- splitTyConApp_maybe ty - = check_tc tc - | otherwise - = False - -checkRepTyConKey :: [Unique] -> Type -> Bool --- Like checkRepTyCon, but just looks at the TyCon key -checkRepTyConKey keys - = checkRepTyCon (\tc -> tyConUnique tc `elem` keys) +checkRepTyCon :: (TyCon -> Bool) -> Type -> SDoc -> Validity +checkRepTyCon check_tc ty extra + = case splitTyConApp_maybe ty of + Just (tc, tys) + | isNewTyCon tc -> NotValid (hang msg 2 (mk_nt_reason tc tys $$ nt_fix)) + | check_tc tc -> IsValid + | otherwise -> NotValid (msg $$ extra) + Nothing -> NotValid (quotes (ppr ty) <+> ptext (sLit "is not a data type") $$ extra) + where + msg = quotes (ppr ty) <+> ptext (sLit "cannot be marshalled in a foreign call") + mk_nt_reason tc tys + | null tys = ptext (sLit "because its data construtor is not in scope") + | otherwise = ptext (sLit "because the data construtor for") + <+> quotes (ppr tc) <+> ptext (sLit "is not in scope") + nt_fix = ptext (sLit "Possible fix: import the data constructor to bring it into scope") \end{code} Note [Foreign import dynamic] @@ -1550,21 +1543,25 @@ legalOutgoingTyCon dflags _ tc legalFFITyCon :: TyCon -> Bool -- True for any TyCon that can possibly be an arg or result of an FFI call legalFFITyCon tc - = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon + | isUnLiftedTyCon tc = True + | tc == unitTyCon = True + | otherwise = boxedMarshalableTyCon tc marshalableTyCon :: DynFlags -> TyCon -> Bool marshalableTyCon dflags tc - = (xopt Opt_UnliftedFFITypes dflags + | (xopt Opt_UnliftedFFITypes dflags && isUnLiftedTyCon tc && not (isUnboxedTupleTyCon tc) && case tyConPrimRep tc of -- Note [Marshalling VoidRep] VoidRep -> False _ -> True) - || boxedMarshalableTyCon tc + = True + | otherwise + = boxedMarshalableTyCon tc boxedMarshalableTyCon :: TyCon -> Bool boxedMarshalableTyCon tc - = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey + | getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey , int32TyConKey, int64TyConKey , wordTyConKey, word8TyConKey, word16TyConKey , word32TyConKey, word64TyConKey @@ -1574,26 +1571,35 @@ boxedMarshalableTyCon tc , stablePtrTyConKey , boolTyConKey ] + = True + + | otherwise = False legalFIPrimArgTyCon :: DynFlags -> TyCon -> Bool -- Check args of 'foreign import prim', only allow simple unlifted types. -- Strictly speaking it is unnecessary to ban unboxed tuples here since -- currently they're of the wrong kind to use in function args anyway. legalFIPrimArgTyCon dflags tc - = xopt Opt_UnliftedFFITypes dflags + | xopt Opt_UnliftedFFITypes dflags && isUnLiftedTyCon tc && not (isUnboxedTupleTyCon tc) + = True + | otherwise + = False legalFIPrimResultTyCon :: DynFlags -> TyCon -> Bool -- Check result type of 'foreign import prim'. Allow simple unlifted -- types and also unboxed tuple result types '... -> (# , , #)' legalFIPrimResultTyCon dflags tc - = xopt Opt_UnliftedFFITypes dflags + | xopt Opt_UnliftedFFITypes dflags && isUnLiftedTyCon tc && (isUnboxedTupleTyCon tc || case tyConPrimRep tc of -- Note [Marshalling VoidRep] VoidRep -> False _ -> True) + = True + | otherwise + = False \end{code} Note [Marshalling VoidRep] diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs index 8f6a773804..f8357825a7 100644 --- a/compiler/typecheck/TcValidity.lhs +++ b/compiler/typecheck/TcValidity.lhs @@ -46,7 +46,6 @@ import ListSetOps import SrcLoc import Outputable import FastString -import BasicTypes ( Arity ) import Control.Monad import Data.Maybe @@ -776,7 +775,9 @@ checkValidInstHead ctxt clas cls_args all tcInstHeadTyAppAllTyVars ty_args) (instTypeErr clas cls_args head_type_args_tyvars_msg) ; checkTc (xopt Opt_MultiParamTypeClasses dflags || - length ty_args == 1) -- Only count type arguments + length ty_args == 1 || -- Only count type arguments + (xopt Opt_NullaryTypeClasses dflags && + null ty_args)) (instTypeErr clas cls_args head_one_type_msg) } -- May not contain type family applications @@ -878,8 +879,8 @@ checkValidInstance ctxt hs_type ty else checkInstTermination inst_tys theta ; case (checkInstCoverage undecidable_ok clas theta inst_tys) of - Nothing -> return () -- Check succeeded - Just msg -> addErrTc (instTypeErr clas inst_tys msg) + IsValid -> return () -- Check succeeded + NotValid msg -> addErrTc (instTypeErr clas inst_tys msg) ; return (tvs, theta, clas, inst_tys) } @@ -1113,7 +1114,14 @@ checkValidTyFamInst mb_clsinfo fam_tc = setSrcSpan loc $ do { checkValidFamPats fam_tc tvs typats - -- The right-hand side is a tau type + -- The argument patterns, and RHS, are all boxed tau types + -- E.g Reject type family F (a :: k1) :: k2 + -- type instance F (forall a. a->a) = ... + -- type instance F Int# = ... + -- type instance F Int = forall a. a->a + -- type instance F Int = Int# + -- See Trac #9357 + ; mapM_ checkValidMonoType typats ; checkValidMonoType rhs -- We have a decidable instance unless otherwise permitted @@ -1163,26 +1171,18 @@ checkValidFamPats :: TyCon -> [TyVar] -> [Type] -> TcM () -- type instance F (T a) = a -- c) Have the right number of patterns checkValidFamPats fam_tc tvs 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 + = ASSERT( length ty_pats == tyConArity fam_tc ) + -- 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) + -- But this is checked at the time the axiom is created + do { 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. --- checkTyFamFreeness :: Type -> TcM () checkTyFamFreeness ty = checkTc (isTyFamFree ty) $ diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs index 29df06572b..9863b8d98f 100644 --- a/compiler/types/Class.lhs +++ b/compiler/types/Class.lhs @@ -17,7 +17,7 @@ The @Class@ datatype module Class ( Class, ClassOpItem, DefMeth (..), - ClassATItem, + ClassATItem(..), ClassMinimalDef, defMethSpecOfDefMeth, @@ -32,8 +32,7 @@ module Class ( #include "HsVersions.h" import {-# SOURCE #-} TyCon ( TyCon, tyConName, tyConUnique ) -import {-# SOURCE #-} TypeRep ( PredType ) -import CoAxiom +import {-# SOURCE #-} TypeRep ( Type, PredType ) import Var import Name import BasicTypes @@ -100,10 +99,10 @@ data DefMeth = NoDefMeth -- No default method | GenDefMeth Name -- A generic default method deriving Eq -type ClassATItem = (TyCon, -- See Note [Associated type tyvar names] - [CoAxBranch]) -- Default associated types from these templates - -- We can have more than one default per type; see - -- Note [Associated type defaults] in TcTyClsDecls +data ClassATItem + = ATI TyCon -- See Note [Associated type tyvar names] + (Maybe Type) -- Default associated type (if any) from this template + -- Note [Associated type defaults] type ClassMinimalDef = BooleanFormula Name -- Required methods @@ -115,9 +114,39 @@ defMethSpecOfDefMeth meth NoDefMeth -> NoDM DefMeth _ -> VanillaDM GenDefMeth _ -> GenericDM - \end{code} +Note [Associated type defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The following is an example of associated type defaults: + class C a where + data D a r + + type F x a b :: * + type F p q r = (p,q)->r -- Default + +Note that + + * The TyCons for the associated types *share type variables* with the + class, so that we can tell which argument positions should be + instantiated in an instance decl. (The first for 'D', the second + for 'F'.) + + * We can have default definitions only for *type* families, + not data families + + * In the default decl, the "patterns" should all be type variables, + but (in the source language) they don't need to be the same as in + the 'type' decl signature or the class. It's more like a + free-standing 'type instance' declaration. + + * HOWEVER, in the internal ClassATItem we rename the RHS to match the + tyConTyVars of the family TyCon. So in the example above we'd get + a ClassATItem of + ATI F ((x,a) -> b) + So the tyConTyVars of the family TyCon bind the free vars of + the default Type rhs + The @mkClass@ function fills in the indirect superclasses. \begin{code} @@ -198,7 +227,7 @@ classOpItems = classOpStuff classATs :: Class -> [TyCon] classATs (Class { classATStuff = at_stuff }) - = [tc | (tc, _) <- at_stuff] + = [tc | ATI tc _ <- at_stuff] classATItems :: Class -> [ClassATItem] classATItems = classATStuff diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index b33eae9e02..38f38ed50b 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -18,7 +18,7 @@ module Coercion ( -- ** Functions over coercions coVarKind, coVarRole, coercionType, coercionKind, coercionKinds, isReflCo, - isReflCo_maybe, coercionRole, + isReflCo_maybe, coercionRole, coercionKindRole, mkCoercionType, -- ** Constructing coercions @@ -104,8 +104,10 @@ import PrelNames ( funTyConKey, eqPrimTyConKey, eqReprPrimTyConKey ) import Control.Applicative import Data.Traversable (traverse, sequenceA) import FastString +import ListSetOps import qualified Data.Data as Data hiding ( TyCon ) +import Control.Arrow ( first ) \end{code} %************************************************************************ @@ -1792,10 +1794,23 @@ seqCos (co:cos) = seqCo co `seq` seqCos cos %* * %************************************************************************ +Note [Computing a coercion kind and role] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To compute a coercion's kind is straightforward: see coercionKind. +But to compute a coercion's role, in the case for NthCo we need +its kind as well. So if we have two separate functions (one for kinds +and one for roles) we can get exponentially bad behaviour, since each +NthCo node makes a separate call to coercionKind, which traverses the +sub-tree again. This was part of the problem in Trac #9233. + +Solution: compute both together; hence coercionKindRole. We keep a +separate coercionKind function because it's a bit more efficient if +the kind is all you want. + \begin{code} coercionType :: Coercion -> Type -coercionType co = case coercionKind co of - Pair ty1 ty2 -> mkCoercionType (coercionRole co) ty1 ty2 +coercionType co = case coercionKindRole co of + (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2 ------------------ -- | If it is the case that @@ -1827,11 +1842,10 @@ coercionKind co = go co go (InstCo aco ty) = go_app aco [ty] go (SubCo co) = go co go (AxiomRuleCo ax tys cos) = - case coaxrProves ax tys (map coercionKind cos) of + case coaxrProves ax tys (map go cos) of Just res -> res Nothing -> panic "coercionKind: Malformed coercion" - go_app :: Coercion -> [Type] -> Pair Type -- Collect up all the arguments and apply all at once -- See Note [Nested InstCos] @@ -1842,25 +1856,54 @@ coercionKind co = go co coercionKinds :: [Coercion] -> Pair [Type] coercionKinds tys = sequenceA $ map coercionKind tys -coercionRole :: Coercion -> Role -coercionRole = go +-- | Get a coercion's kind and role. +-- Why both at once? See Note [Computing a coercion kind and role] +coercionKindRole :: Coercion -> (Pair Type, Role) +coercionKindRole = 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 - go (AxiomRuleCo c _ _) = coaxrRole c + go (Refl r ty) = (Pair ty ty, r) + go (TyConAppCo r tc cos) + = (mkTyConApp tc <$> (sequenceA $ map coercionKind cos), r) + go (AppCo co1 co2) + = let (tys1, r1) = go co1 in + (mkAppTy <$> tys1 <*> coercionKind co2, r1) + go (ForAllCo tv co) + = let (tys, r) = go co in + (mkForAllTy tv <$> tys, r) + go (CoVarCo cv) = (toPair $ coVarKind cv, coVarRole cv) + go co@(AxiomInstCo ax _ _) = (coercionKind co, coAxiomRole ax) + go (UnivCo r ty1 ty2) = (Pair ty1 ty2, r) + go (SymCo co) = first swap $ go co + go (TransCo co1 co2) + = let (tys1, r) = go co1 in + (Pair (pFst tys1) (pSnd $ coercionKind co2), r) + go (NthCo d co) + = let (Pair t1 t2, r) = go co + (tc1, args1) = splitTyConApp t1 + (_tc2, args2) = splitTyConApp t2 + in + ASSERT( tc1 == _tc2 ) + ((`getNth` d) <$> Pair args1 args2, nthRole r tc1 d) + go co@(LRCo {}) = (coercionKind co, Nominal) + go (InstCo co ty) = go_app co [ty] + go (SubCo co) = (coercionKind co, Representational) + go co@(AxiomRuleCo ax _ _) = (coercionKind co, coaxrRole ax) + + go_app :: Coercion -> [Type] -> (Pair Type, Role) + -- Collect up all the arguments and apply all at once + -- See Note [Nested InstCos] + go_app (InstCo co ty) tys = go_app co (ty:tys) + go_app co tys + = let (pair, r) = go co in + ((`applyTys` tys) <$> pair, r) + +-- | Retrieve the role from a coercion. +coercionRole :: Coercion -> Role +coercionRole = snd . coercionKindRole + -- There's not a better way to do this, because NthCo needs the *kind* + -- and role of its argument. Luckily, laziness should generally avoid + -- the need for computing kinds in other cases. + \end{code} Note [Nested InstCos] diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index fcf7cb443f..1308984f4f 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -46,7 +46,6 @@ import Coercion import CoAxiom import VarSet import VarEnv -import Module( isInteractiveModule ) import Name import UniqFM import Outputable @@ -381,23 +380,21 @@ identicalFamInst :: FamInst -> FamInst -> Bool -- Same LHS, *and* both instances are on the interactive command line -- Used for overriding in GHCi identicalFamInst (FamInst { fi_axiom = ax1 }) (FamInst { fi_axiom = ax2 }) - = isInteractiveModule (nameModule (coAxiomName ax1)) - && isInteractiveModule (nameModule (coAxiomName ax2)) - && coAxiomTyCon ax1 == coAxiomTyCon ax2 + = coAxiomTyCon ax1 == coAxiomTyCon ax2 && brListLength brs1 == brListLength brs2 - && and (brListZipWith identical_ax_branch brs1 brs2) - where brs1 = coAxiomBranches ax1 - brs2 = coAxiomBranches ax2 - identical_ax_branch br1 br2 - = length tvs1 == length tvs2 - && length lhs1 == length lhs2 - && and (zipWith (eqTypeX rn_env) lhs1 lhs2) - where - tvs1 = coAxBranchTyVars br1 - tvs2 = coAxBranchTyVars br2 - lhs1 = coAxBranchLHS br1 - lhs2 = coAxBranchLHS br2 - rn_env = rnBndrs2 (mkRnEnv2 emptyInScopeSet) tvs1 tvs2 + && and (brListZipWith identical_branch brs1 brs2) + where + brs1 = coAxiomBranches ax1 + brs2 = coAxiomBranches ax2 + + identical_branch br1 br2 + = isJust (tcMatchTys tvs1 lhs1 lhs2) + && isJust (tcMatchTys tvs2 lhs2 lhs1) + where + tvs1 = mkVarSet (coAxBranchTyVars br1) + tvs2 = mkVarSet (coAxBranchTyVars br2) + lhs1 = coAxBranchLHS br1 + lhs2 = coAxBranchLHS br2 \end{code} %************************************************************************ @@ -644,7 +641,7 @@ lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom }) (ppr tpl_tvs <+> ppr tpl_tys) ) -- Unification will break badly if the variables overlap -- They shouldn't because we allocate separate uniques for them - if compatibleBranches (coAxiomSingleBranch old_axiom) (new_branch) + if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch then Nothing else Just noSubst -- Note [Family instance overlap conflicts] @@ -672,7 +669,7 @@ Note [Family instance overlap conflicts] -- Might be a one-way match or a unifier type MatchFun = FamInst -- The FamInst template -> TyVarSet -> [Type] -- fi_tvs, fi_tys of that FamInst - -> [Type] -- Target to match against + -> [Type] -- Target to match against -> Maybe TvSubst lookup_fam_inst_env' -- The worker, local to this module @@ -732,9 +729,9 @@ lookup_fam_inst_env -- The worker, local to this module -- Precondition: the tycon is saturated (or over-saturated) -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 +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} @@ -750,16 +747,18 @@ which you can't do in Haskell!): 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. +We handle data families and type families separately here: + + * For type families, 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 family instances, though, we need to re-split for each + instance, because the breakdown might be different for each + instance. Why? Because of eta reduction; see Note [Eta reduction + for data family axioms] \begin{code} diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 176f189922..708fef1cfe 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -10,12 +10,13 @@ The bits common to TcInstDcls and TcDeriv. {-# LANGUAGE CPP, DeriveDataTypeable #-} module InstEnv ( - DFunId, OverlapFlag(..), InstMatch, ClsInstLookupResult, - ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, + DFunId, InstMatch, ClsInstLookupResult, + OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, + ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, instanceHead, instanceSig, mkLocalInstance, mkImportedInstance, instanceDFunId, tidyClsInstDFun, instanceRoughTcs, - InstEnv, emptyInstEnv, extendInstEnv, overwriteInstEnv, + InstEnv, emptyInstEnv, extendInstEnv, deleteFromInstEnv, identicalInstHead, extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv', lookupInstEnv, instEnvElts, classInstances, orphNamesOfClsInst, instanceBindFun, instanceCantMatch, roughMatchTcs @@ -159,7 +160,8 @@ pprInstance :: ClsInst -> SDoc -- Prints the ClsInst as an instance declaration pprInstance ispec = hang (pprInstanceHdr ispec) - 2 (ptext (sLit "--") <+> pprDefinedAt (getName ispec)) + 2 (vcat [ ptext (sLit "--") <+> pprDefinedAt (getName ispec) + , ifPprDebug (ppr (is_dfun ispec)) ]) -- * pprInstanceHdr is used in VStudio to populate the ClassView tree pprInstanceHdr :: ClsInst -> SDoc @@ -419,26 +421,22 @@ extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) where add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts) -overwriteInstEnv :: InstEnv -> ClsInst -> InstEnv -overwriteInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm, is_tys = tys }) - = addToUFM_C add inst_env cls_nm (ClsIE [ins_item]) +deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv +deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) + = adjustUFM adjust inst_env cls_nm where - add (ClsIE cur_insts) _ = ClsIE (replaceInst cur_insts) - - rough_tcs = roughMatchTcs tys - replaceInst [] = [ins_item] - replaceInst (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs - , is_tys = tpl_tys }) : rest) - -- Fast check for no match, uses the "rough match" fields - | instanceCantMatch rough_tcs mb_tcs - = item : replaceInst rest - - | let tpl_tv_set = mkVarSet tpl_tvs - , Just _ <- tcMatchTys tpl_tv_set tpl_tys tys - = ins_item : rest - - | otherwise - = item : replaceInst rest + adjust (ClsIE items) = ClsIE (filterOut (identicalInstHead ins_item) items) + +identicalInstHead :: ClsInst -> ClsInst -> Bool +-- ^ True when when the instance heads are the same +-- e.g. both are Eq [(a,b)] +-- Obviously should be insenstive to alpha-renaming +identicalInstHead (ClsInst { is_cls_nm = cls_nm1, is_tcs = rough1, is_tvs = tvs1, is_tys = tys1 }) + (ClsInst { is_cls_nm = cls_nm2, is_tcs = rough2, is_tvs = tvs2, is_tys = tys2 }) + = cls_nm1 == cls_nm2 + && not (instanceCantMatch rough1 rough2) -- Fast check for no match, uses the "rough match" fields + && isJust (tcMatchTys (mkVarSet tvs1) tys1 tys2) + && isJust (tcMatchTys (mkVarSet tvs2) tys2 tys1) \end{code} @@ -452,6 +450,54 @@ overwriteInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm, is_tys = tys } the env is kept ordered, the first match must be the only one. The thing we are looking up can have an arbitrary "flexi" part. +Note [Rules for instance lookup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These functions implement the carefully-written rules in the user +manual section on "overlapping instances". At risk of duplication, +here are the rules. If the rules change, change this text and the +user manual simultaneously. The link may be this: +http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-overlap + +The willingness to be overlapped or incoherent is a property of the +instance declaration itself, controlled as follows: + + * An instance is "incoherent" + if it has an INCOHERENT pragma, or + if it appears in a module compiled with -XIncoherentInstances. + + * An instance is "overlappable" + if it has an OVERLAPPABLE or OVERLAPS pragma, or + if it appears in a module compiled with -XOverlappingInstances, or + if the instance is incoherent. + + * An instance is "overlapping" + if it has an OVERLAPPING or OVERLAPS pragma, or + if it appears in a module compiled with -XOverlappingInstances, or + if the instance is incoherent. + compiled with -XOverlappingInstances. + +Now suppose that, in some client module, we are searching for an instance +of the target constraint (C ty1 .. tyn). The search works like this. + + * Find all instances I that match the target constraint; that is, the + target constraint is a substitution instance of I. These instance + declarations are the candidates. + + * Find all non-candidate instances that unify with the target + constraint. Such non-candidates instances might match when the + target constraint is further instantiated. If all of them are + incoherent, proceed; if not, the search fails. + + * Eliminate any candidate IX for which both of the following hold: + * There is another candidate IY that is strictly more specific; + that is, IY is a substitution instance of IX but not vice versa. + + * Either IX is overlappable or IY is overlapping. + + * If only one candidate remains, pick it. Otherwise if all remaining + candidates are incoherent, pick an arbitrary candidate. Otherwise fail. + + \begin{code} type DFunInstType = Maybe Type -- Just ty => Instantiate with this type @@ -535,8 +581,8 @@ lookupInstEnv' ie cls tys = find ((item, map (lookup_tv subst) tpl_tvs) : ms) us rest -- Does not match, so next check whether the things unify - -- See Note [Overlapping instances] and Note [Incoherent Instances] - | Incoherent _ <- oflag + -- See Note [Overlapping instances] and Note [Incoherent instances] + | Incoherent <- overlapMode oflag = find ms us rest | otherwise @@ -565,23 +611,30 @@ lookupInstEnv' ie cls tys lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env -> Class -> [Type] -- What we are looking for -> ClsInstLookupResult - +-- ^ See Note [Rules for instance lookup] lookupInstEnv (pkg_ie, home_ie) cls tys - = (safe_matches, all_unifs, safe_fail) + = (final_matches, final_unifs, safe_fail) where (home_matches, home_unifs) = lookupInstEnv' home_ie cls tys (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie cls tys all_matches = home_matches ++ pkg_matches all_unifs = home_unifs ++ pkg_unifs pruned_matches = foldr insert_overlapping [] all_matches - (safe_matches, safe_fail) = if length pruned_matches == 1 - then check_safe (head pruned_matches) all_matches - else (pruned_matches, False) -- Even if the unifs is non-empty (an error situation) -- we still prune the matches, so that the error message isn't -- misleading (complaining of multiple matches when some should be -- overlapped away) + (final_matches, safe_fail) + = case pruned_matches of + [match] -> check_safe match all_matches + _ -> (pruned_matches, False) + + -- If the selected match is incoherent, discard all unifiers + final_unifs = case final_matches of + (m:_) | is_incoherent m -> [] + _ -> all_unifs + -- NOTE [Safe Haskell isSafeOverlap] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- We restrict code compiled in 'Safe' mode from overriding code @@ -605,7 +658,7 @@ lookupInstEnv (pkg_ie, home_ie) cls tys if inSameMod x then go bad unchecked else go (i:bad) unchecked - + inSameMod b = let na = getName $ getName inst la = isInternalName na @@ -614,64 +667,72 @@ lookupInstEnv (pkg_ie, home_ie) cls tys in (la && lb) || (nameModule na == nameModule nb) --------------- +is_incoherent :: InstMatch -> Bool +is_incoherent (inst, _) = overlapMode (is_flag inst) == Incoherent + --------------- insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch] --- Add a new solution, knocking out strictly less specific ones +-- ^ Add a new solution, knocking out strictly less specific ones +-- See Note [Rules for instance lookup] insert_overlapping new_item [] = [new_item] -insert_overlapping new_item (item:items) - | new_beats_old && old_beats_new = item : insert_overlapping new_item items - -- Duplicate => keep both for error report - | new_beats_old = insert_overlapping new_item items - -- Keep new one - | old_beats_new = item : items - -- Keep old one - | incoherent new_item = item : items -- note [Incoherent instances] - -- Keep old one - | incoherent item = new_item : items - -- Keep new one - | otherwise = item : insert_overlapping new_item items - -- Keep both +insert_overlapping new_item (old_item : old_items) + | new_beats_old -- New strictly overrides old + , not old_beats_new + , new_item `can_override` old_item + = insert_overlapping new_item old_items + + | old_beats_new -- Old strictly overrides new + , not new_beats_old + , old_item `can_override` new_item + = old_item : old_items + + -- Discard incoherent instances; see Note [Incoherent instances] + | is_incoherent old_item -- Old is incoherent; discard it + = insert_overlapping new_item old_items + | is_incoherent new_item -- New is incoherent; discard it + = old_item : old_items + + -- Equal or incomparable, and neither is incoherent; keep both + | otherwise + = old_item : insert_overlapping new_item old_items where - new_beats_old = new_item `beats` item - old_beats_new = item `beats` new_item - - incoherent (inst, _) = case is_flag inst of Incoherent _ -> True - _ -> False - - (instA, _) `beats` (instB, _) - = overlap_ok && - isJust (tcMatchTys (mkVarSet (is_tvs instB)) (is_tys instB) (is_tys instA)) - -- A beats B if A is more specific than B, - -- (ie. if B can be instantiated to match A) - -- and overlap is permitted - where - -- Overlap permitted if *either* instance permits overlap - -- This is a change (Trac #3877, Dec 10). It used to - -- require that instB (the less specific one) permitted overlap. - overlap_ok = case (is_flag instA, is_flag instB) of - (NoOverlap _, NoOverlap _) -> False - _ -> True + + new_beats_old = new_item `more_specific_than` old_item + old_beats_new = old_item `more_specific_than` new_item + + -- `instB` can be instantiated to match `instA` + -- or the two are equal + (instA,_) `more_specific_than` (instB,_) + = isJust (tcMatchTys (mkVarSet (is_tvs instB)) + (is_tys instB) (is_tys instA)) + + (instA, _) `can_override` (instB, _) + = hasOverlappingFlag (overlapMode (is_flag instA)) + || hasOverlappableFlag (overlapMode (is_flag instB)) + -- Overlap permitted if either the more specific instance + -- is marked as overlapping, or the more general one is + -- marked as overlappable. + -- Latest change described in: Trac #9242. + -- Previous change: Trac #3877, Dec 10. \end{code} Note [Incoherent instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -For some classes, the choise of a particular instance does not matter, any one +For some classes, the choice of a particular instance does not matter, any one is good. E.g. consider class D a b where { opD :: a -> b -> String } instance D Int b where ... instance D a Int where ... - g (x::Int) = opD x x + g (x::Int) = opD x x -- Wanted: D Int Int For such classes this should work (without having to add an "instance D Int Int", and using -XOverlappingInstances, which would then work). This is what -XIncoherentInstances is for: Telling GHC "I don't care which instance you use; if you can use one, use it." - -Should this logic only work when all candidates have the incoherent flag, or +Should this logic only work when *all* candidates have the incoherent flag, or even when all but one have it? The right choice is the latter, which can be justified by comparing the behaviour with how -XIncoherentInstances worked when it was only about the unify-check (note [Overlapping instances]): @@ -682,7 +743,7 @@ Example: instance [incoherent] [Int] b c instance [incoherent] C a Int c Thanks to the incoherent flags, - foo :: ([a],b,Int) + [Wanted] C [a] b Int works: Only instance one matches, the others just unify, but are marked incoherent. diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index ed68aeab2f..5e51e08967 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -4,19 +4,12 @@ \begin{code} {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Kind ( -- * Main data type SuperKind, Kind, typeKind, - -- Kinds - anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, + -- Kinds + anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, -- Kind constructors... @@ -24,9 +17,9 @@ module Kind ( unliftedTypeKindTyCon, constraintKindTyCon, -- Super Kinds - superKind, superKindTyCon, - - pprKind, pprParendKind, + superKind, superKindTyCon, + + pprKind, pprParendKind, -- ** Deconstructing Kinds kindAppResult, synTyConResKind, @@ -42,7 +35,7 @@ module Kind ( okArrowArgKind, okArrowResultKind, isSubOpenTypeKind, isSubOpenTypeKindKey, - isSubKind, isSubKindCon, + isSubKind, isSubKindCon, tcIsSubKind, tcIsSubKindCon, defaultKind, defaultKind_maybe, @@ -67,33 +60,33 @@ import FastString \end{code} %************************************************************************ -%* * - Functions over Kinds -%* * +%* * + Functions over Kinds +%* * %************************************************************************ Note [Kind Constraint and kind *] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The kind Constraint is the kind of classes and other type constraints. -The special thing about types of kind Constraint is that +The special thing about types of kind Constraint is that * They are displayed with double arrow: f :: Ord a => a -> a * They are implicitly instantiated at call sites; so the type inference engine inserts an extra argument of type (Ord a) at every call site to f. -However, once type inference is over, there is *no* distinction between +However, once type inference is over, there is *no* distinction between Constraint and *. Indeed we can have coercions between the two. Consider class C a where op :: a -> a -For this single-method class we may generate a newtype, which in turn +For this single-method class we may generate a newtype, which in turn generates an axiom witnessing Ord a ~ (a -> a) so on the left we have Constraint, and on the right we have *. See Trac #7451. Bottom line: although '*' and 'Constraint' are distinct TyCons, with -distinct uniques, they are treated as equal at all times except +distinct uniques, they are treated as equal at all times except during type inference. Hence cmpTc treats them as equal. \begin{code} @@ -129,9 +122,9 @@ splitKindFunTysN n (FunTy a r) = case splitKindFunTysN (n-1) r of (as, k) -> (a:as, k) splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k) --- | Find the result 'Kind' of a type synonym, +-- | Find the result 'Kind' of a type synonym, -- after applying it to its 'arity' number of type variables --- Actually this function works fine on data types too, +-- Actually this function works fine on data types too, -- but they'd always return '*', so we never need to ask synTyConResKind :: TyCon -> Kind synTyConResKind tycon = kindAppResult (ptext (sLit "synTyConResKind") <+> ppr tycon) @@ -212,7 +205,7 @@ isSubOpenTypeKindKey uniq || 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 *] + -- See Note [Kind Constraint and kind *] -- | Is this a kind (i.e. a type-of-types)? isKind :: Kind -> Bool @@ -243,7 +236,7 @@ isSubKindCon :: TyCon -> TyCon -> Bool -- See Note [GHC Formalism] in coreSyn/CoreLint.lhs isSubKindCon kc1 kc2 | kc1 == kc2 = True - | isOpenTypeKindCon kc2 = isSubOpenTypeKindCon kc1 + | isOpenTypeKindCon kc2 = isSubOpenTypeKindCon kc1 | isConstraintKindCon kc1 = isLiftedTypeKindCon kc2 | isLiftedTypeKindCon kc1 = isConstraintKindCon kc2 -- See Note [Kind Constraint and kind *] @@ -287,11 +280,11 @@ defaultKind_maybe :: Kind -> Maybe Kind -- simple (* or *->* etc). So generic type variables (other than -- built-in constants like 'error') always have simple kinds. This is important; -- consider --- f x = True +-- f x = True -- We want f to get type --- f :: forall (a::*). a -> Bool --- Not --- f :: forall (a::ArgKind). a -> Bool +-- f :: forall (a::*). a -> Bool +-- Not +-- f :: forall (a::ArgKind). a -> Bool -- because that would allow a call like (f 3#) as well as (f True), -- and the calling conventions differ. -- This defaulting is done in TcMType.zonkTcTyVarBndr. diff --git a/compiler/types/OptCoercion.lhs b/compiler/types/OptCoercion.lhs index dc7ab781ff..6eccf42588 100644 --- a/compiler/types/OptCoercion.lhs +++ b/compiler/types/OptCoercion.lhs @@ -27,7 +27,6 @@ import VarEnv import StaticFlags ( opt_NoOptCoercion ) import Outputable import Pair -import Maybes import FastString import Util import Unify @@ -59,13 +58,29 @@ because now the co_B1 (which is really free) has been captured, and subsequent substitutions will go wrong. That's why we can't use mkCoPredTy in the ForAll case, where this note appears. +Note [Optimising coercion optimisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Looking up a coercion's role or kind is linear in the size of the +coercion. Thus, doing this repeatedly during the recursive descent +of coercion optimisation is disastrous. We must be careful to avoid +doing this if at all possible. + +Because it is generally easy to know a coercion's components' roles +from the role of the outer coercion, we pass down the known role of +the input in the algorithm below. We also keep functions opt_co2 +and opt_co3 separate from opt_co4, so that the former two do Phantom +checks that opt_co4 can avoid. This is a big win because Phantom coercions +rarely appear within non-phantom coercions -- only in some TyConAppCos +and some AxiomInstCos. We handle these cases specially by calling +opt_co2. + \begin{code} optCoercion :: CvSubst -> Coercion -> NormalCo -- ^ optCoercion applies a substitution to a coercion, -- *and* optimises it to reduce its size optCoercion env co | opt_NoOptCoercion = substCo env co - | otherwise = opt_co env False Nothing co + | otherwise = opt_co1 env False co type NormalCo = Coercion -- Invariants: @@ -76,13 +91,17 @@ type NormalCo = Coercion 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' +-- | Do we apply a @sym@ to the result? +type SymFlag = Bool + +-- | Do we force the result to be representational? +type ReprFlag = Bool + +-- | Optimize a coercion, making no assumptions. +opt_co1 :: CvSubst + -> SymFlag + -> Coercion -> NormalCo +opt_co1 env sym co = opt_co2 env sym (coercionRole co) co {- opt_co env sym co = pprTrace "opt_co {" (ppr sym <+> ppr co $$ ppr env) $ @@ -108,111 +127,123 @@ opt_co env sym co | otherwise = substCo env 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) +-- See Note [Optimising coercion optimisation] +-- | Optimize a coercion, knowing the coercion's role. No other assumptions. +opt_co2 :: CvSubst + -> SymFlag + -> Role -- ^ The role of the input coercion + -> Coercion -> NormalCo +opt_co2 env sym Phantom co = opt_phantom env sym co +opt_co2 env sym r co = opt_co3 env sym Nothing r co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a coercion, knowing the coercion's non-Phantom role. +opt_co3 :: CvSubst -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo +opt_co3 env sym (Just Phantom) _ co = opt_phantom env sym co +opt_co3 env sym (Just Representational) r co = opt_co4 env sym True r co + -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore +opt_co3 env sym _ r co = opt_co4 env sym False r co + + +-- See Note [Optimising coercion optimisation] +-- | Optimize a non-phantom coercion. +opt_co4 :: CvSubst -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo + +opt_co4 env _ rep r (Refl _r ty) + = ASSERT( r == _r ) + Refl (chooseRole rep r) (substTy env ty) + +opt_co4 env sym rep r (SymCo co) = opt_co4 env (not sym) rep r co + +opt_co4 env sym rep r g@(TyConAppCo _r tc cos) + = ASSERT( r == _r ) + case (rep, r) of + (True, Nominal) -> + mkTyConAppCo Representational tc + (zipWith3 (opt_co3 env sym) + (map Just (tyConRolesX Representational tc)) + (repeat Nominal) + cos) + (False, Nominal) -> + mkTyConAppCo Nominal tc (map (opt_co4 env sym False Nominal) cos) + (_, Representational) -> + -- must use opt_co2 here, because some roles may be P + -- See Note [Optimising coercion optimisation] + mkTyConAppCo r tc (zipWith (opt_co2 env sym) + (tyConRolesX r tc) -- the current roles + cos) + (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) + +opt_co4 env sym rep r (AppCo co1 co2) = mkAppCo (opt_co4 env sym rep r co1) + (opt_co4 env sym False Nominal co2) +opt_co4 env sym rep r (ForAllCo tv co) = case substTyVarBndr env tv of - (env', tv') -> mkForAllCo tv' (opt_co env' sym mrole co) + (env', tv') -> mkForAllCo tv' (opt_co4 env' sym rep r co) -- Use the "mk" functions to check for nested Refls -opt_co' env sym mrole (CoVarCo cv) +opt_co4 env sym rep r (CoVarCo cv) | Just co <- lookupCoVar env cv - = opt_co (zapCvSubstEnv env) sym mrole co + = opt_co4 (zapCvSubstEnv env) sym rep r co | Just cv1 <- lookupInScope (getCvInScope env) cv - = ASSERT( isCoVar cv1 ) wrapRole mrole cv_role $ wrapSym sym (CoVarCo cv1) + = ASSERT( isCoVar cv1 ) wrapRole rep r $ 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 ) - wrapRole mrole cv_role $ wrapSym sym (CoVarCo cv) - where cv_role = coVarRole cv + wrapRole rep r $ wrapSym sym (CoVarCo cv) -opt_co' env sym mrole (AxiomInstCo con ind cos) +opt_co4 env sym rep r (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) !! - = wrapRole mrole (coAxiomRole con) $ + = ASSERT( r == coAxiomRole con ) + wrapRole rep (coAxiomRole con) $ wrapSym sym $ - AxiomInstCo con ind (map (opt_co env False Nothing) cos) + -- some sub-cos might be P: use opt_co2 + -- See Note [Optimising coercion optimisation] + AxiomInstCo con ind (zipWith (opt_co2 env False) + (coAxBranchRoles (coAxiomNthBranch con ind)) + cos) -- Note that the_co does *not* have sym pushed into it -opt_co' env sym mrole (UnivCo r oty1 oty2) - = opt_univ env role a b +opt_co4 env sym rep r (UnivCo _r oty1 oty2) + = ASSERT( r == _r ) + opt_univ env (chooseRole rep r) a b where (a,b) = if sym then (oty2,oty1) else (oty1,oty2) - role = mrole `orElse` r -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 +opt_co4 env sym rep r (TransCo co1 co2) + -- sym (g `o` h) = sym h `o` sym g + | sym = opt_trans in_scope co2' co1' + | otherwise = opt_trans in_scope co1' co2' where - opt_co1 = opt_co env sym mrole co1 - opt_co2 = opt_co env sym mrole co2 + co1' = opt_co4 env sym rep r co1 + co2' = opt_co4 env sym rep r co2 in_scope = getCvInScope env --- 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 ) - 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 - = wrap_role $ NthCo n 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_co4 env sym rep r co@(NthCo {}) = opt_nth_co env sym rep r co -opt_co' env sym mrole (LRCo lr co) +opt_co4 env sym rep r (LRCo lr co) | Just pr_co <- splitAppCo_maybe co - = opt_co env sym mrole (pickLR lr pr_co) + = ASSERT( r == Nominal ) + opt_co4 env sym rep Nominal (pickLR lr pr_co) | Just pr_co <- splitAppCo_maybe co' - = if mrole == Just Representational - then opt_co (zapCvSubstEnv env) False mrole (pickLR lr pr_co) + = ASSERT( r == Nominal ) + if rep + then opt_co4 (zapCvSubstEnv env) False True Nominal (pickLR lr pr_co) else pickLR lr pr_co | otherwise - = wrapRole mrole Nominal $ LRCo lr co' + = wrapRole rep Nominal $ LRCo lr co' where - co' = opt_co env sym Nothing co + co' = opt_co4 env sym False Nominal co -opt_co' env sym mrole (InstCo co ty) +opt_co4 env sym rep r (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 mrole co_body + = opt_co4 (extendTvSubst env tv ty') sym rep r co_body -- See if it is a forall after optimization -- If so, do an inefficient one-variable substitution @@ -221,22 +252,34 @@ opt_co' env sym mrole (InstCo co ty) | otherwise = InstCo co' ty' where - co' = opt_co env sym mrole co + co' = opt_co4 env sym rep r co ty' = substTy env ty -opt_co' env sym _ (SubCo co) = opt_co env sym (Just Representational) co +opt_co4 env sym _ r (SubCo co) + = ASSERT( r == Representational ) + opt_co4 env sym True Nominal co -- XXX: We could add another field to CoAxiomRule that -- would allow us to do custom simplifications. -opt_co' env sym mrole (AxiomRuleCo co ts cs) = - wrapRole mrole (coaxrRole co) $ +opt_co4 env sym rep r (AxiomRuleCo co ts cs) + = ASSERT( r == coaxrRole co ) + wrapRole rep r $ wrapSym sym $ AxiomRuleCo co (map (substTy env) ts) - (zipWith (opt_co env False) (map Just (coaxrAsmpRoles co)) cs) - + (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs) ------------- +-- | Optimize a phantom coercion. The input coercion may not necessarily +-- be a phantom, but the output sure will be. +opt_phantom :: CvSubst -> SymFlag -> Coercion -> NormalCo +opt_phantom env sym co + = if sym + then opt_univ env Phantom ty2 ty1 + else opt_univ env Phantom ty1 ty2 + where + Pair ty1 ty2 = coercionKind co + opt_univ :: CvSubst -> Role -> Type -> Type -> Coercion opt_univ env role oty1 oty2 | Just (tc1, tys1) <- splitTyConApp_maybe oty1 @@ -263,6 +306,45 @@ opt_univ env role oty1 oty2 = mkUnivCo role (substTy env oty1) (substTy env oty2) ------------- +-- NthCo must be handled separately, because it's the one case where we can't +-- tell quickly what the component coercion's role is from the containing +-- coercion. To avoid repeated coercionRole calls as opt_co1 calls opt_co2, +-- we just look for nested NthCo's, which can happen in practice. +opt_nth_co :: CvSubst -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo +opt_nth_co env sym rep r = go [] + where + go ns (NthCo n co) = go (n:ns) co + -- previous versions checked if the tycon is decomposable. This + -- is redundant, because a non-decomposable tycon under an NthCo + -- is entirely bogus. See docs/core-spec/core-spec.pdf. + go ns co + = opt_nths ns co + + -- input coercion is *not* yet sym'd or opt'd + opt_nths [] co = opt_co4 env sym rep r co + opt_nths (n:ns) (TyConAppCo _ _ cos) = opt_nths ns (cos `getNth` n) + + -- here, the co isn't a TyConAppCo, so we opt it, hoping to get + -- a TyConAppCo as output. We don't know the role, so we use + -- opt_co1. This is slightly annoying, because opt_co1 will call + -- coercionRole, but as long as we don't have a long chain of + -- NthCo's interspersed with some other coercion former, we should + -- be OK. + opt_nths ns co = opt_nths' ns (opt_co1 env sym co) + + -- input coercion *is* sym'd and opt'd + opt_nths' [] co + = if rep && (r == Nominal) + -- propagate the SubCo: + then opt_co4 (zapCvSubstEnv env) False True r co + else co + opt_nths' (n:ns) (TyConAppCo _ _ cos) = opt_nths' ns (cos `getNth` n) + opt_nths' ns co = wrapRole rep r (mk_nths ns co) + + mk_nths [] co = co + mk_nths (n:ns) co = mk_nths ns (mkNthCo n co) + +------------- opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] opt_transList is = zipWith (opt_trans is) @@ -427,11 +509,11 @@ opt_trans_rule is co1 co2 role = coercionRole co1 -- should be the same as coercionRole co2! opt_trans_rule _ co1 co2 -- Identity rule - | Pair ty1 _ <- coercionKind co1 + | (Pair ty1 _, r) <- coercionKindRole co1 , Pair _ ty2 <- coercionKind co2 , ty1 `eqType` ty2 = fireTransRule "RedTypeDirRefl" co1 co2 $ - Refl (coercionRole co1) ty2 + Refl r ty2 opt_trans_rule _ _ _ = Nothing @@ -494,16 +576,24 @@ checkAxInstCo (AxiomInstCo ax ind cos) checkAxInstCo _ = Nothing ----------- -wrapSym :: Bool -> Coercion -> Coercion +wrapSym :: SymFlag -> Coercion -> Coercion wrapSym sym co | sym = SymCo co | otherwise = co -wrapRole :: Maybe Role -- desired - -> Role -- current +-- | Conditionally set a role to be representational +wrapRole :: ReprFlag + -> Role -- ^ current role -> Coercion -> Coercion -wrapRole Nothing _ = id -wrapRole (Just desired) current = downgradeRole desired current - +wrapRole False _ = id +wrapRole True current = downgradeRole Representational current + +-- | If we require a representational role, return that. Otherwise, +-- return the "default" role provided. +chooseRole :: ReprFlag + -> Role -- ^ "default" role + -> Role +chooseRole True _ = Representational +chooseRole _ r = r ----------- -- takes two tyvars and builds env'ts to map them to the same tyvar substTyVarBndr2 :: CvSubst -> TyVar -> TyVar @@ -570,8 +660,7 @@ etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion) etaAppCo_maybe co | Just (co1,co2) <- splitAppCo_maybe co = Just (co1,co2) - | Nominal <- coercionRole co - , Pair ty1 ty2 <- coercionKind co + | (Pair ty1 ty2, Nominal) <- coercionKindRole co , Just (_,t1) <- splitAppTy_maybe ty1 , Just (_,t2) <- splitAppTy_maybe ty2 , typeKind t1 `eqType` typeKind t2 -- Note [Eta for AppCo] diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index d57ce12e26..65b5645d74 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -183,6 +183,9 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs It has an AlgTyConParent of FamInstTyCon T [Int] ax_ti +* The axiom ax_ti may be eta-reduced; see + Note [Eta reduction for data family axioms] in TcInstDcls + * The data contructor T2 has a wrapper (which is what the source-level "T2" invokes): @@ -576,11 +579,14 @@ data TyConParent -- 3) A 'CoTyCon' identifying the representation -- type with the type instance family | FamInstTyCon -- See Note [Data type families] - (CoAxiom Unbranched) -- The coercion constructor, - -- always of kind T ty1 ty2 ~ R:T a b c - -- where T is the family TyCon, - -- and R:T is the representation TyCon (ie this one) - -- and a,b,c are the tyConTyVars of this TyCon + (CoAxiom Unbranched) -- The coercion axiom. + -- Generally of kind T ty1 ty2 ~ R:T a b c + -- where T is the family TyCon, + -- and R:T is the representation TyCon (ie this one) + -- and a,b,c are the tyConTyVars of this TyCon + -- + -- BUT may be eta-reduced; see TcInstDcls + -- Note [Eta reduction for data family axioms] -- Cached fields of the CoAxiom, but adjusted to -- use the tyConTyVars of this TyCon @@ -722,7 +728,7 @@ which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s]) Note [Newtype eta] ~~~~~~~~~~~~~~~~~~ Consider - newtype Parser a = MkParser (IO a) derriving( Monad ) + newtype Parser a = MkParser (IO a) deriving Monad Are these two types equal (to Core)? Monad Parser Monad IO @@ -1210,7 +1216,7 @@ isDecomposableTyCon :: TyCon -> Bool -- Ultimately we may have injective associated types -- in which case this test will become more interesting -- --- It'd be unusual to call isInjectiveTyCon on a regular H98 +-- It'd be unusual to call isDecomposableTyCon on a regular H98 -- type synonym, because you should probably have expanded it first -- But regardless, it's not decomposable isDecomposableTyCon (SynTyCon {}) = False diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs index 94fdb9c3f2..f44e260c57 100644 --- a/compiler/types/Unify.lhs +++ b/compiler/types/Unify.lhs @@ -39,10 +39,8 @@ import Type import TyCon import TypeRep import Util -import PrelNames(typeNatKindConNameKey, typeSymbolKindConNameKey) -import Unique(hasKey) -import Control.Monad (liftM, ap, unless, guard) +import Control.Monad (liftM, ap) import Control.Applicative (Applicative(..)) \end{code} @@ -175,8 +173,6 @@ match menv subst (TyVarTy tv1) ty2 then Nothing -- Occurs check else do { subst1 <- match_kind menv subst (tyVarKind tv1) (typeKind ty2) -- Note [Matching kinds] - ; guard (validKindShape (tyVarKind tv1) ty2) - -- Note [Kinds Containing Only Literals] ; return (extendVarEnv subst1 tv1' ty2) } | otherwise -- tv1 is not a template tyvar @@ -210,35 +206,6 @@ match _ _ _ _ = Nothing -{- Note [Kinds Containing Only Literals] - -The kinds `Nat` and `Symbol` contain only literal types (e.g., 17, "Hi", etc.). -As such, they can only ever match and unify with a type variable or a literal -type. We check for this during matching and unification, and reject -binding variables to types that have an unacceptable shape. - -This helps us avoid "overlapping instance" errors in the presence of -very general instances. The main motivating example for this is the -implementation of `Typeable`, which contains the instances: - -... => Typeable (f a) where ... -... => Typeable (a :: Nat) where ... - -Without the explicit check these look like they overlap, and are rejected. -The two do not overlap, however, because nothing of kind `Nat` can be -of the form `f a`. --} - -validKindShape :: Kind -> Type -> Bool -validKindShape k ty - | Just (tc,[]) <- splitTyConApp_maybe k - , tc `hasKey` typeNatKindConNameKey || - tc `hasKey` typeSymbolKindConNameKey = case ty of - TyVarTy _ -> True - LitTy _ -> True - _ -> False -validKindShape _ _ = True - -------------- match_kind :: MatchEnv -> TvSubstEnv -> Kind -> Kind -> Maybe TvSubstEnv @@ -689,9 +656,6 @@ uUnrefined subst tv1 ty2 ty2' -- ty2 is not a type variable | otherwise = do { subst' <- unify subst k1 k2 -- Note [Kinds Containing Only Literals] - ; let ki = substTy (mkOpenTvSubst subst') k1 - ; unless (validKindShape ki ty2') - surelyApart ; bindTv subst' tv1 ty2 } -- Bind tyvar to the synonym if poss where k1 = tyVarKind tv1 diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 166a94850b..0aa8c648b8 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -833,18 +833,30 @@ instance Binary RecFlag where 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 +instance Binary OverlapMode where + put_ bh NoOverlap = putByte bh 0 + put_ bh Overlaps = putByte bh 1 + put_ bh Incoherent = putByte bh 2 + put_ bh Overlapping = putByte bh 3 + put_ bh Overlappable = putByte bh 4 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) + 0 -> return NoOverlap + 1 -> return Overlaps + 2 -> return Incoherent + 3 -> return Overlapping + 4 -> return Overlappable + _ -> panic ("get OverlapMode" ++ show h) + + +instance Binary OverlapFlag where + put_ bh flag = do put_ bh (overlapMode flag) + put_ bh (isSafeOverlap flag) + get bh = do + h <- get bh + b <- get bh + return OverlapFlag { overlapMode = h, isSafeOverlap = b } instance Binary FixityDirection where put_ bh InfixL = do diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index d22380ff6e..35782bac6e 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -4,13 +4,6 @@ \begin{code} {-# LANGUAGE CPP, ScopedTypeVariables #-} -{-# OPTIONS_GHC -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://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Digraph( Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices, @@ -24,7 +17,7 @@ module Digraph( componentsG, findCycle, - + -- For backwards compatability with the simpler version of Digraph stronglyConnCompFromEdgedVertices, stronglyConnCompFromEdgedVerticesR, @@ -77,14 +70,14 @@ Note [Nodes, keys, vertices] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * A 'node' is a big blob of client-stuff - * Each 'node' has a unique (client) 'key', but the latter - is in Ord and has fast comparison + * Each 'node' has a unique (client) 'key', but the latter + is in Ord and has fast comparison * Digraph then maps each 'key' to a Vertex (Int) which is - arranged densely in 0.n + arranged densely in 0.n \begin{code} -data Graph node = Graph { +data Graph node = Graph { gr_int_graph :: IntGraph, gr_vertex_to_node :: Vertex -> node, gr_node_to_vertex :: node -> Maybe Vertex @@ -92,12 +85,12 @@ data Graph node = Graph { data Edge node = Edge node node -type Node key payload = (payload, key, [key]) +type Node key payload = (payload, key, [key]) -- The payload is user data, just carried around in this module -- The keys are ordered - -- The [key] are the dependencies of the node; + -- The [key] are the dependencies of the node; -- it's ok to have extra keys in the dependencies that - -- are not the key of any Node in the graph + -- are not the key of any Node in the graph emptyGraph :: Graph a emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) @@ -105,7 +98,7 @@ emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) graphFromVerticesAndAdjacency :: Ord key => [(node, key)] - -> [(key, key)] -- First component is source vertex key, + -> [(key, key)] -- First component is source vertex key, -- second is target vertex key (thing depended on) -- Unlike the other interface I insist they correspond to -- actual vertices because the alternative hides bugs. I can't @@ -115,7 +108,7 @@ graphFromVerticesAndAdjacency [] _ = emptyGraph graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vertex . key_extractor) where key_extractor = snd (bounds, vertex_node, key_vertex, _) = reduceNodesIntoVertices vertices key_extractor - key_vertex_pair (a, b) = (expectJust "graphFromVerticesAndAdjacency" $ key_vertex a, + key_vertex_pair (a, b) = (expectJust "graphFromVerticesAndAdjacency" $ key_vertex a, expectJust "graphFromVerticesAndAdjacency" $ key_vertex b) reduced_edges = map key_vertex_pair edges graph = buildG bounds reduced_edges @@ -132,10 +125,10 @@ graphFromEdgedVertices edged_vertices = Graph graph vertex_fn (key_vertex . key_ (bounds, vertex_fn, key_vertex, numbered_nodes) = reduceNodesIntoVertices edged_vertices key_extractor graph = array bounds [(v, mapMaybe key_vertex ks) | (v, (_, _, ks)) <- numbered_nodes] -reduceNodesIntoVertices - :: Ord key - => [node] - -> (node -> key) +reduceNodesIntoVertices + :: Ord key + => [node] + -> (node -> key) -> (Bounds, Vertex -> node, key -> Maybe Vertex, [(Int, node)]) reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_vertex, numbered_nodes) where @@ -168,18 +161,18 @@ reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_verte \begin{code} type WorkItem key payload - = (Node key payload, -- Tip of the path - [payload]) -- Rest of the path; - -- [a,b,c] means c depends on b, b depends on a + = (Node key payload, -- Tip of the path + [payload]) -- Rest of the path; + -- [a,b,c] means c depends on b, b depends on a -- | Find a reasonably short cycle a->b->c->a, in a strongly -- connected component. The input nodes are presumed to be -- a SCC, so you can start anywhere. -findCycle :: forall payload key. Ord key +findCycle :: forall payload key. Ord key => [Node key payload] -- The nodes. The dependencies can - -- contain extra keys, which are ignored - -> Maybe [payload] -- A cycle, starting with node - -- so each depends on the next + -- contain extra keys, which are ignored + -> Maybe [payload] -- A cycle, starting with node + -- so each depends on the next findCycle graph = go Set.empty (new_work root_deps []) [] where @@ -189,29 +182,29 @@ findCycle graph -- Find the node with fewest dependencies among the SCC modules -- This is just a heuristic to find some plausible root module root :: Node key payload - root = fst (minWith snd [ (node, count (`Map.member` env) deps) + root = fst (minWith snd [ (node, count (`Map.member` env) deps) | node@(_,_,deps) <- graph ]) (root_payload,root_key,root_deps) = root -- 'go' implements Dijkstra's algorithm, more or less - go :: Set.Set key -- Visited - -> [WorkItem key payload] -- Work list, items length n - -> [WorkItem key payload] -- Work list, items length n+1 - -> Maybe [payload] -- Returned cycle + go :: Set.Set key -- Visited + -> [WorkItem key payload] -- Work list, items length n + -> [WorkItem key payload] -- Work list, items length n+1 + -> Maybe [payload] -- Returned cycle -- Invariant: in a call (go visited ps qs), -- visited = union (map tail (ps ++ qs)) - go _ [] [] = Nothing -- No cycles + go _ [] [] = Nothing -- No cycles go visited [] qs = go visited qs [] - go visited (((payload,key,deps), path) : ps) qs + go visited (((payload,key,deps), path) : ps) qs | key == root_key = Just (root_payload : reverse path) | key `Set.member` visited = go visited ps qs | key `Map.notMember` env = go visited ps qs | otherwise = go (Set.insert key visited) ps (new_qs ++ qs) where - new_qs = new_work deps (payload : path) + new_qs = new_work deps (payload : path) new_work :: [key] -> [payload] -> [WorkItem key payload] new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] @@ -250,7 +243,7 @@ instance Outputable a => Outputable (SCC a) where %************************************************************************ Note: the components are returned topologically sorted: later components -depend on earlier ones, but not vice versa i.e. later components only have +depend on earlier ones, but not vice versa i.e. later components only have edges going from them to earlier ones. \begin{code} @@ -311,7 +304,7 @@ reachableG graph from = map (gr_vertex_to_node graph) result reachablesG :: Graph node -> [node] -> [node] reachablesG graph froms = map (gr_vertex_to_node graph) result - where result = {-# SCC "Digraph.reachable" #-} + where result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) vs vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ] @@ -656,18 +649,18 @@ noOutEdges g = [ v | v <- vertices g, null (g!v)] vertexGroupsS :: Set s -> IntGraph -> [Vertex] -> ST s [[Vertex]] vertexGroupsS provided g to_provide - = if null to_provide - then do { + = if null to_provide + then do { all_provided <- allM (provided `contains`) (vertices g) ; if all_provided then return [] - else error "vertexGroup: cyclic graph" + else error "vertexGroup: cyclic graph" } - else do { + else do { mapM_ (include provided) to_provide ; to_provide' <- filterM (vertexReady provided g) (vertices g) ; rest <- vertexGroupsS provided g to_provide' - ; return $ to_provide : rest + ; return $ to_provide : rest } vertexReady :: Set s -> IntGraph -> Vertex -> ST s Bool diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs index 0396c02749..157e5f08b0 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.lhs @@ -239,7 +239,7 @@ data FastStringTable = string_table :: FastStringTable {-# NOINLINE string_table #-} string_table = unsafePerformIO $ do - uid <- newIORef 0 + uid <- newIORef 603979776 -- ord '$' * 0x01000000 tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED (panic "string_table") s1# of (# s2#, arr# #) -> (# s2#, FastStringTable uid arr# #) diff --git a/compiler/utils/OrdList.lhs b/compiler/utils/OrdList.lhs index d1d8708dd3..42abb51696 100644 --- a/compiler/utils/OrdList.lhs +++ b/compiler/utils/OrdList.lhs @@ -15,6 +15,8 @@ module OrdList ( mapOL, fromOL, toOL, foldrOL, foldlOL ) where +import Outputable + infixl 5 `appOL` infixl 5 `snocOL` infixr 5 `consOL` @@ -28,6 +30,8 @@ data OrdList a | Two (OrdList a) -- Invariant: non-empty (OrdList a) -- Invariant: non-empty +instance Outputable a => Outputable (OrdList a) where + ppr ol = ppr (fromOL ol) -- Convert to list and print that nilOL :: OrdList a isNilOL :: OrdList a -> Bool diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index e32261de65..a65607a7c3 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -53,15 +53,17 @@ module Outputable ( -- * Controlling the style in which output is printed BindingSite(..), - PprStyle, CodeStyle(..), PrintUnqualified, + PprStyle, CodeStyle(..), PrintUnqualified(..), + QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, + reallyAlwaysQualify, reallyAlwaysQualifyNames, alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, neverQualify, neverQualifyNames, neverQualifyModules, - QualifyName(..), + QualifyName(..), queryQual, sdocWithDynFlags, sdocWithPlatform, getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprDeeperList, pprSetDepth, codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, - ifPprDebug, qualName, qualModule, + ifPprDebug, qualName, qualModule, qualPackage, mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle, mkUserStyle, cmdlineParserStyle, Depth(..), @@ -76,7 +78,7 @@ import {-# SOURCE #-} DynFlags( DynFlags, targetPlatform, pprUserLength, pprCols, useUnicode, useUnicodeSyntax, unsafeGlobalDynFlags ) -import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) +import {-# SOURCE #-} Module( PackageKey, Module, ModuleName, moduleName ) import {-# SOURCE #-} OccName( OccName ) import {-# SOURCE #-} StaticFlags( opt_PprStyle_Debug, opt_NoDebugOutput ) @@ -142,12 +144,15 @@ data Depth = AllTheWay -- ----------------------------------------------------------------------------- -- Printing original names --- When printing code that contains original names, we need to map the +-- | When printing code that contains original names, we need to map the -- original names back to something the user understands. This is the --- purpose of the pair of functions that gets passed around +-- purpose of the triple of functions that gets passed around -- when rendering 'SDoc'. - -type PrintUnqualified = (QueryQualifyName, QueryQualifyModule) +data PrintUnqualified = QueryQualify { + queryQualifyName :: QueryQualifyName, + queryQualifyModule :: QueryQualifyModule, + queryQualifyPackage :: QueryQualifyPackage +} -- | given an /original/ name, this function tells you which module -- name it should be qualified with when printing for the user, if @@ -161,6 +166,9 @@ type QueryQualifyName = Module -> OccName -> QualifyName -- a package name to disambiguate it. type QueryQualifyModule = Module -> Bool +-- | For a given package, we need to know whether to print it with +-- the package key to disambiguate it. +type QueryQualifyPackage = PackageKey -> Bool -- See Note [Printing original names] in HscTypes data QualifyName -- given P:M.T @@ -173,6 +181,10 @@ data QualifyName -- given P:M.T -- it is not in scope at all, and M.T is already bound in the -- current scope, so we must refer to it as "P:M.T" +reallyAlwaysQualifyNames :: QueryQualifyName +reallyAlwaysQualifyNames _ _ = NameNotInScope2 + +-- | NB: This won't ever show package IDs alwaysQualifyNames :: QueryQualifyName alwaysQualifyNames m _ = NameQual (moduleName m) @@ -185,9 +197,23 @@ alwaysQualifyModules _ = True neverQualifyModules :: QueryQualifyModule neverQualifyModules _ = False -alwaysQualify, neverQualify :: PrintUnqualified -alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules) -neverQualify = (neverQualifyNames, neverQualifyModules) +alwaysQualifyPackages :: QueryQualifyPackage +alwaysQualifyPackages _ = True + +neverQualifyPackages :: QueryQualifyPackage +neverQualifyPackages _ = False + +reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified +reallyAlwaysQualify + = QueryQualify reallyAlwaysQualifyNames + alwaysQualifyModules + alwaysQualifyPackages +alwaysQualify = QueryQualify alwaysQualifyNames + alwaysQualifyModules + alwaysQualifyPackages +neverQualify = QueryQualify neverQualifyNames + neverQualifyModules + neverQualifyPackages defaultUserStyle, defaultDumpStyle :: PprStyle @@ -297,13 +323,22 @@ sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform) \begin{code} qualName :: PprStyle -> QueryQualifyName -qualName (PprUser (qual_name,_) _) mod occ = qual_name mod occ +qualName (PprUser q _) mod occ = queryQualifyName q mod occ qualName _other mod _ = NameQual (moduleName mod) qualModule :: PprStyle -> QueryQualifyModule -qualModule (PprUser (_,qual_mod) _) m = qual_mod m +qualModule (PprUser q _) m = queryQualifyModule q m qualModule _other _m = True +qualPackage :: PprStyle -> QueryQualifyPackage +qualPackage (PprUser q _) m = queryQualifyPackage q m +qualPackage _other _m = True + +queryQual :: PprStyle -> PrintUnqualified +queryQual s = QueryQualify (qualName s) + (qualModule s) + (qualPackage s) + codeStyle :: PprStyle -> Bool codeStyle (PprCode _) = True codeStyle _ = False diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 0274c590ea..2dcc73fd89 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -47,7 +47,7 @@ module Util ( nTimes, -- * Sorting - sortWith, minWith, + sortWith, minWith, nubSort, -- * Comparisons isEqual, eqListBy, eqMaybeBy, @@ -126,6 +126,7 @@ import Data.Ord ( comparing ) import Data.Bits import Data.Word import qualified Data.IntMap as IM +import qualified Data.Set as Set import Data.Time #if __GLASGOW_HASKELL__ < 705 @@ -490,6 +491,9 @@ sortWith get_key xs = sortBy (comparing get_key) xs minWith :: Ord b => (a -> b) -> [a] -> a minWith get_key xs = ASSERT( not (null xs) ) head (sortWith get_key xs) + +nubSort :: Ord a => [a] -> [a] +nubSort = Set.toAscList . Set.fromList \end{code} %************************************************************************ diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs index 269119c6dd..0d5d37c7d7 100644 --- a/compiler/vectorise/Vectorise/Generic/PAMethods.hs +++ b/compiler/vectorise/Vectorise/Generic/PAMethods.hs @@ -16,7 +16,7 @@ import Vectorise.Generic.Description import CoreSyn import CoreUtils import FamInstEnv -import MkCore ( mkWildCase ) +import MkCore ( mkWildCase, mkCoreLet ) import TyCon import CoAxiom import Type @@ -24,6 +24,7 @@ import OccName import Coercion import MkId import FamInst +import TysPrim( intPrimTy ) import DynFlags import FastString @@ -404,9 +405,13 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r -- and PDatas Void arrays in the product. See Note [Empty PDatas]. let xSums = App (repr_selsLength_v ss) (Var sels) - (vars, exprs) <- mapAndUnzipM (to_con xSums) (repr_cons ss) + xSums_var <- newLocalVar (fsLit "xsum") intPrimTy + + (vars, exprs) <- mapAndUnzipM (to_con xSums_var) (repr_cons ss) return ( sels : concat vars , wrapFamInstBody psums_tc (repr_con_tys ss) + $ mkCoreLet (NonRec xSums_var xSums) + -- mkCoreLet ensures that the let/app invariant holds $ mkConApp psums_con $ map Type (repr_con_tys ss) ++ (Var sels : exprs)) @@ -414,7 +419,7 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r = case ss of EmptyProd -> do pvoids <- builtin pvoidsVar - return ([], App (Var pvoids) xSums ) + return ([], App (Var pvoids) (Var xSums) ) UnaryProd r -> do pty <- mkPDatasType (compOrigType r) diff --git a/configure.ac b/configure.ac index 9f0edaa663..d9524287dd 100644 --- a/configure.ac +++ b/configure.ac @@ -34,7 +34,7 @@ fi AC_SUBST([CONFIGURE_ARGS], [$ac_configure_args]) dnl ---------------------------------------------------------- -dnl ** Find unixy sort and find commands, +dnl ** Find unixy sort and find commands, dnl ** which are needed by FP_SETUP_PROJECT_VERSION dnl ** Find find command (for Win32's benefit) @@ -91,7 +91,7 @@ AC_ARG_WITH([ghc], WithGhc="$GHC"]) dnl ** Tell the make system which OS we are using -dnl $OSTYPE is set by the operating system to "msys" or "cygwin" or something +dnl $OSTYPE is set by the operating system to "msys" or "cygwin" or something AC_SUBST(OSTYPE) AC_ARG_ENABLE(bootstrap-with-devel-snapshot, @@ -228,7 +228,7 @@ case $host in # here we go with the test MINOR=`uname -r|cut -d '.' -f 2-` if test "$MINOR" -lt "11"; then - SOLARIS_BROKEN_SHLD=YES + SOLARIS_BROKEN_SHLD=YES fi ;; esac @@ -479,6 +479,61 @@ export CC MAYBE_OVERRIDE_STAGE0([gcc],[CC_STAGE0]) MAYBE_OVERRIDE_STAGE0([ar],[AR_STAGE0]) +dnl ** what cpp to use? +dnl -------------------------------------------------------------- +AC_ARG_WITH(hs-cpp, +[AC_HELP_STRING([--with-hs-cpp=ARG], + [Use ARG as the path to cpp [default=autodetect]])], +[ + if test "$HostOS" = "mingw32" + then + AC_MSG_WARN([Request to use $withval will be ignored]) + else + HaskellCPPCmd=$withval + fi +], +[ + HaskellCPPCmd=$WhatGccIsCalled +] +) + + + +dnl ** what cpp flags to use? +dnl ----------------------------------------------------------- +AC_ARG_WITH(hs-cpp-flags, + [AC_HELP_STRING([--with-hs-cpp-flags=ARG], + [Use ARG as the path to hs cpp [default=autodetect]])], + [ + if test "$HostOS" = "mingw32" + then + AC_MSG_WARN([Request to use $withval will be ignored]) + else + HaskellCPPArgs=$withval + fi + ], +[ + $HaskellCPPCmd -x c /dev/null -dM -E > conftest.txt 2>&1 + if grep "__clang__" conftest.txt >/dev/null 2>&1; then + HaskellCPPArgs="-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs " + else + $HaskellCPPCmd -v > conftest.txt 2>&1 + if grep "gcc" conftest.txt >/dev/null 2>&1; then + HaskellCPPArgs="-E -undef -traditional " + else + $HaskellCPPCmd --version > conftest.txt 2>&1 + if grep "cpphs" conftest.txt >/dev/null 2>&1; then + HaskellCPPArgs="--cpp -traditional" + else + AC_MSG_WARN([configure can't recognize your CPP program, you may need to set --with-hs-cpp-flags=FLAGS explicitly]) + HaskellCPPArgs="" + fi + fi + fi + ] +) + + dnl ** Which ld to use? dnl -------------------------------------------------------------- FP_ARG_WITH_PATH_GNU_PROG([LD], [ld], [ld]) @@ -763,30 +818,6 @@ FP_CHECK_FUNC([WinExec], FP_CHECK_FUNC([GetModuleFileName], [@%:@include <windows.h>], [GetModuleFileName((HMODULE)0,(LPTSTR)0,0)]) -dnl ** check return type of signal handlers -dnl Foo: assumes we can use prototypes. -dnl On BCC, signal handlers have type "int(void)", elsewhere its "void(int)". -dnl AC_CACHE_CHECK([type of signal handlers], ac_cv_type_signal_handler, -dnl [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/types.h> -dnl #include <signal.h> -dnl #ifdef signal -dnl #undef signal -dnl #endif -dnl void (*signal (int, void (*)(int)))(int); -dnl ]], -dnl [[int i;]])], -dnl [ac_cv_type_signal_handler=void_int], -dnl [ac_cv_type_signal_handler=int_void])]) -dnl if test "$ac_cv_type_signal_handler" = void_int; then -dnl AC_DEFINE(VOID_INT_SIGNALS) -dnl fi - -dnl On BCC, signal handlers have type "int(void)", elsewhere its "void(int)". -AC_TYPE_SIGNAL -if test "$ac_cv_type_signal" = void; then - AC_DEFINE([VOID_INT_SIGNALS], [1], [Define to 1 if signal handlers have type void (*)(int). Otherwise, they're assumed to have type int (*)(void).]) -fi - dnl ** check for more functions dnl ** The following have been verified to be used in ghc/, but might be used somewhere else, too. AC_CHECK_FUNCS([getclock getrusage gettimeofday setitimer siginterrupt sysconf times ctime_r sched_setaffinity setlocale]) @@ -991,13 +1022,14 @@ echo ["\ Using $CompilerName : $WhatGccIsCalled which is version : $GccVersion Building a cross compiler : $CrossCompiling - - ld : $LdCmd - Happy : $HappyCmd ($HappyVersion) - Alex : $AlexCmd ($AlexVersion) - Perl : $PerlCmd - dblatex : $DblatexCmd - xsltproc : $XsltprocCmd + cpp : $HaskellCPPCmd + cpp-flags : $HaskellCPPArgs + ld : $LdCmd + Happy : $HappyCmd ($HappyVersion) + Alex : $AlexCmd ($AlexVersion) + Perl : $PerlCmd + dblatex : $DblatexCmd + xsltproc : $XsltprocCmd Using LLVM tools llc : $LlcCmd diff --git a/distrib/configure.ac.in b/distrib/configure.ac.in index ed91244d88..c7a8ead9b0 100644 --- a/distrib/configure.ac.in +++ b/distrib/configure.ac.in @@ -63,6 +63,65 @@ FIND_GCC([WhatGccIsCalled], [gcc], [gcc]) CC="$WhatGccIsCalled" export CC + +dnl ** what cpp to use? +dnl -------------------------------------------------------------- +AC_ARG_WITH(hs-cpp, +[AC_HELP_STRING([--with-hs-cpp=ARG], + [Use ARG as the path to cpp [default=autodetect]])], +[ + if test "$HostOS" = "mingw32" + then + AC_MSG_WARN([Request to use $withval will be ignored]) + else + HaskellCPPCmd=$withval + fi +], +[ + if test "$HostOS" != "mingw32" + then + HaskellCPPCmd=$WhatGccIsCalled + fi +] +) + + + +dnl ** what cpp flags to use? +dnl ----------------------------------------------------------- +AC_ARG_WITH(hs-cpp-flags, + [AC_HELP_STRING([--with-hs-cpp-flags=ARG], + [Use ARG as the path to hs cpp [default=autodetect]])], + [ + if test "$HostOS" = "mingw32" + then + AC_MSG_WARN([Request to use $withval will be ignored]) + else + HaskellCPPArgs=$withval + fi + ], +[ + $HaskellCPPCmd -x c /dev/null -dM -E > conftest.txt 2>&1 + if grep "__clang__" conftest.txt >/dev/null 2>&1; then + HaskellCPPArgs="-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs " + else + $HaskellCPPCmd -v > conftest.txt 2>&1 + if grep "gcc" conftest.txt >/dev/null 2>&1; then + HaskellCPPArgs="-E -undef -traditional " + else + $HaskellCPPCmd --version > conftest.txt 2>&1 + if grep "cpphs" conftest.txt >/dev/null 2>&1; then + HaskellCPPArgs="--cpp -traditional" + else + AC_MSG_WARN([configure can't recognize your CPP program, you may need to set --with-hs-cpp-flags=FLAGS explicitly]) + HaskellCPPArgs="" + fi + fi + fi + ] +) + + dnl ** Which ld to use? dnl -------------------------------------------------------------- FP_ARG_WITH_PATH_GNU_PROG([LD], [ld], [ld]) diff --git a/docs/backpack/backpack-impl.tex b/docs/backpack/backpack-impl.tex index e172499537..963c53c50b 100644 --- a/docs/backpack/backpack-impl.tex +++ b/docs/backpack/backpack-impl.tex @@ -1,11 +1,38 @@ \documentclass{article} +\usepackage{pifont} \usepackage{graphicx} %[pdftex] OR [dvips] \usepackage{fullpage} +\usepackage{wrapfig} \usepackage{float} \usepackage{titling} +\usepackage{hyperref} +\usepackage{tikz} +\usepackage{color} +\usepackage{footnote} +\usepackage{float} +\usepackage{algorithm} +\usepackage{algpseudocode} +\usetikzlibrary{arrows} +\usetikzlibrary{positioning} \setlength{\droptitle}{-6em} +\input{commands-new-new.tex} + +\newcommand{\nuAA}{\nu_\mathit{AA}} +\newcommand{\nuAB}{\nu_\mathit{AB}} +\newcommand{\nuGA}{\nu_\mathit{GA}} +\newcommand{\nuGB}{\nu_\mathit{GB}} +\newcommand{\betaPL}{\beta_\mathit{PL}} +\newcommand{\betaAA}{\beta_\mathit{AA}} +\newcommand{\betaAS}{\beta_\mathit{AS}} +\newcommand{\thinandalso}{\hspace{.45cm}} +\newcommand{\thinnerandalso}{\hspace{.38cm}} + +\input{commands-rebindings.tex} + +\newcommand{\var}[1]{\textsf{#1}} + \newcommand{\ghcfile}[1]{\textsl{#1}} \title{Implementing Backpack} @@ -15,393 +42,908 @@ \maketitle The purpose of this document is to describe an implementation path -for Backpack~\cite{Kilpatrick:2014:BRH:2535838.2535884} in GHC\@. +for Backpack in GHC\@. -We start off by outlining the current architecture of GHC, ghc-pkg and Cabal, -which constitute the existing packaging system. We then state what our subgoals -are, since there are many similar sounding but different problems to solve. Next, -we describe the ``probably correct'' implementation plan, and finish off with -some open design questions. This is intended to be an evolving design document, -so please contribute! +\tableofcontents -\section{Current packaging architecture} +\section{What we are trying to solve} -The overall architecture is described in Figure~\ref{fig:arch}. +While the current ecosystem has proved itself serviceable for many years, +there are a number of major problems which causes significant headaches +for many users. Here are some of them: -\begin{figure}[H] - \center{\scalebox{0.8}{\includegraphics{arch.png}}} -\label{fig:arch}\caption{Architecture of GHC, ghc-pkg and Cabal. Green bits indicate additions from upcoming IHG work, red bits indicate additions from Backpack. Orange indicates a Haskell library.} -\end{figure} - -Here, arrows indicate dependencies from one component to another. Color -coding is as follows: orange components are libaries, green components -are to be added with the IHG work, red components are to be added with -Backpack. (Thus, black and orange can be considered the current) +\subsection{Package reinstalls are destructive}\label{sec:destructive} -\subsection{Installed package database} +When attempting to install a new package, you might get an error like +this: -Starting from the bottom, we have the \emph{installed package database} -(actually a collection of such databases), which stores information -about what packages have been installed are thus available to be -compiled against. There is both a global database (for the system -administrator) and a local database (for end users), which can be -updated independently. One way to think about the package database -is as a \emph{cache of object code}. In principle, one could compile -any piece of code by repeatedly recompiling all of its dependencies; -the installed package database describes when this can be bypassed. +\begin{verbatim} +$ cabal install hakyll +cabal: The following packages are likely to be broken by the reinstalls: +pandoc-1.9.4.5 +Graphalyze-0.14.0.0 +Use --force-reinstalls if you want to install anyway. +\end{verbatim} -\begin{figure}[H] - \center{\scalebox{0.8}{\includegraphics{pkgdb.png}}} -\label{fig:pkgdb}\caption{Anatomy of a package database.} -\end{figure} +While this error message is understandable if you're really trying to +reinstall a package, it is quite surprising that it can occur even if +you didn't ask for any reinstalls! + +The underlying cause of this problem is related to an invariant Cabal +currently enforces on a package database: there can only be one instance +of a package for any given package name and version. This means that it +is not possible to install a package multiple times, compiled against +different dependencies. However, sometimes, reinstalling a package with +different dependencies is the only way to fulfill version bounds of a +package! For example: say we have three packages \pname{a}, \pname{b} +and \pname{c}. \pname{b-1.0} is the only version of \pname{b} +available, and it has been installed and compiled against \pname{c-1.0}. +Later, the user installs an updated version \pname{c-1.1} and then +attempts to install \pname{a}, which depends on the specific versions +\pname{c-1.1} and \pname{b-1.0}. We \emph{cannot} use the already +installed version of \pname{b-1.0}, which depends on the wrong version +of \pname{c}, so our only choice is to reinstall \pname{b-1.0} compiled +against \pname{c-1.1}. This will break any packages, e.g. \pname{d}, +which were built against the old version of \pname{b-1.0}. + +Our solution to this problem is to \emph{abolish} destructive package +installs, and allow a package to be installed multiple times with the same +package name and version. However, allowing this poses some interesting +user interface problems, since package IDs are now no longer unambiguous +identifiers. + +\subsection{Version bounds are often over/under-constrained} + +When attempting to install a new package, Cabal might fail in this way: -In Figure~\ref{fig:pkgdb}, we show the structure of a package database. -The installed package are created from a Cabal file through the process -of dependency resolution and compilation. In database terms, the primary key -of a package database is the InstalledPackageId -(Figure~\ref{fig:current-pkgid}). This ID uniquely identifies an -instance of an installed package. The PackageId omits the ABI hash and -is used to qualify linker exported symbols: the current value of this -parameter is communicated to GHC using the \verb|-package-id| flag. - -In principle, packages with different PackageIds should be linkable -together in the same compiled program, whereas packages with the same -PackageId are not (even if they have different InstalledPackageIds). In -practice, GHC is currently only able to select one version of a package, -as it clears out all old versions of the package in -\ghcfile{compiler/main/Package.lhs}:applyPackageFlag. +\begin{verbatim} +$ cabal install hledger-0.18 +Resolving dependencies... +cabal: Could not resolve dependencies: +# pile of output +\end{verbatim} -\begin{figure} - \center{\begin{tabular}{r l} - PackageId & package name, package version \\ - InstalledPackageId & PackageId, ABI hash \\ - \end{tabular}} -\label{fig:current-pkgid}\caption{Current structure of package identifiers.} -\end{figure} +There are a number of possible reasons why this could occur, but usually +it's because some of the packages involved have over-constrained version +bounds, which are resulting in an unsatisfiable set of constraints (or, +at least, Cabal gave up backtracking before it found a solution.) To +add insult to injury, most of the time the bound is nonsense and removing +it would result in a working compilation. In fact, this situation is +so common that Cabal has a flag \verb|--allow-newer| which lets you +override the package upper bounds. + +However, the flip-side is when Cabal finds a satisfying set, but your +compilation fails with a type error. Here, you had an under-constrained +set of version bounds which didn't actually reflect the compatible +versions of a package, and Cabal picked a version of the package which +was incompatible. + +Our solution to this problem is to use signatures instead of version +numbers as the primary mechanism by which compatibility is determined: +e.g., if it typechecks, it's a valid choice. Version numbers can still +be used to reflect semantic changes not seen in the types (in +particular, ruling out buggy versions of a package is a useful +operation), but these bounds are empirical observations and can be +collected after-the-fact. + +\subsection{It is difficult to support multiple implementations of a type} + +This problem is perhaps best described by referring to a particular +instance of it Haskell's ecosystem: the \texttt{String} data type. Haskell, +by default, implements strings as linked lists of integers (representing +characters). Many libraries use \texttt{String}, because it's very +convenient to program against. However, this representation is also +very \emph{slow}, so there are alternative implementations such as +\texttt{Text} which implement efficient, UTF-8 encoded packed byte +arrays. + +Now, suppose you are writing a library and you don't care if the user of +your library is using \texttt{String} or \texttt{Text}. However, you +don't want to rewrite your library twice to support both data types: +rather, you'd like to rely on some \emph{common interface} between the +two types, and let the user instantiate the implementation. The only +way to do this in today's Haskell is using type classes; however, this +necessitates rewriting all type signatures from a nice \texttt{String -> +String} to \texttt{StringLike s => s -> s}. The result is less readable, +required a large number of trivial edits to type signatures, and might +even be less efficient, if GHC does not appropriately specialize your code +written in this style. + +Our solution to this problem is to introduce a new mechanism of +pluggability: module holes, which let us use types and functions from a +module \texttt{Data.String} as before, but defer choosing \emph{what} +module should be used in the implementation to some later point (or +instantiate the code multiple times with different choices.) + +\subsection{Fast moving APIs are difficult to develop/develop against} + +Most packages that are uploaded to Hackage have package authors which pay +some amount of attention to backwards compatibility and avoid making egregious +breaking changes. However, a package like the \verb|ghc-api| follows a +very different model: the library is a treated by its developers as an +internal component of an application (GHC), and is frequently refactored +in a way that changes its outwards facing interface. + +Arguably, an application like GHC should design a stable API and +maintain backwards compatibility against it. However, this is a lot of +work (including refactoring) which is only being done slowly, and in the +meantime, the dump of all the modules gives users the functionality they +want (even if it keeps breaking every version.) + +One could say that the core problem is there is no way for users to +easily communicate to GHC authors what parts of the API they rely on. A +developer of GHC who is refactoring an interface will often rely on the +typechecker to let them know which parts of the codebase they need to +follow and update, and often could say precisely how to update code to +use the new interface. User applications, which live out of tree, don't +receive this level of attention. + +Our solution is to make it possible to typecheck the GHC API against a +signature. Important consumers can publish what subsets of the GHC API +they rely against, and developers of GHC, as part of their normal build +process, type-check against these signatures. If the signature breaks, +a developer can either do the refactoring differently to avoid the +compatibility-break, or document how to update code to use the new API\@. + +\section{Backpack in a nutshell} + +For a more in-depth tutorial about Backpack's features, check out Section 2 +of the original Backpack paper. In this section, we briefly review the +most important points of Backpack's design. + +\paragraph{Thinning and renaming at the module level} +A user can specify a build dependency which only exposes a subset of +modules (possibly under different names.) By itself, it's a way for the +user to resolve ambiguous module imports at the package level, without +having to use the \texttt{PackageImports} syntax extension. + +\paragraph{Holes (abstract module definitions)} The core +component of Backpack's support for \emph{separate modular development} +is the ability to specify abstract module bindings, or holes, which give +users of the module an obligation to provide an implementation which +fulfills the signature of the hole. In this example: -The database entry itself contains the information from the installed package ID, -as well as information such as what dependencies it was linked against, where -its compiled code and interface files live, its compilation flags, what modules -it exposes, etc. Much of this information is only relevant to Cabal; GHC -uses a subset of the information in the package database. +\begin{verbatim} +package p where + A :: [ ... ] + B = [ import A; ... ] +\end{verbatim} -\subsection{GHC} +\verb|p| is an \emph{indefinite package}, which cannot be compiled until +an implementation of \m{A} is provided. However, we can still type check +\m{B} without any implementation of \m{A}, by type checking it against +the signature. Holes can be put into signature packages and included +(depended upon) by other packages to reuse definitions of signatures. -The two programs which access the package database directly are GHC -proper (for compilation) and ghc-pkg (which is a general purpose -command line tool for manipulating the database.) GHC relies on -the package database in the following ways: +\paragraph{Filling in holes with an implementation} +A hole in an indefinite package can be instantiated in a \emph{mix-in} +style: namely, if a signature and an implementation have the same name, +they are linked together: -\begin{itemize} - \item It imports the local and global package databases into - its runtime database, and applies modifications to the exposed - and trusted status of the entries via the flags \verb|-package| - and others (\ghcfile{compiler/main/Packages.lhs}). The internal - package state can be seen at \verb|-v4| or higher. - \item It uses this package database to find the location of module - interfaces when it attempts to load the module info of an external - module (\ghcfile{compiler/iface/LoadIface.hs}). -\end{itemize} - -GHC itself performs a type checking phase, which generates an interface -file representing the module (so that later invocations of GHC can load the type -of a module), and then after compilation projects object files and linked archives -for programs to use. +\begin{verbatim} +package q where + A = [ ... ] + include p -- has signature A +\end{verbatim} -\paragraph{Original names} Original names are an important design pattern -in GHC\@. -Sometimes, a name can be exposed in an hi file even if its module -wasn't exposed. Here is an example (compiled in package R): +Renaming is often useful to rename a module (or a hole) so that a signature +and implementation have the same name and are linked together. +An indefinite package can be instantiated multiple times with different +implementations: the \emph{applicativity} of Backpack means that if +a package is instantiated separately with the same module, the results +are type equal: \begin{verbatim} -module X where - import Internal (f) - g = f - -module Internal where - import Internal.Total (f) +package q' where + A = [ ... ] + include p (A, B as B1) + include p (A, B as B2) + -- B1 and B2 are equivalent \end{verbatim} -Then in X.hi: +\paragraph{Combining signatures together} +Unlike implementations, it's valid for a multiple signatures with the +same name to be in scope. \begin{verbatim} -g = <R.id, Internal.Total, f> (this is the original name) +package a-sig where + A :: [ ... ] +package a-sig2 where + A :: [ ... ] +package q where + include a-sig + include a-sig2 + B = [ import A; ... ] \end{verbatim} -(The reason we refer to the package as R.id is because it's the -full package ID, and not just R). +These signatures \emph{merge} together, providing the union of the +functionality (assuming the types of individual entities are +compatible.) Backpack has a very simple merging algorithm: types must +match exactly to be compatible (\emph{width} subtyping). -\subsection{hs-boot} +\clearpage -\verb|hs-boot| is a special mechanism used to support recursive linking -of modules within a package, today. Suppose I have a recursive module -dependency between modules and A and B. I break one of\ldots +\section{Module and package identity} -(ToDo: describe how hs-boot mechanism works) +\begin{figure}[H] +\begin{tabular}{p{0.45\textwidth} p{0.45\textwidth}} +\begin{verbatim} +package p where + A :: [ data X ] + P = [ import A; data Y = Y X ] +package q where + A1 = [ data X = X1 ] + A2 = [ data X = X2 ] + include p (A as A1, P as P1) + include p (A as A2, P as P2) +\end{verbatim} +& +\begin{verbatim} +package p where + A :: [ data X ] + P = [ data T = T ] -- no A import! +package q where + A1 = [ data X = X1 ] + A2 = [ data X = X2 ] + include p (A as A1, P as P1) + include p (A as A2, P as P2) +\end{verbatim} +\\ +(a) Type equality must consider holes\ldots & +(b) \ldots but how do we track dependencies? \\ +\end{tabular} +\caption{Two similar examples}\label{fig:simple-ex} +\end{figure} -\subsection{Cabal} +One of the central questions one encounters when type checking Haskell +code is: \emph{when are two types equal}? In ordinary Haskell, the +answer is simple: ``They are equal if their \emph{original names} (i.e., +where they were originally defined) are the same.'' However, in +Backpack, the situation is murkier due to the presence of \emph{holes}. +Consider the pair of examples in Figure~\ref{fig:simple-ex}. +In Figure~\ref{fig:simple-ex}a, the types \m{B1}.\verb|Y| and \m{B2}.\verb|Y| should not be +considered equal, even though na\"\i vely their original names are +\pname{p}:\m{B}.\verb|Y|, since their arguments are different \verb|X|'s! +On the other hand, if we instantiated \pname{p} twice with the same \m{A} +(e.g., change the second include to \texttt{include p (A as A1, P as P2)}), +we might consider the two resulting \verb|Y|'s +equal, an \emph{applicative} semantics of identity instantiation. In +Figure~\ref{fig:simple-ex}b, we see that even though \m{A} was instantiated differently, +we might reasonably wonder if \texttt{T} should still be considered the same, +since it has no dependence on the actual choice of \m{A}. + +In fact, there are quite a few different choices that can be made here. +Figures~\ref{fig:applicativity}~and~\ref{fig:granularity} summarize the various +choices on two axes: the granularity of applicativity (under what circumstances +do we consider two types equal) and the granularity of dependency (what circumstances +do we consider two types not equal)? A \ding{52} means the design we have chosen +answers the question affirmatively---\ding{54}, negatively---but all of these choices +are valid points on the design space. + +\subsection{The granularity of applicativity} + +An applicative semantics of package instantiation states that if a package is +instantiated with the ``same arguments'', then the resulting entities it defines +should also be considered equal. Because Backpack uses \emph{mix-in modules}, +it is very natural to consider the arguments of a package instantiation as the +modules, as shown in Figure~\ref{fig:applicativity}b: the same module \m{A} is +linked for both instantiations, so \m{P1} and \m{P2} are considered equal. + +However, we consider the situation at a finer granularity, we might say, ``Well, +for a declaration \texttt{data Y = Y X}, only the definition of type \verb|X| matters. +If they are the same, then \verb|Y| is the same.'' In that case, we might accept +that in Figure~\ref{fig:applicativity}a, even though \pname{p} is instantiated +with different modules, at the end of the day, the important component \verb|X| is +the same in both cases, so \verb|Y| should also be the same. This is a sort of +``extreme'' view of modular development, where every declaration is desugared +into a separate module. In our design, we will be a bit more conservative, and +continue with module level applicativity, in the same manner as Paper Backpack. + +\paragraph{Implementation considerations} +Compiling Figure~\ref{fig:applicativity}b to dynamic libraries poses an +interesting challenge, if every package compiles to a dynamic library. +When we compile package \pname{q}, the libraries we end up producing are \pname{q} +and an instance of \pname{p} (instantiated with \pname{q}:\m{A}). Furthermore, +\pname{q} refers to code in \pname{p} (the import in \m{Q}), and vice versa (the usage +of the instantiated hole \m{A}). When building static libraries, this circular +dependency doesn't matter: when we link the executable, we can resolve all +of the symbols in one go. However, when the libraries in question are +dynamic libraries \verb|libHSq.so| and \verb|libHSp(q:A).so|, we now have +a \emph{circular dependency} between the two dynamic libraries, and most dynamic +linkers will not be able to load either of these libraries. + +To break the circularity in Figure~\ref{fig:applicativity}b, we have to \emph{inline} +the entire module \m{A} into the instance of \pname{p}. Since the code is exactly +the same, we can still consider the instance of \m{A} in \pname{q} and in \pname{p} +type equal. However, in Figure~\ref{fig:applicativity}c, applicativity has been +done at a coarser level: although we are using Backpack's module mixin syntax, +morally, this example is filling in the holes with the \emph{package} \pname{a} +(rather than a module). In this case, we can achieve code sharing, since +\pname{p} can refer directly to \pname{a}, breaking the circularity. + +\newcolumntype{C}{>{\centering\arraybackslash}p{0.3\textwidth}} + \begin{savenotes} +\begin{figure} + \begin{tabular}{C C C} +\begin{verbatim} +package q where + A = [ data X = X ] + A1 = [ import A; x = 0 ] + A2 = [ import A; x = 1 ] + include p (A as A1, P as P1) + include p (A as A2, P as P2) + Q = [ import P1; ... ] +\end{verbatim} +& +\begin{verbatim} +package q where + A = [ data X = X ] -Cabal is the build system for GHC, we can think of it as parsing a Cabal -file describing a package, and then making (possibly multiple) -invocations to GHC to perform the appropriate compilation. What -information does Cabal pass onto GHC\@? One can get an idea for this by -looking at a prototypical command line that Cabal invokes GHC with: + include p (A, P as P1) + include p (A, P as P2) + Q = [ import P1; ... ] +\end{verbatim} +& \begin{verbatim} -ghc --make - -package-name myapp-0.1 - -hide-all-packages - -package-id containers-0.9-ABCD - Module1 Module2 +package a where + A = [ data X = X ] +package q where + include a + include p (A, P as P1) + include p (A, P as P2) + Q = [ import P1; ... ] \end{verbatim} + \\ + (a) Declaration applicativity \ding{54} & + (b) Module applicativity \ding{52} & + (c) Package applicativity \ding{52} \\ +\end{tabular} +\caption{Choices of granularity of applicativity on \pname{p}: given \texttt{data Y = Y X}, is \m{P1}.\texttt{Y} equal to \m{P2}.\texttt{Y}?}\label{fig:applicativity} +\end{figure} +\end{savenotes} -There are a few things going on here. First, Cabal has to tell GHC -what the name of the package it's compiling (otherwise, GHC can't appropriately -generate symbols that other code referring to this package might generate). -There are also a number of commands which configure its in-memory view of -the package database (GHC's view of the package database may not directly -correspond to what is on disk). There's also an optimization here: in principle, -GHC can compile each module one-by-one, but instead we use the \verb|--make| flag -because this allows GHC to reuse some data structures, resulting in a nontrivial -speedup. +\subsection{The granularity of dependency} -(ToDo: describe cabal-install/sandbox) +\begin{savenotes} +\newcolumntype{C}{>{\centering\arraybackslash}p{0.3\textwidth}} +\begin{figure} + \begin{tabular}{C C C} +\begin{verbatim} +package p(A,P) where + A :: [ data X ] + P = [ + import A + data T = T + data Y = Y X + ] +\end{verbatim} +& +\begin{verbatim} +package p(A,P) where + A :: [ data X ] + B = [ data T = T ] + C = [ + import A + data Y = Y X + ] + P = [ + import B + import C + ] +\end{verbatim} +& +\begin{verbatim} +package b where + B = [ data T = T ] +package c where + A :: [ data X ] + C = [ + import A + data Y = Y X + ] +package p(A,P) where + include b; include c + P = [ import B; import C ] +\end{verbatim} + \\ + (a) Declaration granularity \ding{54} & + (b) Module granularity \ding{54} & + (c) Package granularity \ding{52} \\ +\end{tabular} +\caption{Choices of granularity for dependency: is the identity of \texttt{T} independent of how \m{A} is instantiated?}\label{fig:granularity} +\end{figure} -\section{Goals} +\end{savenotes} -There are actually a number of different goals we have for modifying the -packaging system, some of which are subsets of the Backpack system. +In the previous section, we considered \emph{what} entities may be considered for +computing dependency; in this section we consider \emph{which} entities are actually +considered as part of the dependencies for the declaration/module/package we're writing. +Figure~\ref{fig:granularity} contains a series of examples which exemplify the choice +of whether or not to collect dependencies on a per-declaration, per-module or per-package basis: \begin{itemize} - \item As a prerequisite, support multiple instances of containers-2.9 \emph{in the - package database}. These instances may be compiled against - different dependencies, have the same dependencies but different - source files (as when a package is being developed), or be - compiled with different options. It is less important to allow - these instances to be linkable together.\footnote{Actually, I think - this is completely orthogonal to Backpack, since we are going to treat - dependencies as part of the package ID, so they would be considered - separate entries in the package database anyway.} - - \item Support typechecking a library against a module interface - as opposed to an actual implementation. This would be useful - for moving towards a model where Cabal package dependency versions - are replaced with proper signature packages. % See Section~\ref{sec:signature-packages} for more details. - - \item Support compiling the aforementioned libraries with actual implementations. - It is \emph{not} a goal to be able to compile a library while only - partially providing dependencies, and it is low priority to support - mutually recursive implementations of these implementations. - - \iffalse% - \item Support insertion of backwards compatibility shims for packages - that are using old versions of packages, so that you can continue - using them without having to patch them manually. This is a - stylized use-case of Backpack features. See Section~LINKME for - more details. - - \item Some easy-to-implement subset of the functionality provided by - packages with holes (Backpack proper). This includes support - of linking an executable containing multiple packages with the - same package name but different PackageIds. - \fi + \item Package-level granularity states that the modules in a package are +considered to depend on \emph{all} of the holes in the package, even if +the hole is never imported. Figure~\ref{fig:granularity}c is factored so that +\verb|T| is defined in a distinct package \pname{b} with no holes, so no matter +the choice of \m{A}, \m{B}.\verb|T| will be the same. On the other hand, in +Figure~\ref{fig:granularity}b, there is a hole in the package defining \m{B}, +so the identity of \verb|T| will depend on the choice of \m{A}. + +\item Module-level granularity states that each module has its own dependency, +computed by looking at its import statements. In this setting, \verb|T| in Figure~\ref{fig:granularity}b +is independent of \m{A}, since the hole is never imported in \m{B}. But once again, in +Figure~\ref{fig:granularity}a, there is an import in the module defining \verb|T|, +so the identity of \verb|T| once again depends on the choice of \m{A}. + +\item Finally, at the finest level of granularity, one could chop up \pname{p} in +Figure~\ref{fig:granularity}a, looking at the type declaration-level dependency +to suss out whether or not \verb|T| depends on \m{A}. It doesn't refer to +anything in \m{A}, so it is always considered the same. \end{itemize} -A lower priority goal is to actually allow multiple instances of -containers-2.9 to be linked together in the same executable -program.\footnote{In particular, this requires changes to how linker -symbols are assigned. However, this feature is important to -implement a number of Backpack features.} +It is well worth noting that the system described by Paper Backpack tracks dependencies per module; +however, we have decided that we will implement tracking per package instead: +a coarser grained granularity which accepts less programs. + +Is a finer form of granularity \emph{better?} Not necessarily! For +one, we can always split packages into further subpackages (as was done +in Figure~\ref{fig:granularity}c) which better reflect the internal hole +dependencies, so it is always possible to rewrite a program to make it +typecheck---just with more packages. Additionally, the finer the +granularity of dependency, the more work I have to do to understand what +the identities of entities in a module are. In Paper Backpack, I have +to understand the imports of all modules in a package; with +declaration-granularity, I have to understand the entire code. This is +a lot of work for the developer to think about; a more granular model is +easier to remember and reason about. Finally, package-level granularity +is much easier to implement, as it preserves the previous compilation +model, \emph{one library per package}. At a fine level of granularity, we +may end up repeatedly compiling a module which actually should be considered +``the same'' as any other instance of it. + +Nevertheless, finer granularity can be desirable from an end-user perspective. +Usually, these circumstances arise when library-writers are forced to split their +components into many separate packages, when they would much rather have written +a single package. For example, if I define a data type in my library, and would +like to define a \verb|Lens| instance for it, I would create a new package just +for the instance, in order to avoid saddling users who aren't interested in lenses +with an extra dependency. Another example is test suites, which have dependencies +on various test frameworks that a user won't care about if they are not planning +on testing the code. (Cabal has a special case for this, allowing the user +to write effectively multiple packages in a single Cabal file.) + +\subsection{Summary} + +We can summarize all of the various schemes by describing the internal data +types that would be defined by GHC under each regime. First, we have +the shared data structures, which correspond closely to what users are +used to seeing: -A \emph{non-goal} is to allow users to upgrade upstream libraries -without recompiling downstream. This is an ABI concern and we're not -going to worry about it. - -\section{Aside: Recent IHG work}\label{sec:ihg} - -The IHG project has allocated some funds to relax the package instance -constraint in the package database, so that multiple instances can be -stored, but now the user of GHC must explicitly list package-IDs to be -linked against. In the far future, it would be expected that tools like -Cabal automatically handle instance selection among a large number of -instances, but this is subtle and so this work is only to do some -foundational work, allowing a package database to optionally relax the -unique package-version requirement, and utilize environment files to -select which packages should be used. See Duncan's email for more -details on the proposal. - -To implement this: - -\begin{enumerate} - - \item Remove the ``removal step'' when registering a package (with a flag) - - \item Check \ghcfile{compiler/main/Packages.lhs}:mkPackagesState to look out for shadowing - within a database. We believe it already does the right thing, since - we already need to handle shadowing between the local and global database. +\begin{verbatim} +<pkg-name> ::= containers, ... +<pkg-version ::= 1.0, ... +<pkg-id> ::= <pkg-name>-<pkg-version> +<mod-name> ::= Data.Set, ... +<occ> ::= empty, ... +\end{verbatim} -\end{enumerate} +Changing the \textbf{granularity of applicativity} modifies how we represent the +list of dependencies associated with an entity. With module applicativity, +we list module identities (not yet defined); with declaration applicativity +we actually list the original names (i.e., ids). -Once these changes are implemented, we can program multiple instances by -using \verb|-hide-all-packages -package-id ...|, even if there is no -high-level tool support. - -Actually, this concern is orthogonal to the purposes of Backpack, if -we redefine PackageId appropriately. - -\paragraph{The ABI hash} Currently, InstalledPackageId -is constructed of a package, version and ABI hash -(generateRegistrationInfo in -\ghcfile{libraries/Cabal/Cabal/Distribution/Simple/Register.hs}). The -use of an ABI hash is a bit of GHC-specific hack introduced in 2009, -intended to make sure these installed package IDs are unique. While -this is quite clever, using the ABI is actually a bit inflexible, as one -might reasonably want to have multiple copies of a package with the same -ABI but different source code changes.\footnote{In practice, our ABIs -are so unstable that it doesn't really matter.} - -In Figure~\ref{fig:proposed-pkgid}, there is an alternate logical -representation of InstalledPackageId which attempts to extricate the -notion of ABI compatibility from what actually might uniquely identify a -package beyond its PackageId. We imagine these components to be: +\begin{verbatim} +<deps> ::= <id>, ... # Declaration applicativity +<deps> ::= <module>, ... # Module applicativity +\end{verbatim} -\begin{itemize} - \item A hash of the source code (so one can register different - in-development versions without having to bump the version - number); - \item Compilation way (profiling? dynamic?) - \item Compilation flags (such as compilation way, optimization, - profiling settings)\footnote{This is a little undefined on a package bases, because in principle the flags could be varied on a per-file basis. More likely this will be approximated against the relevant fields in the Cabal file as well as arguments passed to Cabal.}; -\end{itemize} +Changing the \textbf{granularity of dependency} affects how we compute +the lists of dependencies, and what entities are well defined: -A historical note: in the 2012 GSoC project to allow multiple instances -of a package to be installed at the same time, use of \emph{random -numbers} was used to workaround the inability to get an ABI early -enough. We are not using this plan. +\begin{verbatim} +# Package-level granularity +<pkg-key> ::= hash(<pkg-id> + <deps for pkg>) +<module> ::= <pkg-key> : <mod-name> +<id> ::= <module> . <occ> + +# Module-level granularity +<pkg-key> not defined +<module> ::= hash(<pkg-id> : <mod-name> + <deps for mod>) +<id> ::= <module-key> . <occ> + +# Declaration-level granularity +<pkg-key> not defined +<module> not defined +<id> ::= hash(<pkg-id> : <mod-name> . <occ> + <deps for decl>) +\end{verbatim} -\section{Infrastructural improvements} +Notice that as we increase the granularity, the notion of a ``package'' and a ``module'' +become undefined. This is because, for example, with module-level granularity, a single +``package'' may result in several modules, each of which have different sets of +dependencies. It doesn't make much sense to refer to the package as a monolithic entity, +because the point of splitting up the dependencies was so that if a user relies only +on a single module, it has a correspondingly restricted set of dependencies. +\subsection{The new scheme, formally} + +\begin{wrapfigure}{R}{0.5\textwidth} +\begin{myfig} +\[ +\begin{array}{@{}lr@{\;}c@{\;}l@{}} + \text{Package Names (\texttt{PkgName})} & P &\in& \mathit{PkgNames} \\ + \text{Module Path Names (\texttt{ModName})} & p &\in& \mathit{ModPaths} \\ + \text{Module Identity Vars} & \alpha,\beta &\in& \mathit{IdentVars} \\ + \text{Package Key (\texttt{PackageKey})} & \K &::=& P(\vec{p\mapsto\nu}) \\ + \text{Module Identities (\texttt{Module})} & \nu &::=& + \alpha ~|~ + \K\colon\! p \\ + \text{Module Identity Substs} & \phi,\theta &::=& + \{\vec{\alpha \coloneqq \nu}\} \\ +\end{array} +\] +\caption{Module Identities} +\label{fig:mod-idents} +\end{myfig} +\end{wrapfigure} + +In this section, we give a formal treatment of our choice in the design space, in the +same style as the Backpack paper, but omitting mutual recursion, as it follows straightforwardly. +Physical module +identities $\nu$, the \texttt{Module} component of \emph{original names} in GHC, are either (1) \emph{variables} $\alpha$, which are +used to represent holes\footnote{In practice, these will just be fresh paths in a special package key for variables.} or (2) a concrete module $p$ defined in package +$P$, with holes instantiated with other module identities (might be +empty)\footnote{In Paper Backpack, we would refer to just $P$:$p$ as the identity +constructor. However, we've written the subterms specifically next to $P$ to highlight the semantic difference of these terms.}. + +As in traditional Haskell, every package contains a number of module +files at some module path $p$; within a package these paths are +guaranteed to be unique.\footnote{In Paper Backpack, the module expressions themselves are used to refer to globally unique identifiers for each literal. This makes the metatheory simpler, but for implementation purposes it is convenient to conflate the \emph{original} module path that a module is defined at with its physical identity.} When we write inline module definitions, we assume +that they are immediately assigned to a module path $p$ which is incorporated +into their identity. A module identity $\nu$ simply augments this +with subterms $\vec{p\mapsto\nu}$ representing how \emph{all} holes in the package $P$ +were instantiated.\footnote{In Paper Backpack, we do not distinguish between holes/non-holes, and we consider all imports of the \emph{module}, not the package.} This naming is stable because the current Backpack surface syntax does not allow a logical path in a package +to be undefined. A package key is $P(\vec{p\mapsto\nu})$. + +Here is the very first example from +Section 2 of the original Backpack paper, \pname{ab-1}: + +\begin{example} +\Pdef{ab-1}{ + \Pmod{A}{x = True} + \Pmod{B}{\Mimp{A}; y = not x} + % \Pmodd{C}{\mname{A}} +} +\end{example} + +The identities of \m{A} and \m{B} are +\pname{ab-1}:\mname{A} and \pname{ab-1}:\mname{B}, respectively.\footnote{In Paper Backpack, the identity for \mname{B} records its import of \mname{A}, but since it is definite, this is strictly redundant.} In a package with holes, each +hole (within the package definition) gets a fresh variable as its +identity, and all of the holes associated with package $P$ are recorded. Consider \pname{abcd-holes-1}: + +\begin{example} +\Pdef{abcd-holes-1}{ + \Psig{A}{x :: Bool} % chktex 26 + \Psig{B}{y :: Bool} % chktex 26 + \Pmod{C}{x = False} + \Pmodbig{D}{ + \Mimpq{A}\\ + \Mimpq{C}\\ + % \Mexp{\m{A}.x, z}\\ + z = \m{A}.x \&\& \m{C}.x + } +} +\end{example} + +The identities of the four modules +are, in order, $\alpha_a$, $\alpha_b$, $\pname{abcd-holes-1}(\alpha_a,\alpha_b)$:\mname{C}, and +$\pname{abcd-holes-1}(\alpha_a,\alpha_b)$:\mname{D}.\footnote{In Paper Backpack, the granularity is at the module level, so the subterms of \mname{C} and \mname{D} can differ.} We include both $\alpha_a$ and $\alpha_b$ in both \mname{C} and \mname{D}, regardless of the imports. When we link the package against an implementation of the hole, these variables are replaced with the identities of the modules we linked against. + +Shaping proceeds in the same way as in Paper Backpack, except that the +shaping judgment must also accept the package key +$P(\vec{p\mapsto\alpha})$ so we can create identifiers with +\textsf{mkident}. This implies we must know ahead of time what the holes +of a package are. + +\paragraph{A full Backpack comparison} +If you're curious about how the rest of the Backpack examples translate, +look no further than this section. + +First, consider the module identities in the \m{Graph} instantiations in +\pname{multinst}, shown in Figure 2 of the original Backpack paper. +In the definition of \pname{structures}, assume that the variables for +\m{Prelude} and \m{Array} are $\alpha_P$ and $\alpha_A$ respectively. +The identity of \m{Graph} is $\pname{structures}(\alpha_P, \alpha_A)$:\m{Graph}. Similarly, the identities of the two array implementations +are $\nu_{AA} = \pname{arrays-a}(\alpha_P)$:\m{Array} and +$\nu_{AB} = \pname{arrays-b}(\alpha_P)$:\m{Array}.\footnote{Notice that the subterms coincide with Paper Backpack! A sign that module level granularity is not necessary for many use-cases.} + +The package \pname{graph-a} is more interesting because it +\emph{links} the packages \pname{arrays-a} and \pname{structures} +together, with the implementation of \m{Array} from \pname{arrays-a} +\emph{instantiating} the hole \m{Array} from \pname{structures}. This +linking is reflected in the identity of the \m{Graph} module in +\pname{graph-a}: whereas in \pname{structures} it was $\nu_G = +\pname{structures}(\alpha_P, \alpha_A)$:\m{Graph}, in \pname{graph-a} it is +$\nu_{GA} = \nu_G[\nu_{AA}/\alpha_A] = \pname{structures}(\alpha_P, \nu_{AA})$:\m{Graph}. Similarly, the identity of \m{Graph} in +\pname{graph-b} is $\nu_{GB} = \nu_G[\nu_{AB}/\alpha_A] = +\pname{structures}(\alpha_P, \nu_{AB})$:\m{Graph}. Thus, linking consists +of substituting the variable identity of a hole by the concrete +identity of the module filling that hole. + +Lastly, \pname{multinst} makes use of both of these \m{Graph} +modules, under the aliases \m{GA} and \m{GB}, respectively. +Consequently, in the \m{Client} module, \code{\m{GA}.G} and +\code{\m{GB}.G} will be correctly viewed as distinct types since they +originate in modules with distinct identities. + +As \pname{multinst} illustrates, module identities effectively encode +dependency graphs at the package level.\footnote{In Paper Backpack, module identities +encode dependency graphs at the module level. In both cases, however, what is being +depended on is always a module.} Like in Paper Backpack, we have an \emph{applicative} +semantics of instantiation, and the applicativity example in Figure 3 of the +Backpack paper still type checks. However, because we are operating at a coarser +granularity, modules may have spurious dependencies on holes that they don't +actually depend on, which means less type equalities may hold. + + +\subsection{Cabal dependency resolution} + +Currently, when we compile a Cabal +package, Cabal goes ahead and resolves \verb|build-depends| entries with actual +implementations, which we compile against. A planned addition to the package key, +independent of Backpack, is to record the transitive dependency tree selected +during this dependency resolution process, so that we can install \pname{libfoo-1.0} +twice compiled against different versions of its dependencies. +What is the relationship to this transitive dependency tree of \emph{packages}, +with the subterms of our package identities which are \emph{modules}? Does one +subsume the other? In fact, these are separate mechanisms---two levels of indirections, +so to speak. + +To illustrate, suppose I write a Cabal file with \verb|build-depends: foobar|. A reasonable assumption is that this translates into a +Backpack package which has \verb|include foobar|. However, this is not +actually a Paper Backpack package: Cabal's dependency solver has to +rewrite all of these package references into versioned references +\verb|include foobar-0.1|. For example, this is a pre-package: -There are some infrastructural improvements that must be made before -Backpack proper can be implemented. These additions are described in -red in the architectural diagrams. The current structure of this -section is to describe the additions bottom up. +\begin{verbatim} +package foo where + include bar +\end{verbatim} -\subsection{Concrete physical identity = PackageId$^*$ + Module name}\label{sec:ipi} +and this is a Paper Backpack package: -\begin{figure} - \center{\begin{tabular}{r l} - PackageId & hash of ``package name, package version, PackageIds of dependent packages'' \\ - InstalledPackageId & hash of ``PackageId, source code, way, compiler flags'' \\ - \end{tabular}} -\label{fig:proposed-pkgid}\caption{Proposed new structure of package identifiers.} -\end{figure} +\begin{verbatim} +package foo-0.3[bar-0.1[baz-0.2]] where + include bar-0.1[baz-0.2] +\end{verbatim} -In Backpack, there needs to be some mechanism for assigning -\emph{physical module identities} to modules, which are essential for -typechecking Backpack packages, since they let us tell if two types are -equal or not. In the paper, the physical identity was represented as the -package that constructed it as well as some representation of the module -source. We can simplify this slightly: in current Cabal packages, we -require that modules always be given a package-unique logical name; -thus, physical identities can be simply represented as a PackageId plus -module name. (See \ghcfile{compiler/basicTypes/Module.lhs:Module}) -In fact, this coincides with how GHC already internally handles -the problem of type equality: it appeals to an \emph{original name} -which is, presently, a PackageId and the module name. - -However, with the current representation of PackageIds, this is -insufficient: a package is not just its name, but also the regular -tree representing all of its package dependencies. Thus, we have -to adjust the representation of a PackageId so that it includes this -regular tree, as seen Figure~\ref{fig:proposed-pkgid}. Since this -tree in general may be quite long, it needs to be shortened in some way, -such as by hashing. - -And now, the complications\ldots - -\paragraph{Relaxing package selection restrictions} As mentioned -previously, GHC is unable to select multiple packages with the same -package name (but different PackageIds). This restriction needs to be -lifted. For backwards compatibility reasons, it's probably better to -not overload \verb|-package-id| but add a new flag, maybe \verb|-force-package-id|; -we also need to disable the old version masking behavior. This is orthogonal -to the IHG work, which wants to allow multiple InstalledPackageIds in the -\emph{database} (here, we want to allow multiple PackageIds in compiled code). +This tree is very similar to the one tracking dependencies for holes, +but we must record this tree \emph{even} when our package has no holes. +% As a final example, the full module +% identity of \m{B1} in Figure~\ref{fig:granularity} may actually be $\pname{p-0.9(q-1.0[p-0.9]:A1)}$:\m{B}. \paragraph{Linker symbols} As we increase the amount of information in PackageId, it's important to be careful about the length of these IDs, as they are used for exported linker symbols (e.g. \verb|base_TextziReadziLex_zdwvalDig_info|). Very long symbol names hurt compile and link time, object file sizes, GHCi startup time, -dynamic linking, and make gdb hard to use. As such, the current plan is -to do away with full package names and versions, and instead use just a -base-62 encoded hash, perhaps with the first four characters of the package +dynamic linking, and make gdb hard to use. As such, we are going to +do away with full package names and versions and instead use just a +base-62 encoded hash, with the first five characters of the package name for user-friendliness. -Edward: I'm still partial to a short hash of the dependency bits (or -even Simon's registry of short strings to dependency trees), and keeping -everything else the same. - -\paragraph{Wired-in names} One annoying thing to remember is that GHC -has wired-in names, which refer to packages without any version. Now -these wired names also have to accomodate dependency trees. A -suggested approach is to have a fixed table from these wired names to -package IDs; alternately we can use something like the special \verb|inplace| -version number. - -\paragraph{Free variables (or, what is a non-concrete physical -identity?)} Physical identities in their full generality are permitted -to have free variables, which represent holes. Handling this is a -tricky question, and we defer it to Section~\ref{sec:typechecking-indefinite}, when -we talk about packages with holes. - -\subsection{Exposed modules should allow external modules}\label{sec:reexport} - -In Backpack, the definition of a package consists of a logical context, -which maps logical module names to physical module names. These do not -necessarily coincide, since some physical modules may have been defined -in other packages and mixed into this package. This mapping specifies -what modules other packages including this package can access. -However, in the current installed package database, we have exposed-modules which -specify what modules are accessible, but we assume that the current -package is responsible for providing these modules. - -To implement Backpack, we have to extend this exposed-modules (``Export declarations'' -on Figure~\ref{fig:pkgdb}). Rather -than a list of logical module names, we provide a new list of tuples: -the exported logical module name and original physical module name (this -is in two parts: the InstalledPackageId and the original module name). -For example, an traditional module export is simply (Name, my-pkg-id, Name); -a renamed module is (NewName, my-pkg-id, OldName), and an external module -is (Name, external-pkg-id, Name). - -As an example: - -\begin{verbatim} -package P where - M = ... - N = ... -package Q (M, R, T) - include P (N -> R) - T = ... -\end{verbatim} +\subsection{Package selection} + +When I fire up \texttt{ghci} with no arguments, GHC somehow creates +out of thin air some consistent set of packages, whose modules I can +load using \texttt{:m}. This functionality is extremely handy for +exploratory work, but actually GHC has to work quite hard in order +to generate this set of packages, the contents of which are all +dumped into a global namespace. For example, GHC doesn't have access +to Cabal's dependency solver, nor does it know \emph{which} packages +the user is going to ask for, so it can't just run a constraint solver, +get a set of consistent packages to offer and provide them to the user.\footnote{Some might +argue that depending on a global environment in this fashion is wrong, because +when you perform a build in this way, you have absolutely no ideas what +dependencies you actually ended up using. But the fact remains that for +end users, this functionality is very useful.} + +To make matters worse, while in the current design of the package database, +a package is uniquely identified by its package name and version, in +the Backpack design, it is \emph{mandatory} that we support multiple +packages installed in the database with the same package name and version, +and this can result in complications in the user model. This further +complicates GHC's default package selection algorithm. + +In this section, we describe how the current algorithm operates (including +what invariants it tries to uphold and where it goes wrong), and how +to replace the algorithm to handle generalization to +multiple instances in the package database. We'll also try to tease +apart the relationship between package keys and installed package IDs in +the database. + +\paragraph{The current algorithm} Abstractly, GHC's current package +selection algorithm operates as follows. For every package name, select +the package with the latest version (recall that this is unique) which +is also \emph{valid}. A package is valid if: -And now if we look at Q\@: +\begin{itemize} + \item It exists in the package database, + \item All of its dependencies are valid, + \item It is not shadowed by a package with the same package ID\footnote{Recall that currently, a package ID uniquely identifies a package in the package database} in + another package database (unless it is in the transitive closure + of a package named by \texttt{-package-id}), and + \item It is not ignored with \texttt{-ignore-package}. +\end{itemize} -\begin{verbatim} -exposed-modules: - <M, P.id, M> - <R, P.id, N> - <T, Q.id, T> -\end{verbatim} +Package validity is probably the minimal criterion for to GHC to ensure +that it can actually \emph{use} a package. If the package is missing, +GHC can't find the interface files or object code associated with the +package. Ignoring packages is a way of pretending that a package is +missing from the database. + +Package validity is also a very weak criterion. Another criterion we +might hope holds is \emph{consistency}: when we consider the transitive +closure of all selected packages, for any given package name, there +should only be one instance providing that package. It is trivially +easy to break this property: suppose that I have packages \pname{a-1.0}, +\pname{b-1.0} compiled against \pname{a-1.0}, and \pname{a-1.1}. GHC +will happily load \pname{b-1.0} and \pname{a-1.1} together in the same +interactive session (they are both valid and the latest versions), even +though \pname{b-1.0}'s dependency is inconsistent with another package +that was loaded. The user will notice if they attempt to treat entities +from \pname{a} reexported by \pname{b-1.0} and entities from +\pname{a-1.1} as type equal. Here is one user who had this problem: +\url{http://stackoverflow.com/questions/12576817/}. In some cases, the +problem is easy to work around (there is only one offending package +which just needs to be hidden), but if the divergence is deep in two +separate dependency hierarchies, it is often easier to just blow away +the package database and try again. + +Perversely, destructive reinstallation helps prevent these sorts of +inconsistent databases. While inconsistencies can arise when multiple +versions of a package are installed, multiple versions will frequently +lead to the necessity of reinstalls. In the previous example, if a user +attempts to Cabal install a package which depends on \pname{a-1.1} and +\pname{b-1.0}, Cabal's dependency solver will propose reinstalling +\pname{b-1.0} compiled against \pname{a-1.1}, in order to get a +consistent set of dependencies. If this reinstall is accepted, we +invalidate all packages in the database which were previously installed +against \pname{b-1.0} and \pname{a-1.0}, excluding them from GHC's +selection process and making it more likely that the user will see a +consistent view of the database. + +\paragraph{Enforcing consistent dependencies} From the user's +perspective, it would be desirable if GHC never loaded a set of packages +whose dependencies were inconsistent. +There are two ways we can go +about doing this. First, we can improve GHC's logic so that it doesn't +pick an inconsistent set. However, as a point of design, we'd like to +keep whatever resolution GHC does as simple as possible (in an ideal +world, we'd skip the validity checks entirely, but they ended up being +necessary to prevent broken database from stopping GHC from starting up +at all). In particular, GHC should \emph{not} learn how to do +backtracking constraint solving: that's in the domain of Cabal. Second, +we can modify the logic of Cabal to enforce that the package database is +always kept in a consistent state, similar to the consistency check +Cabal applies to sandboxes, where it refuses to install a package to a +sandbox if the resulting dependencies would not be consistent. + +The second alternative is a appealing, but Cabal sandboxes are currently +designed for small, self-contained single projects, as opposed to the +global ``universe'' that a default environment is intended to provide. +For example, with a Cabal sandbox environment, it's impossible to +upgrade a dependency to a new version without blowing away the sandbox +and starting again. To support upgrades, Cabal needs to do some work: +when a new version is put in the default set, all of the +reverse-dependencies of the old version are now inconsistent. Cabal +should offer to hide these packages or reinstall them compiled against +the latest version. Furthermore, because we in general may not have write +access to all visible package databases, this visibility information +must be independent of the package databases themselves. + +As a nice bonus, Cabal should also be able to snapshot the older +environment which captures the state of the universe prior to the +installation, in case the user wants to revert back. + +\paragraph{Modifying the default environment} Currently, after GHC +calculates the default package environment, a user may further modify +the environment by passing package flags to GHC, which can be used to +explicitly hide or expose packages. How do these flags interact with +our Cabal-managed environments? Hiding packages is simple enough, +but exposing packages is a bit dicier. If a user asks for a different +version of a package than in the default set, it will probably be +inconsistent with the rest of the dependencies. Cabal would have to +be consulted to figure out a maximal set of consistent packages with +the constraints given. Alternatively, we could just supply the package +with no claims of consistency. + +However, this use-case is rare. Usually, it's not because they want a +specific version: the package is hidden simply because we're not +interested in loading it by default (\pname{ghc-api} is the canonical +example, since it dumps a lot of modules in the top level namespace). +If we distinguish packages which are consistent but hidden, their +loads can be handled appropriately. + +\paragraph{Consistency in Backpack} We have stated as an implicit +assumption that if we have both \pname{foo-1.0} and \pname{foo-1.1} +available, only one should be loaded at a time. What are the +consequences if both of these packages are loaded at the same time? An +import of \m{Data.Foo} provided by both packages would be ambiguous and +the user might find some type equalities they expect to hold would not. +However, the result is not \emph{unsound}: indeed, we might imagine a +user purposely wanting two different versions of a library in the same +program, renaming the modules they provided so that they could be +referred to unambiguously. As another example, suppose that we have an +indefinite package with a hole that is instantiated multiple times. In +this case, a user absolutely may want to refer to both instantiations, +once again renaming modules so that they have unique names. + +There are two consequences of this. First, while the default package +set may enforce consistency, a user should still be able to explicitly +ask for a package instance, renamed so that its modules don't conflict, +and then use it in their program. Second, instantiated indefinite packages +should \emph{never} be placed in the default set, since it's impossible +to know which instantiation is the one the user prefers. A definite package +can reexport an instantiated module under an unambiguous name if the user +so pleases. + +\paragraph{Shadowing, installed package IDs, ABI hashes and package +keys} Shadowing plays an important role for maintaining the soundness of +compilation; call this the \emph{compatibility} of the package set. The +problem it addresses is when there are two distinct implementations of a +module, but because their package ID (or package key, in the new world +order) are the same, they are considered type equal. It is absolutely +wrong for a single program to include both implementations +simultaneously (the symbols would conflict and GHC would incorrectly +conclude things were type equal when they're not), so \emph{shadowing}'s +job is to ensure that only one instance is picked, and all the other +instances considered invalid (and their reverse-dependencies, etc.) +Recall that in current GHC, within a package database, a package +instance is uniquely identified by its package ID\@; thus, shadowing +only needs to take place between package databases. An interesting +corner case is when the same package ID occurs in both databases, but +the installed package IDs are the \emph{same}. Because the installed +package ID is currently simply an ABI hash, we skip shadowing, because +the packages are---in principle---interchangeable. + +There are currently a number of proposed changes to this state of affairs: + +\begin{itemize} + \item Change installed package IDs to not be based on ABI hashes. + ABI hashes have a number of disadvantages as identifiers for + packages in the database. First, they cannot be computed until + after compilation, which gave the multi-instance GSoC project a + few years some headaches. Second, it's not really true that + programs with identical ABI hashes are interchangeable: a new + package may be ABI compatible but have different semantics. + Thus, installed package IDs are a poor unique identifier for + packages in the package database. However, because GHC does not + give ABI stability guarantees, it would not be possible to + assume from here that packages with the same installed package + ID are ABI compatible. + + \item Relaxing the uniqueness constraint on package IDs. There are + actually two things that could be done here. First, since we + have augmented package IDs with dependency resolution + information to form package keys, we could simply state that + package keys uniquely identify a package in a database. + Shadowing rules can be implemented in the same way as before, by + preferring the instance topmost on the stack. Second, we could + also allow \emph{same-database} shadowing: that is, not even + package keys are guaranteed to be unique in a database: instead, + installed package IDs are the sole unique identifier of a + package. This architecture is Nix inspired, as the intent is + to keep all package information in a centralized database. +\end{itemize} -When we compile Q, and the interface file gets generated, we have -to generate identifiers for each of the exposed modules. These should -be calculated to directly refer to the ``original name'' of each them; -so for example M and R point directly to package P, but they also -include the original name they had in the original definition. +Without mandatory package environments, same-database shadowing is a bad +idea, because GHC now has no idea how to resolve shadowing. Conflicting +installed package IDs can be simulated by placing them in multiple +package databases (in principle, the databases can be concatenated together +and treated as a single monolitic database.) -\section{Simplifying Backpack}\label{sec:simplifying-backpack} +\section{Shapeless Backpack}\label{sec:simplifying-backpack} Backpack as currently defined always requires a \emph{shaping} pass, which calculates the shapes of all modules defined in a package. @@ -414,15 +956,17 @@ implementation problems: \item \emph{Shaping is a lot of work.} A module shape specifies the providence of all data types and identifiers defined by a module. To calculate this, we must preprocess and parse all - modules, even before we do the type-checking pass. + modules, even before we do the type-checking pass. (Fortunately, + shaping doesn't require a full parse of a module, only enough + to get identifiers. However, it does have to understand import + statements at the same level of detail as GHC's renamer.) \item \emph{Shaping must be done upfront.} In the current Backpack design, all shapes must be computed before any typechecking can occur. While performing the shaping pass upfront is necessary in order to solve the double vision problem (where a module - identity may be influenced by later definitions), it also means - that either GHC must compile an entire package in one go, or it - must first do a shaping pass, and then revisit every module and + identity may be influenced by later definitions), it means + that GHC must first do a shaping pass, and then revisit every module and compile them proper. Nor is it (easily) possible to skip the shaping pass when it is unnecessary, as one might expect to be the case in the absence of mutual recursion. Shaping is not @@ -442,11 +986,14 @@ implementation problems: code without recursive dependencies. Programmers should avoid this code organization, except when it is absolutely necessary. - \item \emph{GHC is architecturally ill-suited for shaping.} Shaping - implies that GHC's internal concept of an ``original name'' be - extended to accommodate module variables. This is an extremely - invasive change to all aspects of GHC, since the original names - assumption is baked quite deeply into the compiler. + \item \emph{GHC is architecturally ill-suited for directly + implementing shaping.} Shaping implies that GHC's internal + concept of an ``original name'' be extended to accommodate + module variables. This is an extremely invasive change to all + aspects of GHC, since the original names assumption is baked + quite deeply into the compiler. Plausible implementations of + shaping requires all these variables to be skolemized outside + of GHC\@. \end{itemize} @@ -466,8 +1013,8 @@ typecheck; but if A defined T on its own, B would not typecheck. Thus, we \emph{cannot} typecheck B until we have done some analysis of A (the shaping analysis!) -So, if we want to jettison the shaping analysis, we'd like a subset -of Backpack which does not allow mutually recursive modules. +Thus, it is beneficial (from an optimization point of view) to +consider a subset of Backpack for which shaping is not necessary. Here is a programming discipline which does just that, which we will call the \textbf{linking restriction}: \emph{Module implementations must be declared before signatures.} Formally, this restriction modifies the rule for merging polarized module shapes ($\widetilde{\tau}_1^{m_1} \oplus \widetilde{\tau}_2^{m_2}$) so that @@ -541,95 +1088,437 @@ As far as the implementation is concerned, we never have to worry about handling module variables; we only need to do extra typechecks against (renamed) interface files. -\subsection{Compilation of definite modules}\label{sec:compiling-definite} +\subsection{Compiling definite packages}\label{sec:compiling} + +% New definitions +\algnewcommand\algorithmicswitch{\textbf{switch}} +\algnewcommand\algorithmiccase{\textbf{case}} +\algnewcommand\algorithmicassert{\texttt{assert}} +% New "environments" +\algdef{SE}[SWITCH]{Switch}{EndSwitch}[1]{\algorithmicswitch\ #1\ \algorithmicdo}{\algorithmicend\ \algorithmicswitch}% +\algdef{SE}[CASE]{Case}{EndCase}[1]{\algorithmiccase\ ``#1''}{\algorithmicend\ \algorithmiccase}% +\algtext*{EndSwitch}% +\algtext*{EndCase}% + +\begin{algorithm} + \caption{Compilation of definite packages (assume \texttt{-hide-all-packages} on all \texttt{ghc} invocations)}\label{alg:compile} +\begin{algorithmic} + \Procedure{Compile}{\textbf{package} $P$ \textbf{where} $\vec{B}$, $H$, $db$}\Comment{}$H$ maps hole module names to identities + \State$flags\gets \nil$ + \State$\mathcal{K}$ $\gets$ \Call{Hash}{$P + H$} + \State% + In-place register the package $\mathcal{K}$ in $db$ + \For{$B$ \textbf{in} $\vec{B}$} + \Case{$p = p\texttt{.hs}$} + \State\Call{Exec}{\texttt{ghc -c} $p$\texttt{.hs} \texttt{-package-db} $db$ \texttt{-package-name} $\mathcal{K}$ $flags$} + \EndCase% + \Case{$p$ $\cc$ $p$\texttt{.hsig}} + \State\Call{Exec}{\texttt{ghc -c} $p$\texttt{.hsig} \texttt{-package-db} $db$ \texttt{--sig-of} $H(p)$ $flags$} + \EndCase% + \Case{$p = p'$} + \State$flags\gets flags$ \texttt{-alias} $p$ $p'$ + \EndCase% + \Case{\Cinc{$P'$} $\langle\vec{p_H\mapsto p_H'}, \vec{p\mapsto p'} \rangle$} + \State\textbf{let} $H'(p_H) = $ \Call{Exec}{\texttt{ghc --resolve-module} $p_H'$ \texttt{-package-db} $db$ $flags$} + \State$\mathcal{K}'\gets$ \Call{Compile}{$P'$, $H'$, $db$}\Comment{}Nota bene: not $flags$ + \State$flags\gets flags$ \texttt{-package} $\mathcal{K}'$ $\langle\vec{p\mapsto p'}\rangle$ + \EndCase% + \EndFor% + \State% + Remove $\mathcal{K}$ from $db$ + \State% + Install the complete package $\mathcal{K}$ to the global database + \State\Return$\mathcal{K}$ + \EndProcedure% +\end{algorithmic} +\end{algorithm} + +The full recursive procedure for compiling a Backpack package using +one-shot compilation is given in Figure~\ref{alg:compile}. We +recursively walk through Backpack descriptions, processing each line by +invoking GHC and/or modifying our package state. Here is a more +in-depth description of the algorithm, line-by-line: + +\paragraph{The parameters} To compile a package description for package +$P$, we need to know $H$, the mapping of holes $p_H$ in package $P$ to +physical module identities $\nu$ which are implementing them; this +mapping is used to calculate the package key $\mathcal{K}$ for the +package in question. Furthermore, we have an inplace package database +$db$ in which we will register intermediate build results, including +partially compiled parent packages which may provide implementations +of holes for packages they include. + +\subsection{Compiling implementations} + +We compile modules in the same way we do today, but with some extra +package visibility $flags$, which let GHC know how to resolve imports +and look up original names. We'll describe what the new flags are +and also discuss some subtleties with module lookup. + +\paragraph{In-place registration} Perhaps surprisingly, we start +compilation by registering the (uncompiled) package in the in-place +package database. This registration does not expose packages, and is +purely intended to inform the compilation of subpackages where to +find modules that are provided by the parent (in-progress) package, +as well as provide auxiliary information, e.g., such as the package name +and version for error reporting. The pre-registration trick is an old +one used by the GHC build system; the key invariant to look out for +is that we shouldn't reference original names in modules that haven't +been built yet. This is enforced by our manual tracking of holes in +$H$: a module can't occur in $H$ unless it's already been compiled! + +\paragraph{New package resolution algorithm} Currently, invocations +of \texttt{-package} and similar flags have the result of \emph{hiding} +other exposed packages with the same name. However, this is not going +to work for Backpack: an indefinite package may get loaded multiple times +with different instantiations, and it might even make sense to load multiple +versions of the same package simultaneously, as long as their modules +are renamed to not conflict. + +Thus, we impose the following behavior change: when +\texttt{-hide-all-packages} is specified, we do \emph{not} automatically +hide packages with the same name as a package specified by +\texttt{-package} (or a similar flag): they are all included, even if +there are conflicts. To deal with conflicts, we augment the syntax of +\texttt{-package} to also accept a list of thinnings and renamings, e.g. +\texttt{-package} \pname{containers} $\langle\m{Data.Set}, +\m{Data.Map}\mapsto \m{Map}\rangle$ says to make visible for import +\m{Data.Set} and \m{Map} (which is \m{Data.Map} renamed.) This means +that +\texttt{-package} \pname{containers-0.9} $\langle\m{Data.Set}\mapsto +\m{Set09}\rangle$ \texttt{-package} \pname{containers-0.8} +$\langle\m{Data.Set}\mapsto \m{Set08}\rangle$ now uses both packages +concurrently (previously, GHC would hide one of them.) + +Additionally, it's important to note that two packages exporting the +same module do not \emph{necessarily} cause a conflict; the modules +may be linkable. For example, \texttt{-package} \pname{containers} $\langle\m{Data.Set}\rangle$ +\texttt{-package} \pname{containers} $\langle\m{Data.Set}\rangle$ is fine, because +precisely the same implementation of \m{Data.Set} is loaded in both cases. +A similar situation can occur with signatures: + +\begin{verbatim} +package p where + A :: [ x :: Int ] +package q + include p + A :: [ y :: Int ] + B = [ import A; z = x + y ] -- * +package r where + A = [ x = 0; y = 0 ] + include q +\end{verbatim} + +Here, both \pname{p} and \pname{q} are visible when compiling the starred +module, which compiles with the flags \texttt{-package} \pname{p}, but there +are two interface files available: one available locally, and one from \pname{p}. +Both of these interface files are \emph{forwarding} to the original implementation +\pname{r} (more on this in the ``Compiling signatures'' file), so rather than +reporting an ambiguous import, we instead have to merge the two interface files +together and use the result as the interface for the module. (This could be done +on the fly, or we could generate merged interface files as we go along.) -Of course, we still have to compile the code, -and this includes any subpackages which we have mixed in the dependencies -to make them fully definite. Let's take the following package as an example: +Note that we do not need to merge signatures with an implementation, in such +cases, we should just use the implementation interface. E.g. \begin{verbatim} -package pkg-a where +package p where + A :: ... +package q where A = ... -package pgk-b where -- indefinite package + include p + B = [ import A ] -- * +\end{verbatim} + +Here, \m{A} is available both from \pname{p} and \pname{q}, but the use in the +starred module should be done with respect to the full implementation. + +\paragraph{The \texttt{-alias} flag} We introduce a new flag +\texttt{-alias} for aliasing modules. Aliasing is analogous to +the merging that can occur when we include packages, but it also applies +to modules which are locally defined. When we alias a module $p$ with +$p'$, we require that $p'$ exists in the current module mapping, and then +we attempt to add an entry for it at entry $p$. If there is no mapping for +$p$, this succeeds; otherwise, we apply the same conflict resolution algorithm. + +\subsection{Compiling signatures} + +Signature compilation is triggered when we compile a signature file. +This mode similar to how we process \verb|hs-boot| files, except +we pass an extra flag \verb|--sig-of| which specifies what the +identity of the actual implementation of the signature is (according to our $H$ +mapping). This is guaranteed to exist, due to the linking +restriction, although it may be in a partially registered package +in $db$. If the module is \emph{not} exposed under the name of the +\texttt{hisig}file, we output an \texttt{hisig} file which, for all declarations the +signature exposes, forwards their definitions to the original +implementation file. The intent is that any code in the current package +which compiles against this signature will use this \texttt{hisig} file, +not the original one \texttt{hi} file. +For example, the \texttt{hisig} file produced when compiling the starred interface +points to the implementation in package \pname{q}. + +\begin{verbatim} +package p where + A :: ... -- * + B = [ import A; ... ] +package q where + A = [ ... ] + include p +\end{verbatim} + +\paragraph{Sometimes \texttt{hisig} is unnecessary} +In the following package: + +\begin{verbatim} +package p where + P = ... + P :: ... +\end{verbatim} + +Paper Backpack specifies that we check the signature \m{P} against implementation +\m{P}, but otherwise no changes are made (i.e., the signature does not narrow +the implementation.) In this case, it is not necessary to generate an \texttt{hisig} file; +the original interface file suffices. + +\paragraph{Multiple signatures} As a simplification, we assume that there +is only one signature per logical name in a package. (This prevents +us from expressing mutual recursion in signatures, but let's not worry +about it for now.) + +\paragraph{Restricted recursive modules ala hs-boot}\label{sec:hs-boot-restrict} +When we compile an \texttt{hsig} file without any \texttt{--sig-of} flag (because +no implementation is known), we fall back to old-style GHC mutual recursion. +Na\"\i vely, a shaping pass would be necessary; +so we adopt an existing constraint that +already applies to hs-boot files: \emph{at the time we define a signature, +we must know what the original name for all data types is}. In practice, +GHC enforces this by stating that: (1) an hs-boot file must be +accompanied with an implementation, and (2) the implementation must +in fact define (and not reexport) all of the declarations in the signature. +We can discover if a signature is intended to break a recursive module loop +when we discover that $p\notin flags_H$; in this case, we fallback to the +old hs-boot behavior. (Alternatively, the user can explicitly ask for it.) + +Why does this not require a shaping pass? The reason is that the +signature is not really polymorphic: we require that the $\alpha$ module +variable be resolved to a concrete module later in the same package, and +that all the $\beta$ module variables be unified with $\alpha$. Thus, we +know ahead of time the original names and don't need to deal with any +renaming.\footnote{This strategy doesn't completely resolve the problem +of cross-package mutual recursion, because we need to first compile a +bit of the first package (signatures), then the second package, and then +the rest of the first package.} + +Compiling packages in this way gives the tantalizing possibility +of true separate compilation: the only thing we don't know is what the actual +package name of an indefinite package will be, and what the correct references +to have are. This is a very minor change to the assembly, so one could conceive +of dynamically rewriting these references at the linking stage. But +separate compilation achieved in this fashion would not be able to take +advantage of cross-module optimizations. + +\subsection{Compiling includes} + +Includes are the most interesting part of the compilation process, as we have +calculate how the holes of the subpackage we are filling in are compiled $H'$ +and modify our flags to make the exports of the include visible to subsequently +compiled modules. We consider the case with renaming, since includes with +no renaming are straightforward. + +First, we assume that we know \emph{a priori} what the holes of a +package $p_H$ are (either by some sort of pre-pass, or explicit +declaration.) For each of their \emph{renamed targets} $p'_H$, we look +up the module in the current $flags$ environment, retrieving the +physical module identity by consulting GHC with the +\texttt{--resolve-module} flag and storing it in $H'$. (This can be done in batch.) +For example: + +\begin{verbatim} +package p where A :: ... - B = [ b = ... ] -package pkg-c where - include pkg-a - include pkg-b -\end{verbatim} - -There seem to be two schools of thought for how compilation should proceed. - -\paragraph{The ``downstream'' proposal} This is Simon's favorite -proposal. Because of the linking invariant, if we traverse the Backpack -specification, any given module we need to compile will have all of its -dependencies compiled (since it could only depend on the dependency if -there was a signature, and the signature could not have been linked -unless it was implemented previously.) So we just go ahead and compile -everything one-by-one while traversing the package tree, as if the -package was a single big package. (Of course, if we encounter a -definite package, don't bother recompiling it; just use it directly.) -In particular, we maintain the invariant that any code generated will -export symbols under the current package's namespace. So the identifier -\verb|b| in the example becomes a symbol \verb|pkg-c_pkg-b_B_b| rather -than \verb|pkg-b_B_b| (package subqualification is necessary because -package C may define its own B module after thinning out the import.) - -One big problem with this proposal is that it doesn't implement applicative -semantics beyond compilation units. While modules within a single -compilation will get reused, if there is another package: - -\begin{verbatim} -package pkg-d where - include pkg-a - include pkg-b -\end{verbatim} - -when it is compiled by itself, it will generate its own instance of B, -even though it should be the same as C. Simon was willing to entertain -the idea that, well, as long as the type-checker is able to figure out -they are the same, then it might be OK if we accidentally generate two -copies of the code (provided they actually are the same). - -\paragraph{The ``upstream'' proposal} -The problem with the ``downstream'' proposal is that it always recompiles -all of the indefinite parts of the package, even if some of them should -be shared in some sense. Hypothetically, a fully linked version of an -indefinite package should be considered a package in its own right -(in particular, it is associated with a physical module identity in Backpack). -So all we need to do is store these installed packages somewhere, probably -the local package database. If we recompile the same dependency chain, -the installed package can be simply reused. These products do not have -to be exposed. - -One problem with this proposal is in this example: + ... +package q where + A = [ ... ] + B = [ ... ] + include p (A as B) +\end{verbatim} + +When computing the entry $H(\pname{A})$, we run the command \texttt{ghc --resolve-module} \pname{B}. + +Next, we recursively call \textsc{Compile} with the computed $H'$. +Note that the entries in $H$ may refer to modules which would not be +picked up by $flags$, but they will be registered in the inplace +package database $db$. +For example, in this situation: \begin{verbatim} -package myapp2 where - System.Random = [ ... ].hs - include monte-carlo +package p where + B :: ... + C = [ import B; ... ] +package q where + A = [ ... ] + B = [ import A; ... ] + include p + D = [ import C; ... ] \end{verbatim} -Here, monte-carlo depends on a ``subpart of the myapp2 package'', and it's -not entirely clear how monte-carlo should be represented in the installed -package database: should myapp2 be carved up into pieces so that subparts -of its package description can be installed to the database? One notable -thing to note is that these ``stubs'' will never be used by any other packages, -they are strictly local. +When we recursively process package \pname{p}, $H$ will refer to +\pname{q}:\m{B}, and we need to know where to find it (\pname{q} is only +partially processed and so is in the inplace package database.) +Furthermore, the interface file for \m{B} may refer to \pname{q}:\m{A}, +and thus we likewise need to know how to find its interface file. -Another reason you might not be so keen about this proposal is the fact -that we have to hit the package database, despite the fact that these -are all ostensibly local build products. (But perhaps not!) +Note that the inplace package database is not expected to expose and +packages. Otherwise, this example would improperly compile: + +\begin{verbatim} +package p where + B = [ import A; ... ] +package q where + A = ... + include p +\end{verbatim} + +\pname{p} does not compile on its own, so it should not compile if it is +recursively invoked from \pname{q}. However, if we exposed the modules +of the partially registered package \pname{q}, \m{A} is now suddenly +resolvable. + +Finally, once the subpackage is compiled, we can add it to our $flags$ so later +modules we compile see its (appropriately thinned and renamed) modules, and like +aliasing. + +\paragraph{Absence of an \texttt{hi} file} +It is important that \texttt{--resolve-module} truly looks up the \emph{implementor} +of a module, and not just a signature which is providing it at some name. +Sometimes, a little extra work is necessary to compute this, for example: + +\begin{verbatim} +package p where + A :: [ y :: Int ] +package q where + A :: [ x :: Int ] + include p -- * +package r where + A = [ x = 0; y = 1 ] + include q +\end{verbatim} + +When computing $H'$ for the starred include, our $flags$ only include +\texttt{-package-dir} \pname{r} $cwd_r$ $\langle\rangle$: with a thinning +that excludes all modules! The only interface file we can pick up with these +$flags$ is the local definition of \m{A}. However, we \emph{absolutely} +should set $H'(\m{A})=\pname{q}:\m{A}$; if we do so, then we will incorrectly +conclude when compiling the signature in \pname{p} that the implementation +doesn't export enough identifiers to fulfill the signature (\texttt{y} is not +available from just the signature in \pname{q}). Instead, we have to look +up the original implementor of \m{A} in \pname{r}, and use that in $H'$. + +\subsection{Commentary} + +\paragraph{Just because it compiled, doesn't mean the individual packages type check} +The compilation mechanism described is slightly more permissive than vanilla Backpack. +Here is a simple example: + +\begin{verbatim} +package p where + A :: [ data T = T ] + B :: [ data T = T ] + C = [ + import A + import B + x = A.T :: B.T + ] +package q where + A = [ data T = T ] + B = A + include p +\end{verbatim} + +Here, we incorrectly decide \m{A}\verb|.T| and \m{B}\verb|.T| are type +equal when typechecking \m{C}, because the \verb|hisig| files we +generate for them all point to the same original implementation. However, +\pname{p} should not typecheck. + +The problem here is that type checking asks ``does it compile with respect +to all possible instantiations of the holes'', whereas compilation asks +``does it compile with respect to this particular instantiation of holes.'' +In the absence of a shaping pass, this problem is unavoidable. + +\section{Shaped Backpack} + +Despite the simplicity of shapeless Backpack with the linking +restriction in the absence of holes, we will find that when we have +holes, it will be very difficult to do type-checking without +some form of shaping. This section is very much a work in progress, +but the ability to typecheck against holes, even with the linking restriction, +is a very important part of modular separate development, so we will need +to support it at some point. + +\subsection{Efficient shaping} + +(These are Edward's opinion, he hasn't convinced other folks that this is +the right way to do it.) + +In this section, I want to argue that, although shaping constitutes +a pre-pass which must be run before compilation in earnest, it is only +about as bad as the dependency resolution analysis that GHC already does +in \verb|ghc -M| or \verb|ghc --make|. + +In Paper Backpack, what information does shaping compute? It looks at +exports, imports, data declarations and value declarations (but not the +actual expressions associated with these values.) As a matter of fact, +GHC already must look at the imports associated with a package in order +to determine the dependency graph, so that it can have some order to compile +modules in. There is a specialized parser which just parses these statements, +and then ignores the rest of the file. + +A bit of background: the \emph{renamer} is responsible for resolving +imports and figuring out where all of these entities actually come from. +SPJ would really like to avoid having to run the renamer in order to perform +a shaping pass. + +\paragraph{Is it necessary to run the Renamer to do shaping?} +Edward and Scott believe the answer is no, well, partially. +Shaping needs to know the original names of all entities exposed by a +module/signature. Then it needs to know (a) which entities a module/signature +defines/declares locally and (b) which entities that module/signature exports. +The former, (a), can be determined by a straightforward inspection of a parse +tree of the source file.\footnote{Note that no expression or type parsing +is necessary. We only need names of local values, data types, and data +constructors.} The latter, (b), is a bit trickier. Right now it's the Renamer +that interprets imports and exports into original names, so we would still +rely on that implementation. However, the Renamer does other, harder things +that we don't need, so ideally we could factor out the import/export +resolution from the Renamer for use in shaping. + +Unfortunately the Renamer's import resolution analyzes \verb|.hi| files, but for +local modules, which haven't yet been typechecked, we don't have those. +Instead, we could use a new file format, \verb|.hsi| files, to store the shape of +a locally defined module. (Defined packages are bundled with their shapes, +so included modules have \verb|.hsi| files as well.) (What about the logical +vs.~physical distinction in file names?) If we refactor the import/export +resolution code, could we rewrite it to generically operate on both +\verb|.hi| files and \verb|.hsi| files? + +Alternatively, rather than storing shapes on a per-source basis, we could +store (in memory) the entire package shape. Similarly, included packages +could have a single shape file for the entire package. Although this approach +would make shaping non-incremental, since an entire package's shape would +be recomputed any time a constituent module's shape changes, we do not expect +shaping to be all that expensive. \subsection{Typechecking of indefinite modules}\label{sec:typechecking-indefinite} -When we are typechecking a package that contains some holes, some extra -care must be taken. We can no longer assume that there are no holes in -the physical context, and while these holes will never be linked against -a physical implementation, they may be linked against other signatures. -(Note: while disallowing signature linking would solve our problem, it -would disallow a wide array of useful instances of signature reuse, for -example, a package mylib that implements both mylib-1x-sig and mylib-2x-sig.) +Recall in our argument in the definite case, where we showed there are +no holes in the physical context. With indefinite modules, this is no +longer true. While (with the linking restriction) these holes will never +be linked against a physical implementation, they may be linked against +other signatures. (Note: while disallowing signature linking would +solve our problem, it would disallow a wide array of useful instances of +signature reuse, for example, a package mylib that implements both +mylib-1x-sig and mylib-2x-sig.) With holes, we must handle module variables, and we sometimes must unify them: @@ -688,7 +1577,7 @@ package r where include q \end{verbatim} -Another possibility is that it might be acceptable to do a small shaping +Another possibility is that it might be acceptable to do a mini-shaping pass, without parsing modules or signatures, \emph{simply} looking at names and aliases. But logical names are not the only mechanism by which unification may occur: @@ -705,8 +1594,10 @@ It is easy to conclude that the original names of C and B are the same. But more importantly, C.A must be given the original name of p:A.A. This can only be discovered by looking at the signature definition for B. In any case, it is worth noting that this situation parallels the situation with hs-boot -files (although there is no mutual recursion here). See Section~\ref{sec:hs-boot-restirct} -for more details. +files (although there is no mutual recursion here). + +The conclusion is that you will probably, in fact, have to do real +shaping in order to typecheck all of these examples. \paragraph{Hey, these signature imports are kind of tricky\ldots} @@ -731,6 +1622,93 @@ A\ldots but it will not be defined prior to package p. In any case, however, it would be good to emit a warning if a package cannot be compiled without mutual recursion. +\subsection{Rename on entry} + +Consider the following example: + +\begin{verbatim} +package p where + A :: [ data T = T ] + B = [ import A; x = T ] +package q where + C :: ... + A = [ data T = T ] + include p + D = [ + import qualified A + import qualified B + import C + x = B.T :: A.T + ] +\end{verbatim} + +We are interested in type-checking \pname{q}, which is an indefinite package +on account of the uninstantiated hole \m{C}. Furthermore, let's suppose that +\pname{p} has already been independently typechecked, and its interface files +installed in some global location with $\alpha_A$ used as the module identity +of \m{A}. (To simplify this example, we'll assume $\beta_{AT}=\alpha_A$.) + +The first three lines of \pname{q} type check in the normal way, but \m{D} +now poses a problem: if we load the interface file for \m{B} the normal way, +we will get a reference to type \texttt{T} with the original name $\alpha_A$.\texttt{T}, +whereas from \m{A} we have an original name \pname{q}:\m{A}.\texttt{T}. + +Let's suppose that we already have the result of a shaping pass, which +maps our identity variables to their true identities. +Let's consider the possible options here: + +\begin{itemize} + \item We could re-typecheck \pname{p}, feeding it the correct instantiations + for its variables. However, this seems wasteful: we typechecked the + package already, and up-to-renaming, the interface files are exactly + what we need to type check our application. + \item We could make copies of all the interface files, renamed to have the + right original names. This also seems wasteful: why should we have to + create a new copy of every interface file in a library we depend on? + \item When \emph{reading in} the interface file to GHC, we could apply the + renaming according to the shaping pass and store that in memory. +\end{itemize} + +That last solution is pretty appealing, however, there are still circumstances +we need to create new interface files; these exactly mirror the cases described +in Section~\ref{sec:compiling}. + +\subsection{Incremental typechecking} +We want to typecheck modules incrementally, i.e., when something changes in +a package, we only want to re-typecheck the modules that care about that +change. GHC already does this today.% +\footnote{\url{https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance}} +Is the same mechanism sufficient for Backpack? Edward and Scott think that it +is, mostly. Our conjecture is that a module should be re-typechecked if the +existing mechanism says it should \emph{or} if the logical shape +context (which maps logical names to physical names) has changed. The latter +condition is due to aliases that affect typechecking of modules. + +Let's look again at an example from before: +\begin{verbatim} +package p where + A :: [ data A ] + B :: [ data A ] + M = [ import A; import B; ... ] +\end{verbatim} +Let's say that \verb|M| is typechecked successfully. Now we add an alias binding +at the end of the package, \verb|A = B|. Does \verb|M| need to be +re-typechecked? Yes! (Well, it seems so, but let's just assert ``yes'' for now. +Certainly in the reverse case---if we remove the alias and then ask---this +is true, since \verb|M| might have depended on the two \verb|A| types +being the same.) +The logical shape context changed to say that \verb|A| and +\verb|B| now map to the same physical module identity. But does the existing +recompilation avoidance mechanism say that \verb|M| should be re-typechecked? +It's unclear. The \verb|.hi| file for \verb|M| records that it imported \verb|A| and +\verb|B| with particular ABIs, but does it also know about the physical module +identities (or rather, original module names) of these modules? + +Scott thinks this highlights the need for us to get our story straight about +the connection between logical names, physical module identities, and file +names! + + \subsection{Installing indefinite packages}\label{sec:installing-indefinite} If an indefinite package contains no code at all, we only need @@ -759,25 +1737,712 @@ partway, intending to finish it later. However, our compilation strategy for definite packages requires us to run this step using a \emph{different} choice of original names, so it's unclear how much work could actually be reused. -\subsection{Restricted recursive modules ala hs-boot}\label{sec:hs-boot-restrict} +\section{Surface syntax} -It should be possible to support GHC-style mutual recursion using the -Backpack formalism immediately using hs-boot files. However, to avoid -the need for a shaping pass, we must adopt an existing constraint that -already applies to hs-boot files: \emph{at the time we define a signature, -we must know what the original name for all data types is}. We then -compile modules as usual, but compiling against the signature as if it -were an hs-boot file. +In the Backpack paper, a brand new module language is presented, with +syntax for inline modules and signatures. This syntax is probably worth implementing, +because it makes it easy to specify compatibility packages, whose module +definitions in general may be very short: -(ToDo: Figure out why this eliminates the shaping pass) +\begin{verbatim} +package ishake-0.12-shake-0.13 where + include shake-0.13 + Development.Shake.Sys = Development.Shake.Cmd + Development.Shake = [ (**>) = (&>) ; (*>>) = (|*>)] + Development.Shake.Rule = [ defaultPriority = rule . priority 0.5 ] + include ishake-0.12 +\end{verbatim} -Compiling packages in this way gives the tantalizing possibility -of true separate compilation: the only thing we don't know is what the actual -package name of an indefinite package will be, and what the correct references -to have are. This is a very minor change to the assembly, so one could conceive -of dynamically rewriting these references at the linking stage. +However, there are a few things that are less than ideal about the +surface syntax proposed by Paper Backpack: + +\begin{itemize} + \item It's completely different from the current method users + specify packages. There's nothing wrong with this per se + (one simply needs to support both formats) but the smaller + the delta, the easier the new packaging format is to explain + and implement. + + \item Sometimes order matters (relative ordering of signatures and + module implementations), and other times it does not (aliases). + This can be confusing for users. + + \item Users have to order module definitions topologically, + whereas in current Cabal modules can be listed in any order, and + GHC figures out an appropriate order to compile them. +\end{itemize} + +Here is an alternative proposal, closely based on Cabal syntax. Given +the following Backpack definition: + +\begin{verbatim} +package libfoo(A, B, C, Foo) where + include base + -- renaming and thinning + include libfoo (Foo, Bar as Baz) + -- holes + A :: [ a :: Bool ].hsig + A2 :: [ b :: Bool ].hsig + -- normal module + B = [ + import {-# SOURCE #-} A + import Foo + import Baz + ... + ].hs + -- recursively linked pair of modules, one is private + C :: [ data C ].hsig + D = [ import {-# SOURCE #-} C; data D = D C ].hs + C = [ import D; data C = C D ].hs + -- alias + A = A2 +\end{verbatim} + +We can write the following Cabal-like syntax instead (where +all of the signatures and modules are placed in appropriately +named files): -\section{Implementation plan} +\begin{verbatim} +package: libfoo +... +build-depends: base, libfoo (Foo, Bar as Baz) +holes: A A2 -- deferred for now +exposed-modules: Foo B C +aliases: A = A2 +other-modules: D +\end{verbatim} + +Notably, all of these lists are \emph{insensitive} to ordering! +The key idea is use of the \verb|{-# SOURCE #-}| pragma, which +is enough to solve the important ordering constraint between +signatures and modules. + +Here is how the elaboration works. For simplicity, in this algorithm +description, we assume all packages being compiled have no holes +(including \verb|build-depends| packages). Later, we'll discuss how to +extend the algorithm to handle holes in both subpackages and the main +package itself. + +\begin{enumerate} + + \item At the top-level with \verb|package| $p$ and + \verb|exposed-modules| $ms$, record \verb|package p (ms) where| + + \item For each package $p$ with thinning/renaming $ms$ in + \verb|build-depends|, record a \verb|include p (ms)| in the + Backpack package. The ordering of these includes does not + matter, since none of these packages have holes. + + \item Take all modules $m$ in \verb|other-modules| and + \verb|exposed-modules| which were not exported by build + dependencies, and create a directed graph where hs and hs-boot + files are nodes and imports are edges (the target of an edge is + an hs file if it is a normal import, and an hs-boot file if it + is a SOURCE import). Topologically sort this graph, erroring if + this graph contains cycles (even with recursive modules, the + cycle should have been broken by an hs-boot file). For each + node, in this order, record \verb|M = [ ... ]| or \verb|M :: [ ... ]| + depending on whether or not it is an hs or hs-boot. If possible, + sort signatures before implementations when there is no constraint + otherwise. + +\end{enumerate} + +Here is a simple example which shows how SOURCE can be used to disambiguate +between two important cases. Suppose we have these modules: + +\begin{verbatim} +-- A1.hs +import {-# SOURCE #-} B + +-- A2.hs +import B + +-- B.hs +x = True + +-- B.hs-boot +x :: Bool +\end{verbatim} + +Then we translate the following packages as follows: + +\begin{verbatim} +exposed-modules: A1 B +-- translates to +B :: [ x :: Bool ] +A1 = [ import B ] +B = [ x = True ] +\end{verbatim} + +but + +\begin{verbatim} +exposed-modules: A2 B +-- translates to +B = [ x = True ] +B :: [ x :: Bool ] +A2 = [ import B ] +\end{verbatim} + +The import controls placement between signature and module, and in A1 it +forces B's signature to be sorted before B's implementation (whereas in +the second section, there is no constraint so we preferentially place +the B's implementation first) + +\paragraph{Holes in the database} In the presence of holes, +\verb|build-depends| resolution becomes more complicated. First, +let's consider the case where the package we are building is +definite, but the package database contains indefinite packages with holes. +In order to maintain the linking restriction, we now have to order packages +from step (2) of the previous elaboration. We can do this by creating +a directed graph, where nodes are packages and edges are from holes to the +package which implements them. If there is a cycle, this indicates a mutually +recursive package. In the absence of cycles, a topological sorting of this +graph preserves the linking invariant. + +One subtlety to consider is the fact that an entry in \verb|build-depends| +can affect how a hole is instantiated by another entry. This might be a +bit weird to users, who might like to explicitly say how holes are +filled when instantiating a package. Food for thought, surface syntax wise. + +\paragraph{Holes in the package} Actually, this is quite simple: the +ordering of includes goes as before, but some indefinite packages in the +database are less constrained as they're ``dependencies'' are fulfilled +by the holes at the top-level of this package. It's also worth noting +that some dependencies will go unresolved, since the following package +is valid: + +\begin{verbatim} +package a where + A :: ... +package b where + include a +\end{verbatim} + +\paragraph{Multiple signatures} In Backpack syntax, it's possible to +define a signature multiple times, which is necessary for mutually +recursive signatures: + +\begin{verbatim} +package a where + A :: [ data A ] + B :: [ import A; data B = B A ] + A :: [ import B; data A = A B ] +\end{verbatim} + +Critically, notice that we can see the constructors for both module B and A +after the signatures are linked together. This is not possible in GHC +today, but could be possible by permitting multiple hs-boot files. Now +the SOURCE pragma indicating an import must \emph{disambiguate} which +hs-boot file it intends to include. This might be one way of doing it: + +\begin{verbatim} +-- A.hs-boot2 +data A + +-- B.hs-boot +import {-# SOURCE hs-boot2 #-} A + +-- A.hs-boot +import {-# SOURCE hs-boot #-} B +\end{verbatim} + +\paragraph{Explicit or implicit reexports} One annoying property of +this proposal is that, looking at the \verb|exposed-modules| list, it is +not immediately clear what source files one would expect to find in the +current package. It's not obvious what the proper way to go about doing +this is. + +\paragraph{Better syntax for SOURCE} If we enshrine the SOURCE import +as a way of solving Backpack ordering problems, it would be nice to have +some better syntax for it. One possibility is: + +\begin{verbatim} +abstract import Data.Foo +\end{verbatim} + +which makes it clear that this module is pluggable, typechecking against +a signature. Note that this only indicates how type checking should be +done: when actually compiling the module we will compile against the +interface file for the true implementation of the module. + +It's worth noting that the SOURCE annotation was originally made a +pragma because, in principle, it should have been possible to compile +some recursive modules without needing the hs-boot file at all. But if +we're moving towards boot files as signatures, this concern is less +relevant. + +\section{Type classes and type families} + +\subsection{Background} + +Before we talk about how to support type classes in Backpack, it's first +worth talking about what we are trying to achieve in the design. Most +would agree that \emph{type safety} is the cardinal law that should be +preserved (in the sense that segfaults should not be possible), but +there are many instances of ``bad behavior'' (top level mutable state, +weakening of abstraction guarantees, ambiguous instance resolution, etc) +which various Haskellers may disagree on the necessity of ruling out. + +With this in mind, it is worth summarizing what kind of guarantees are +presently given by GHC with regards to type classes and type families, +as well as characterizing the \emph{cultural} expectations of the +Haskell community. + +\paragraph{Type classes} When discussing type class systems, there are +several properties that one may talk about. +A set of instances is \emph{confluent} if, no matter what order +constraint solving is performed, GHC will terminate with a canonical set +of constraints that must be satisfied for any given use of a type class. +In other words, confluence says that we won't conclude that a program +doesn't type check just because we swapped in a different constraint +solving algorithm. + +Confluence's closely related twin is \emph{coherence} (defined in ``Type +classes: exploring the design space''). This property states that +``every different valid typing derivation of a program leads to a +resulting program that has the same dynamic semantics.'' Why could +differing typing derivations result in different dynamic semantics? The +answer is that context reduction, which picks out type class instances, +elaborates into concrete choices of dictionaries in the generated code. +Confluence is a prerequisite for coherence, since one +can hardly talk about the dynamic semantics of a program that doesn't +type check. + +In the vernacular, confluence and coherence are often incorrectly used +to refer to another related property: \emph{global uniqueness of instances}, +which states that in a fully compiled program, for any type, there is at most one +instance resolution for a given type class. Languages with local type +class instances such as Scala generally do not have this property, and +this assumption is frequently used for abstraction. + +So, what properties does GHC enforce, in practice? +In the absence of any type system extensions, GHC's employs a set of +rules (described in ``Exploring the design space'') to ensure that type +class resolution is confluent and coherent. Intuitively, it achieves +this by having a very simple constraint solving algorithm (generate +wanted constraints and solve wanted constraints) and then requiring the +set of instances to be \emph{nonoverlapping}, ensuring there is only +ever one way to solve a wanted constraint. Overlap is a +more stringent restriction than either confluence or coherence, and +via the \verb|OverlappingInstances| and \verb|IncoherentInstances|, GHC +allows a user to relax this restriction ``if they know what they're doing.'' + +Surprisingly, however, GHC does \emph{not} enforce global uniqueness of +instances. Imported instances are not checked for overlap until we +attempt to use them for instance resolution. Consider the following program: + +\begin{verbatim} +-- T.hs +data T = T +-- A.hs +import T +instance Eq T where +-- B.hs +import T +instance Eq T where +-- C.hs +import A +import B +\end{verbatim} + +When compiled with one-shot compilation, \verb|C| will not report +overlapping instances unless we actually attempt to use the \verb|Eq| +instance in C.\footnote{When using batch compilation, GHC reuses the + instance database and is actually able to detect the duplicated + instance when compiling B. But if you run it again, recompilation +avoidance skips A, and it finishes compiling! See this bug: +\url{https://ghc.haskell.org/trac/ghc/ticket/5316}} This is by +design\footnote{\url{https://ghc.haskell.org/trac/ghc/ticket/2356}}: +ensuring that there are no overlapping instances eagerly requires +eagerly reading all the interface files a module may depend on. + +We might summarize these three properties in the following manner. +Culturally, the Haskell community expects \emph{global uniqueness of instances} +to hold: the implicit global database of instances should be +confluent and coherent. GHC, however, does not enforce uniqueness of +instances: instead, it merely guarantees that the \emph{subset} of the +instance database it uses when it compiles any given module is confluent and coherent. GHC does do some +tests when an instance is declared to see if it would result in overlap +with visible instances, but the check is by no means +perfect\footnote{\url{https://ghc.haskell.org/trac/ghc/ticket/9288}}; +truly, \emph{type-class constraint resolution} has the final word. One +mitigating factor is that in the absence of \emph{orphan instances}, GHC is +guaranteed to eagerly notice when the instance database has overlap.\footnote{Assuming that the instance declaration checks actually worked\ldots} + +Clearly, the fact that GHC's lazy behavior is surprising to most +Haskellers means that the lazy check is mostly good enough: a user +is likely to discover overlapping instances one way or another. +However, it is relatively simple to construct example programs which +violate global uniqueness of instances in an observable way: + +\begin{verbatim} +-- A.hs +module A where +data U = X | Y deriving (Eq, Show) + +-- B.hs +module B where +import Data.Set +import A + +instance Ord U where +compare X X = EQ +compare X Y = LT +compare Y X = GT +compare Y Y = EQ + +ins :: U -> Set U -> Set U +ins = insert + +-- C.hs +module C where +import Data.Set +import A + +instance Ord U where +compare X X = EQ +compare X Y = GT +compare Y X = LT +compare Y Y = EQ + +ins' :: U -> Set U -> Set U +ins' = insert + +-- D.hs +module Main where +import Data.Set +import A +import B +import C + +test :: Set U +test = ins' X $ ins X $ ins Y $ empty + +main :: IO () +main = print test + +-- OUTPUT +$ ghc -Wall -XSafe -fforce-recomp --make D.hs +[1 of 4] Compiling A ( A.hs, A.o ) +[2 of 4] Compiling B ( B.hs, B.o ) + +B.hs:5:10: Warning: Orphan instance: instance [safe] Ord U +[3 of 4] Compiling C ( C.hs, C.o ) + +C.hs:5:10: Warning: Orphan instance: instance [safe] Ord U +[4 of 4] Compiling Main ( D.hs, D.o ) +Linking D ... +$ ./D +fromList [X,Y,X] +\end{verbatim} + +Locally, all type class resolution was coherent: in the subset of +instances each module had visible, type class resolution could be done +unambiguously. Furthermore, the types of \verb|ins| and \verb|ins'| +discharge type class resolution, so that in \verb|D| when the database +is now overlapping, no resolution occurs, so the error is never found. + +It is easy to dismiss this example as an implementation wart in GHC, and +continue pretending that global uniqueness of instances holds. However, +the problem with \emph{global uniqueness of instances} is that they are +inherently nonmodular: you might find yourself unable to compose two +components because they accidentally defined the same type class +instance, even though these instances are plumbed deep in the +implementation details of the components. + +As it turns out, there is already another feature in Haskell which +must enforce global uniqueness, to prevent segfaults. +We now turn to type classes' close cousin: type families. + +\paragraph{Type families} With type families, confluence is the primary +property of interest. (Coherence is not of much interest because type +families are elaborated into coercions, which don't have any +computational content.) Rather than considering what the set of +constraints we reduce to, confluence for type families considers the +reduction of type families. The overlap checks for type families +can be quite sophisticated, especially in the case of closed type +families. + +Unlike type classes, however, GHC \emph{does} check the non-overlap +of type families eagerly. The analogous program does \emph{not} type check: + +\begin{verbatim} +-- F.hs +type family F a :: * +-- A.hs +import F +type instance F Bool = Int +-- B.hs +import F +type instance F Bool = Bool +-- C.hs +import A +import B +\end{verbatim} + +The reason is that it is \emph{unsound} to ever allow any overlap +(unlike in the case of type classes where it just leads to incoherence.) +Thus, whereas one might imagine dropping the global uniqueness of instances +invariant for type classes, it is absolutely necessary to perform global +enforcement here. There's no way around it! + +\subsection{Local type classes} + +Here, we say \textbf{NO} to global uniqueness. + +This design is perhaps best discussed in relation to modular type +classes, which shares many similar properties. Instances are now +treated as first class objects (in MTCs, they are simply modules)---we +may explicitly hide or include instances for type class resolution (in +MTCs, this is done via the \verb|using| top-level declaration). This is +essentially what was sketched in Section 5 of the original Backpack +paper. As a simple example: + +\begin{verbatim} +package p where + A :: [ data T = T ] + B = [ import A; instance Eq T where ... ] + +package q where + A = [ data T = T; instance Eq T where ... ] + include p +\end{verbatim} + +Here, \verb|B| does not see the extra instance declared by \verb|A|, +because it was thinned from its signature of \verb|A| (and thus never +declared canonical.) To declare an instance without making it +canonical, it must placed in a separate (unimported) module. + +Like modular type classes, Backpack does not give rise to incoherence, +because instance visibility can only be changed at the top level module +language, where it is already considered best practice to provide +explicit signatures. Here is the example used in the Modular Type +Classes paper to demonstrate the problem: + +\begin{verbatim} +structure A = using EqInt1 in + struct ...fun f x = eq(x,x)... end +structure B = using EqInt2 in + struct ...val y = A.f(3)... end +\end{verbatim} + +Is the type of f \verb|int -> bool|, or does it have a type-class +constraint? Because type checking proceeds over the entire program, ML +could hypothetically pick either. However, ported to Haskell, the +example looks like this: + +\begin{verbatim} +EqInt1 :: [ instance Eq Int ] +EqInt2 :: [ instance Eq Int ] +A = [ + import EqInt1 + f x = x == x +] +B = [ + import EqInt2 + import A hiding (instance Eq Int) + y = f 3 +] +\end{verbatim} + +There may be ambiguity, yes, but it can be easily resolved by the +addition of a top-level type signature to \verb|f|, which is considered +best-practice anyway. Additionally, Haskell users are trained to expect +a particular inference for \verb|f| in any case (the polymorphic one). + +Here is another example which might be considered surprising: + +\begin{verbatim} +package p where + A :: [ data T = T ] + B :: [ data T = T ] + C = [ + import qualified A + import qualified B + instance Show A.T where show T = "A" + instance Show B.T where show T = "B" + x :: String + x = show A.T ++ show B.T + ] +\end{verbatim} + +In the original Backpack paper, it was implied that module \verb|C| +should not type check if \verb|A.T = B.T| (failing at link time). +However, if we set aside, for a moment, the issue that anyone who +imports \verb|C| in such a context will now have overlapping instances, +there is no reason in principle why the module itself should be +problematic. Here is the example in MTCs, which I have good word from +Derek does type check. + +\begin{verbatim} +signature SIG = sig + type t + val mk : t +end +signature SHOW = sig + type t + val show : t -> string +end +functor Example (A : SIG) (B : SIG) = + let structure ShowA : SHOW = struct + type t = A.t + fun show _ = "A" + end in + let structure ShowB : SHOW = struct + type t = B.t + fun show _ = "B" + end in + using ShowA, ShowB in + struct + val x = show A.mk ++ show B.mk + end : sig val x : string end +\end{verbatim} + +The moral of the story is, even though in a later context the instances +are overlapping, inside the functor, the type-class resolution is unambiguous +and should be done (so \verb|x = "AB"|). + +Up until this point, we've argued why MTCs and this Backpack design are similar. +However, there is an important sociological difference between modular type-classes +and this proposed scheme for Backpack. In the presentation ``Why Applicative +Functors Matter'', Derek mentions the canonical example of defining a set: + +\begin{verbatim} +signature ORD = sig type t; val cmp : t -> t -> bool end +signature SET = sig type t; type elem; + val empty : t; + val insert : elem -> t -> t ... +end +functor MkSet (X : ORD) :> SET where type elem = X.t + = struct ... end +\end{verbatim} + +This is actually very different from how sets tend to be defined in +Haskell today. If we directly encoded this in Backpack, it would +look like this: + +\begin{verbatim} +package mk-set where + X :: [ + data T + cmp :: T -> T-> Bool + ] + Set :: [ + data Set + empty :: Set + insert :: T -> Set -> Set + ] + Set = [ + import X + ... + ] +\end{verbatim} + +It's also informative to consider how MTCs would encode set as it is written +today in Haskell: + +\begin{verbatim} +signature ORD = sig type t; val cmp : t -> t -> bool end +signature SET = sig type 'a t; + val empty : 'a t; + val insert : (X : ORD) => X.t -> X.t t -> X.t t +end +struct MkSet :> SET = struct ... end +\end{verbatim} + +Here, it is clear to see that while functor instantiation occurs for +implementation, it is not occuring for types. This is a big limitation +with the Haskell approach, and it explains why Haskellers, in practice, +find global uniqueness of instances so desirable. + +Implementation-wise, this requires some subtle modifications to how we +do type class resolution. Type checking of indefinite modules works as +before, but when go to actually compile them against explicit +implementations, we need to ``forget'' that two types are equal when +doing instance resolution. This could probably be implemented by +associating type class instances with the original name that was +utilized when typechecking, so that we can resolve ambiguous matches +against types which have the same original name now that we are +compiling. + +As we've mentioned previously, this strategy is unsound for type families. + +\subsection{Globally unique} + +Here, we say \textbf{YES} to global uniqueness. + +When we require the global uniqueness of instances (either because +that's the type class design we chose, or because we're considering +the problem of type families), we will need to reject declarations like the +one cited above when \verb|A.T = B.T|: + +\begin{verbatim} +A :: [ data T ] +B :: [ data T ] +C :: [ + import qualified A + import qualified B + instance Show A.T where show T = "A" + instance Show B.T where show T = "B" +] +\end{verbatim} + +The paper mentions that a link-time check is sufficient to prevent this +case from arising. While in the previous section, we've argued why this +is actually unnecessary when local instances are allowed, the link-time +check is a good match in the case of global instances, because any +instance \emph{must} be declared in the signature. The scheme proceeds +as follows: when some instances are typechecked initially, we type check +them as if all of variable module identities were distinct. Then, when +we perform linking (we \verb|include| or we unify some module +identities), we check again if to see if we've discovered some instance +overlap. This linking check is akin to the eager check that is +performed today for type families; it would need to be implemented for +type classes as well: however, there is a twist: we are \emph{redoing} +the overlap check now that some identities have been unified. + +As an implementation trick, one could deferring the check until \verb|C| +is compiled, keeping in line with GHC's lazy ``don't check for overlap +until the use site.'' (Once again, unsound for type families.) + +\paragraph{What about module inequalities?} An older proposal was for +signatures to contain ``module inequalities'', i.e., assertions that two +modules are not equal. (Technically: we need to be able to apply this +assertion to $\beta$ module variables, since \verb|A != B| while +\verb|A.T = B.T|). Currently, Edward thinks that module inequalities +are only marginal utility with local instances (i.e., not enough to +justify the implementation cost) and not useful at all in the world of +global instances! + +With local instances, module inequalities could be useful to statically +rule out examples like \verb|show A.T ++ show B.T|. Because such uses +are not necessarily reflected in the signature, it would be a violation +of separate module development to try to divine the constraint from the +implementation itself. I claim this is of limited utility, however, because, +as we mentioned earlier, we can compile these ``incoherent'' modules perfectly +coherently. With global instances, all instances must be in the signature, so +while it might be aesthetically displeasing to have the signature impose +extra restrictions on linking identities, we can carry this out without +violating the linking restriction. + +\section{Bits and bobs} + +\subsection{Abstract type synonyms} + +In Paper Backpack, abstract type synonyms are not permitted, because GHC doesn't +understand how to deal with them. The purpose of this section is to describe +one particularly nastiness of abstract type synonyms, by way of the occurs check: + +\begin{verbatim} +A :: [ type T ] +B :: [ import qualified A; type T = [A.T] ] +\end{verbatim} + +At this point, it is illegal for \verb|A = B|, otherwise this type synonym would +fail the occurs check. This seems like pretty bad news, since every instance +of the occurs check in the type-checker could constitute a module inequality. \section{Open questions}\label{sec:open-questions} @@ -797,11 +2462,6 @@ hashing out. accommodate this. This is probably the most important problem to overcome. - \item In Section~\ref{sec:compiling-definite}, we describe two strategies - for compiling packages with no holes (but which depend on indefinite - packages). Simon and Edward still don't agree which proposal is best (Simon - in the downstream camp, Edward is in the upstream camp.) - \item In Section~\ref{sec:installing-indefinite}, a few choices for how to store source code were pitched, however, there is not consensus on which one is best. @@ -820,7 +2480,4 @@ hashing out. \end{itemize} -\bibliographystyle{plain} -\bibliography{backpack-impl} - \end{document} diff --git a/docs/backpack/commands-new-new.tex b/docs/backpack/commands-new-new.tex new file mode 100644 index 0000000000..1f2466e14c --- /dev/null +++ b/docs/backpack/commands-new-new.tex @@ -0,0 +1,891 @@ +%!TEX root = paper/paper.tex +\usepackage{amsmath} +\usepackage{amssymb} +\usepackage{amsthm} +\usepackage{xspace} +\usepackage{color} +\usepackage{xifthen} +\usepackage{graphicx} +\usepackage{amsbsy} +\usepackage{mathtools} +\usepackage{stmaryrd} +\usepackage{url} +\usepackage{alltt} +\usepackage{varwidth} +% \usepackage{hyperref} +\usepackage{datetime} +\usepackage{subfig} +\usepackage{array} +\usepackage{multirow} +\usepackage{xargs} +\usepackage{marvosym} % for MVAt +\usepackage{bm} % for blackboard bold semicolon + + +%% HYPERREF COLORS +\definecolor{darkred}{rgb}{.7,0,0} +\definecolor{darkgreen}{rgb}{0,.5,0} +\definecolor{darkblue}{rgb}{0,0,.5} +% \hypersetup{ +% linktoc=page, +% colorlinks=true, +% linkcolor=darkred, +% citecolor=darkgreen, +% urlcolor=darkblue, +% } + +% Coloring +\definecolor{hilite}{rgb}{0.7,0,0} +\newcommand{\hilite}[1]{\color{hilite}#1\color{black}} +\definecolor{shade}{rgb}{0.85,0.85,0.85} +\newcommand{\shade}[1]{\colorbox{shade}{\!\ensuremath{#1}\!}} + +% Misc +\newcommand\evalto{\hookrightarrow} +\newcommand\elabto{\rightsquigarrow} +\newcommand\elabtox[1]{\stackrel{#1}\rightsquigarrow} +\newcommand{\yields}{\uparrow} +\newcommand\too{\Rightarrow} +\newcommand{\nil}{\cdot} +\newcommand{\eps}{\epsilon} +\newcommand{\Ups}{\Upsilon} +\newcommand{\avoids}{\mathrel{\#}} + +\renewcommand{\vec}[1]{\overline{#1}} +\newcommand{\rname}[1]{\textsc{#1}} +\newcommand{\infrule}[3][]{% + \vspace{0.5ex} + \frac{\begin{array}{@{}c@{}}#2\end{array}}% + {\mbox{\ensuremath{#3}}}% + \ifthenelse{\isempty{#1}}% + {}% + % {\hspace{1ex}\rlap{(\rname{#1})}}% + {\hspace{1ex}(\rname{#1})}% + \vspace{0.5ex} +} +\newcommand{\infax}[2][]{\infrule[#1]{}{#2}} +\newcommand{\andalso}{\hspace{.5cm}} +\newcommand{\suchthat}{~\mathrm{s.t.}~} +\newenvironment{notes}% + {\vspace{-1.5em}\begin{itemize}\setlength\itemsep{0pt}\small}% + {\end{itemize}} +\newcommand{\macrodef}{\mathbin{\overset{\mathrm{def}}{=}}} +\newcommand{\macroiff}{\mathbin{\overset{\mathrm{def}}{\Leftrightarrow}}} + + +\newcommand{\ttt}[1]{\text{\tt #1}} +\newcommand{\ttul}{\texttt{\char 95}} +\newcommand{\ttcc}{\texttt{:\!:}} +\newcommand{\ttlb}{{\tt {\char '173}}} +\newcommand{\ttrb}{{\tt {\char '175}}} +\newcommand{\tsf}[1]{\textsf{#1}} + +% \newcommand{\secref}[1]{\S\ref{sec:#1}} +% \newcommand{\figref}[1]{Figure~\ref{fig:#1}} +\newcommand{\marginnote}[1]{\marginpar[$\ast$ {\small #1} $\ast$]% + {$\ast$ {\small #1} $\ast$}} +\newcommand{\hschange}{\marginnote{!Haskell}} +\newcommand{\TODO}{\emph{TODO}\marginnote{TODO}} +\newcommand{\parheader}[1]{\textbf{#1}\quad} + +\newcommand{\file}{\ensuremath{\mathit{file}}} +\newcommand{\mapnil}{~\mathord{\not\mapsto}} + +\newcommand{\Ckey}[1]{\textbf{\textsf{#1}}} +\newcommand{\Cent}[1]{\texttt{#1}} +% \newcommand{\Cmod}[1]{\texttt{[#1]}} +% \newcommand{\Csig}[1]{\texttt{[\ttcc{}#1]}} +\newcommand{\Cmod}[1]{=\texttt{[#1]}} +\newcommand{\Csig}[1]{~\ttcc{}~\texttt{[#1]}} +\newcommand{\Cpath}[1]{\ensuremath{\mathsf{#1}}} +\newcommand{\Cvar}[1]{\ensuremath{\mathsf{#1}}} +\newcommand{\Ccb}[1]{\text{\ttlb} {#1} \text{\ttrb}} +\newcommand{\Cpkg}[1]{\texttt{#1}} +\newcommand{\Cmv}[1]{\ensuremath{\langle #1 \rangle}} +\newcommand{\Cto}[2]{#1 \mapsto #2} +\newcommand{\Ctoo}[2]{\Cpath{#1} \mapsto \Cpath{#2}} +\newcommand{\Crm}[1]{#1 \mapnil} +\newcommand{\Crmm}[1]{\Cpath{#1} \mapnil} +\newcommand{\Cthin}[1]{\ensuremath{\langle \Ckey{only}~#1 \rangle}} +\newcommand{\Cthinn}[1]{\ensuremath{\langle \Ckey{only}~\Cpath{#1} \rangle}} +\newcommand{\Cinc}[1]{\Ckey{include}~{#1}} +\newcommand{\Cincc}[1]{\Ckey{include}~\Cpkg{#1}} +\newcommand{\Cshar}[2]{~\Ckey{where}~{#1} \equiv {#2}} +\newcommand{\Csharr}[2]{~\Ckey{where}~\Cpath{#1} \equiv \Cpath{#2}} +\newcommand{\Ctshar}[2]{~\Ckey{where}~{#1} \equiv {#2}} +\newcommand{\Ctsharr}[3]{~\Ckey{where}~\Cpath{#1}.\Cent{#3} \equiv \Cpath{#2}.\Cent{#3}} +\newcommand{\Cbinds}[1]{\left\{\!\begin{array}{l} #1 \end{array}\!\right\}} +\newcommand{\Cbindsp}[1]{\left(\!\begin{array}{l} #1 \end{array}\!\right)} +\newcommand{\Cpkgs}[1]{\[\begin{array}{l} #1\end{array}\]} +\newcommand{\Cpkgsl}[1]{\noindent\ensuremath{\begin{array}{@{}l} #1\end{array}}} +\newcommand{\Ccomment}[1]{\ttt{\emph{--~#1}}} +\newcommand{\Cimp}[1]{\Ckey{import}~\Cpkg{#1}} +\newcommand{\Cimpas}[2]{\Ckey{import}~\Cpkg{#1}~\Ckey{as}~\Cvar{#2}} + +\newcommand{\Ctbinds}[1]{\left\{\!\vrule width 0.6pt \begin{array}{l} #1 \end{array} \vrule width 0.6pt \!\right\}} +\newcommand{\Ctbindsx}{\left\{\!\vrule width 0.6pt \; \vrule width 0.6pt \!\right\}} +\newcommand{\Ctbindsxx}{\left\{\!\vrule width 0.6pt \begin{array}{l}\!\!\!\!\\\!\!\!\!\end{array} \vrule width 0.6pt \!\right\}} +\newcommand{\Ctbindsxxx}{\left\{\!\vrule width 0.6pt \begin{array}{l}\!\!\!\!\\\!\!\!\!\\\!\!\!\!\end{array} \vrule width 0.6pt \!\right\}} + + +\newcommand{\Cpkgdef}[2]{% + \ensuremath{ + \begin{array}{l} + \Ckey{package}~\Cpkg{#1}~\Ckey{where}\\ + \hspace{1em}\begin{array}{l} + #2 + \end{array} + \end{array}}} +\newcommand{\Cpkgdefonly}[3]{% + \ensuremath{ + \begin{array}{l} + \Ckey{package}~\Cpkg{#1}\Cvar{(#2)}~\Ckey{where}\\ + \hspace{1em}\begin{array}{l} + #3 + \end{array} + \end{array}}} +\newcommand{\Ccc}{\mathbin{\ttcc{}}} +\newcommand{\Cbinmod}[2]{\Cvar{#1} = \texttt{[#2]}} +\newcommand{\Cbinsig}[2]{\Cvar{#1} \Ccc \texttt{[#2]}} +\newcommand{\Cinconly}[2]{\Ckey{include}~\Cpkg{#1}\Cvar{(#2)}} +\newcommand{\Cimponly}[2]{\Ckey{import}~\Cpkg{#1}\Cvar{(#2)}} +\newcommand{\Cimpmv}[3]{\Ckey{import}~\Cpkg{#1}\langle\Cvar{#2}\mapsto\Cvar{#3}\rangle} + + + + + +\newcommand{\oxb}[1]{\llbracket #1 \rrbracket} +\newcommand{\coxb}[1]{\{\hspace{-.5ex}| #1 |\hspace{-.5ex}\}} +\newcommand{\coxbv}[1]{\coxb{\vec{#1}}} +\newcommand{\angb}[1]{\ensuremath{\boldsymbol\langle #1 \boldsymbol\rangle}\xspace} +\newcommand{\angbv}[1]{\angb{\vec{#1}}} +\newcommand{\aoxbl}{\ensuremath{\boldsymbol\langle\hspace{-.5ex}|}} +\newcommand{\aoxbr}{\ensuremath{|\hspace{-.5ex}\boldsymbol\rangle}\xspace} +\newcommand{\aoxb}[1]{\ensuremath{\aoxbl{#1}\aoxbr}} +\newcommand{\aoxbv}[1]{\aoxb{\vec{#1}}} +\newcommand{\poxb}[1]{\ensuremath{% + (\hspace{-.5ex}|% + #1% + |\hspace{-.5ex})}\xspace} +\newcommand{\stof}[1]{{#1}^{\star}} +% \newcommand{\stof}[1]{\ensuremath{\underline{#1}}} +\newcommand{\sh}[1]{\ensuremath{\tilde{#1}}} + + +% \newenvironment{code}[1][t]% +% {\ignorespaces\begin{varwidth}[#1]{\textwidth}\begin{alltt}}% +% {\end{alltt}\end{varwidth}\ignorespacesafterend} +% \newenvironment{codel}[1][t]% +% {\noindent\begin{varwidth}[#1]{\textwidth}\noindent\begin{alltt}}% +% {\end{alltt}\end{varwidth}\ignorespacesafterend} + + +%% hack for subfloats in subfig ------------- +\makeatletter +\newbox\sf@box +\newenvironment{SubFloat}[2][]% + {\def\sf@one{#1}% + \def\sf@two{#2}% + \setbox\sf@box\hbox + \bgroup}% + {\egroup + \ifx\@empty\sf@two\@empty\relax + \def\sf@two{\@empty} + \fi + \ifx\@empty\sf@one\@empty\relax + \subfloat[\sf@two]{\box\sf@box}% + \else + \subfloat[\sf@one][\sf@two]{\box\sf@box}% + \fi} +\makeatother +%% ------------------------------------------ + +%% hack for top-aligned tabular cells ------------- +\newsavebox\topalignbox +\newcolumntype{L}{% + >{\begin{lrbox}\topalignbox + \rule{0pt}{\ht\strutbox}} + l + <{\end{lrbox}% + \raisebox{\dimexpr-\height+\ht\strutbox\relax}% + {\usebox\topalignbox}}} +\newcolumntype{C}{% + >{\begin{lrbox}\topalignbox + \rule{0pt}{\ht\strutbox}} + c + <{\end{lrbox}% + \raisebox{\dimexpr-\height+\ht\strutbox\relax}% + {\usebox\topalignbox}}} +\newcolumntype{R}{% + >{\begin{lrbox}\topalignbox + \rule{0pt}{\ht\strutbox}} + r + <{\end{lrbox}% + \raisebox{\dimexpr-\height+\ht\strutbox\relax}% + {\usebox\topalignbox}}} +%% ------------------------------------------------ + +\newcommand\syn[1]{\textsf{#1}} +\newcommand\bsyn[1]{\textsf{\bfseries #1}} +\newcommand\msyn[1]{\textsf{#1}} +\newcommand{\cc}{\mathop{::}} + +% \newcommand{\Eimp}[1]{\bsyn{import}~{#1}} +% \newcommand{\Eonly}[2]{#1~\bsyn{only}~{#2}} +% \newcommand{\Ehide}[1]{~\bsyn{hide}~{#1}} +% \newcommand{\Enew}[1]{\bsyn{new}~{#1}} +% \newcommand{\Elocal}[2]{\bsyn{local}~{#1}~\bsyn{in}~{#2}} +% \newcommand{\Smv}[3]{\Emv[]{#1}{#2}{#3}} +\newcommand{\Srm}[2]{#1 \mathord{\setminus} #2} + +\newcommand{\cpath}{\varrho} +\newcommand{\fpath}{\rho} + +\newcommand{\ie}{\emph{i.e.},\xspace} +\newcommand{\eg}{\emph{e.g.},~} +\newcommand{\etal}{\emph{et al.}} + +\renewcommand{\P}[1]{\Cpkg{#1}} +\newcommand{\X}[1]{\Cvar{#1}} +\newcommand{\E}{\mathcal{E}} +\newcommand{\C}{\mathcal{C}} +\newcommand{\M}{\mathcal{M}} +\newcommand{\B}{\mathcal{B}} +\newcommand{\R}{\mathcal{R}} +\newcommand{\K}{\mathcal{K}} +\renewcommand{\L}{\mathcal{L}} +\newcommand{\D}{\mathcal{D}} + +%%%% NEW + +\newdateformat{numericdate}{% +\THEYEAR.\twodigit{\THEMONTH}.\twodigit{\THEDAY} +} + +% EL DEFNS +\newcommand{\shal}[1]{\syn{shallow}(#1)} +\newcommand{\exports}[1]{\syn{exports}(#1)} +\newcommand{\Slocals}[1]{\syn{locals}(#1)} +\newcommand{\Slocalsi}[2]{\syn{locals}(#1; #2)} +\newcommand{\specs}[1]{\syn{specs}(#1)} +\newcommand{\ELmkespc}[2]{\syn{mkespc}(#1;#2)} +\newcommand{\Smkeenv}[1]{\syn{mkeenv}(#1)} +\newcommand{\Smklocaleenv}[2]{\syn{mklocaleenv}(#1;#2)} +\newcommand{\Smklocaleenvespcs}[1]{\syn{mklocaleenv}(#1)} +\newcommand{\Smkphnms}[1]{\syn{mkphnms}(#1)} +\newcommand{\Smkphnm}[1]{\syn{mkphnm}(#1)} +\newcommand{\Sfilterespc}[2]{\syn{filterespc}(#1;#2)} +\newcommand{\Sfilterespcs}[2]{\syn{filterespcs}(#1;#2)} +\newcommand{\Simps}[1]{\syn{imps}(#1)} + + + +% IL DEFNS +\newcommand{\dexp}{\mathit{dexp}} +\newcommand{\fexp}{\mathit{fexp}} +\newcommand{\tfexp}{\mathit{tfexp}} +\newcommand{\pexp}{\mathit{pexp}} +\newcommand{\dtyp}{\mathit{dtyp}} +\newcommand{\ftyp}{\mathit{ftyp}} +\newcommand{\hsmod}{\mathit{hsmod}} +\newcommand{\fenv}{\mathit{fenv}} +\newcommand{\ILmkmod}[6]{\syn{mkmod}(#1; #2; #3; #4; #5; #6)} +\newcommand{\ILmkstubs}[3]{\syn{mkstubs}(#1; #2; #3)} +\newcommand{\Smkstubs}[1]{\syn{mkstubs}(#1)} +\newcommand{\ILentnames}[1]{\syn{entnames}(#1)} +\newcommand{\ILmkfenv}[1]{\syn{mkfenv}(#1)} +\newcommand{\ILmkdtyp}[1]{\syn{mkdtyp}(#1)} +\newcommand{\ILmkknd}[1]{\syn{mkknd}(#1)} +\newcommand{\ILmkimpdecl}[2]{\syn{mkimpdecl}(#1;#2)} +\newcommand{\ILmkimpdecls}[2]{\syn{mkimpdecls}(#1;#2)} +\newcommand{\ILmkimpspec}[3]{\syn{mkimpspec}(#1;#2;#3)} +\newcommand{\ILmkentimp}[3]{\syn{mkentimp}(#1;#2;#3)} +\newcommand{\ILmkentimpp}[1]{\syn{mkentimp}(#1)} +\newcommand{\ILmkexp}[2]{\syn{mkexp}(#1;#2)} +\newcommand{\ILmkexpdecl}[2]{\syn{mkexpdecl}(#1;#2)} +\newcommand{\ILmkespc}[2]{\syn{mkespc}(#1;#2)} +\newcommand{\ILshal}[1]{\syn{shallow}(#1)} +\newcommand{\ILexports}[1]{\syn{exports}(#1)} +\newcommand{\ILdefns}[1]{\syn{defns}(#1)} +\newcommand{\ILdefnsi}[2]{\syn{defns}(#1;#2)} + +% CORE DEFNS +\newcommand{\Hentref}{\mathit{eref}} +\newcommand{\Hentimp}{\mathit{import}} +\newcommand{\Hentexp}{\mathit{export}} +\newcommand{\Himp}{\mathit{impdecl}} +\newcommand{\Himpspec}{\mathit{impspec}} +\newcommand{\Himps}{\mathit{impdecls}} +\newcommand{\Hexps}{\mathit{expdecl}} +\newcommand{\Hdef}{\mathit{def}} +\newcommand{\Hdefs}{\mathit{defs}} +\newcommand{\Hdecl}{\mathit{decl}} +\newcommand{\Hdecls}{\mathit{decls}} +\newcommand{\Heenv}{\mathit{eenv}} +\newcommand{\Haenv}{\mathit{aenv}} +% \newcommand{\HIL}[1]{{\scriptstyle\downarrow}#1} +\newcommand{\HIL}[1]{\check{#1}} + +\newcommand{\Hcmp}{\sqsubseteq} + +\newcommand{\uexp}{\mathit{uexp}} +\newcommand{\utyp}{\mathit{utyp}} +\newcommand{\typ}{\mathit{typ}} +\newcommand{\knd}{\mathit{knd}} +\newcommand{\kndstar}{\ttt{*}} +\newcommand{\kndarr}[2]{#1\ensuremath{\mathbin{\ttt{->}}}#2} +\newcommand{\kenv}{\mathit{kenv}} +\newcommand{\phnm}{\mathit{phnm}} +\newcommand{\spc}{\mathit{dspc}} +\newcommand{\spcs}{\mathit{dspcs}} +\newcommand{\espc}{\mathit{espc}} +\newcommand{\espcs}{\mathit{espcs}} +\newcommand{\ds}{\mathit{ds}} + +\newcommand{\shctx}{\sh{\Xi}_{\syn{ctx}}} +\newcommand{\shctxsigma}{\sh{\Sigma}_{\syn{ctx}}} + +\newcommand{\vdashsh}{\Vdash} + +% \newcommand{\vdashghc}{\vdash_{\!\!\mathrm{c}}^{\!\!\mathrm{\scriptscriptstyle EL}}} +% \newcommand{\vdashghcil}{\vdash_{\!\!\mathrm{c}}^{\!\!\mathrm{\scriptscriptstyle IL}}} +% \newcommand{\vdashshghc}{\vdashsh_{\!\!\mathrm{c}}^{\!\!\mathrm{\scriptscriptstyle EL}}} +\newcommand{\vdashghc}{\vdash_{\!\!\mathrm{c}}} +\newcommand{\vdashghcil}{\vdash_{\!\!\mathrm{c}}^{\!\!\mathrm{\scriptscriptstyle IL}}} +\newcommand{\vdashshghc}{\vdashsh_{\!\!\mathrm{c}}} + +% CORE STUFF +\newcommandx*{\JCModImp}[5][1=\sh\B, 2=\nu_0, usedefault=@]% + {#1;#2 \vdashshghc #3;#4 \elabto #5} +\newcommandx*{\JIlCModImp}[5][1=\fenv, 2=f_0, usedefault=@]% + {#1;#2 \vdashghcil #3;#4 \elabto #5} +\newcommandx*{\JCSigImp}[5][1=\sh\B, 2=\sh\tau, usedefault=@]% + {#1;#2 \vdashshghc #3;#4 \elabto #5} + +\newcommandx*{\JCImpDecl}[3][1=\sh\B, usedefault=@]% + {#1 \vdashshghc #2 \elabto #3} +\newcommandx*{\JCImp}[4][1=\sh\B, 2=p, usedefault=@]% + {#1;#2 \vdashshghc #3 \elabto #4} +\newcommandx*{\JIlCImpDecl}[3][1=\fenv, usedefault=@]% + {#1 \vdashghcil #2 \elabto #3} +\newcommandx*{\JIlCImp}[4][1=\fenv, 2=f, usedefault=@]% + {#1;#2 \vdashghcil #3 \elabto #4} + +\newcommandx*{\JCModExp}[4][1=\nu_0, 2=\Heenv, usedefault=@]% + {#1;#2 \vdashshghc #3 \elabto #4} +\newcommandx*{\JIlCModExp}[4][1=f_0, 2=\HIL\Heenv, usedefault=@]% + {#1;#2 \vdashghcil #3 \elabto #4} + +\newcommandx*{\JCModDef}[5][1=\Psi, 2=\nu_0, 3=\Heenv, usedefault=@]% + {#1; #2; #3 \vdashghcil #4 : #5} +\newcommandx*{\JIlCModDef}[5][1=\fenv, 2=f_0, 3=\HIL\Heenv, usedefault=@]% + {#1; #2; #3 \vdashghcil #4 : #5} +\newcommandx*{\JCSigDecl}[5][1=\Psi, 2=\sh\tau, 3=\Heenv, usedefault=@]% + {#1; #2; #3 \vdashghcil #4 : #5} + +\newcommandx*{\JCExp}[6][1=\sh\Psi, 2=\nu_0, 3=\Hdefs, 4=\Heenv, usedefault=@]% + {#1;#2;#3;#4 \vdashshghc #5 \elabto #6} +\newcommandx*{\JIlCExp}[4][1=f_0, 2=\HIL\Heenv, usedefault=@]% + {#1;#2 \vdashghcil #3 \elabto #4} + +\newcommandx*{\JCRefExp}[7][1=\sh\Psi, 2=\nu_0, 3=\Hdefs, 4=\Heenv, usedefault=@]% + {#1;#2;#3;#4 \vdashshghc #5 \elabto #6:#7} +\newcommandx*{\JIlCRefExp}[7][1=\fenv, 2=f_0, 3=\HIL\Hdefs, 4=\HIL\Heenv, usedefault=@]% + {#1;#2;#3;#4 \vdashghcil #5 \elabto #6:#7} + +\newcommandx*{\JCMod}[4][1=\Gamma, 2=\nu_0, usedefault=@]% + {#1; #2 \vdashghc #3 : #4} +\newcommandx*{\JIlCMod}[3][1=\fenv, usedefault=@]% + {#1 \vdashghcil #2 : #3} +\newcommandx*{\JCSig}[5][1=\Gamma, 2=\sh\tau, usedefault=@]% + {#1; #2 \vdashghc #3 \elabto #4;#5} +\newcommandx*{\JCShSig}[5][1=\Gamma, 2=\sh\tau, usedefault=@]% + {#1; #2 \vdashghc #3 \elabto #4;#5} +\newcommandx*{\JCModElab}[5][1=\Gamma, 2=\nu_0, usedefault=@]% + % {#1; #2 \vdashghc #3 : #4 \elabto #5} + {#1; #2 \vdashghc #3 : #4 \;\shade{\elabto #5}} + +\newcommandx*{\JCWfEenv}[2][1=\Haenv, usedefault=@]% + {#1 \vdashshghc #2~\syn{wf}} +\newcommandx*{\JCWfEenvMap}[2][1=\Haenv, usedefault=@]% + {#1 \vdashshghc #2~\syn{wf}} +\newcommandx*{\JIlCWfEenv}[2][1=\HIL\Haenv, usedefault=@]% + {#1 \vdashghcil #2~\syn{wf}} +\newcommandx*{\JIlCWfEenvMap}[2][1=\HIL\Haenv, usedefault=@]% + {#1 \vdashghcil #2~\syn{wf}} + +\newcommandx*{\JIlTfexp}[3][1=\fenv, 2=f_0, usedefault=@]% + {#1; #2 \vdash #3} + + + + % IL STUFF + +\newcommandx*{\JIlWf}[2][1=\fenv, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JIlKnd}[4][1=\fenv, 2=\kenv, usedefault=@]% + {#1;#2 \vdashghcil #3 \mathrel{\cc} #4} +% \newcommandx*{\JIlSub}[4][1=\fenv, 2=f, usedefault=@]% +% {#1;#2 \vdash #3 \le #4} +\newcommandx*{\JIlSub}[2][usedefault=@]% + {\vdash #1 \le #2} +\newcommandx*{\JIlMerge}[3][usedefault=@]% + {\vdash #1 \oplus #2 \Rightarrow #3} + +\newcommandx*{\JIlDexp}[2][1=\fenv, usedefault=@]% + {#1 \vdash #2} +\newcommandx*{\JIlDexpTyp}[3][1=\fenv, usedefault=@]% + {#1 \vdash #2 : #3} + +\newcommandx*{\JIlWfFenv}[2][1=\nil, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JIlWfFtyp}[2][1=\fenv, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JIlWfSpc}[2][1=\fenv, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JIlWfESpc}[2][1=\fenv, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JIlWfSig}[2][1=\fenv, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JIlWfFtypSpecs}[2][1=\fenv, usedefault=@]% + {#1 \vdash #2 ~\syn{specs-wf}} +\newcommandx*{\JIlWfFtypExps}[2][1=\fenv, usedefault=@]% + {#1 \vdash #2 ~\syn{exports-wf}} +\newcommandx*{\JIlWfFenvDeps}[2][1=\fenv, usedefault=@]% + {#1 \vdash #2 ~\syn{deps-wf}} + +% WF TYPE STUFF IN EL +\newcommandx*{\JPkgValid}[1]% + {\vdash #1 ~\syn{pkg-valid}} +\newcommandx*{\JWfPkgCtx}[1][1=\Delta, usedefault=@]% + {\vdash #1 ~\syn{wf}} +\newcommandx*{\JWfPhCtx}[2][1=\nil, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JWfModTyp}[2][1=\Psi, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JWfModTypPol}[3][1=\Psi, usedefault=@]% + {#1 \vdash #2^{#3} ~\syn{wf}} +\newcommandx*{\JWfLogSig}[2][1=\Psi, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JWfSpc}[2][1=\Psi, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JWfESpc}[2][1=\Psi, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JWfSig}[2][1=\nil, usedefault=@]% + {#1 \vdash #2 ~\syn{wf}} +\newcommandx*{\JWfModTypSpecs}[2][1=\Psi, usedefault=@]% + {#1 \vdash #2 ~\syn{specs-wf}} +\newcommandx*{\JWfModTypPolSpecs}[3][1=\Psi, usedefault=@]% + {#1 \vdash #2^{#3} ~\syn{specs-wf}} +\newcommandx*{\JWfModTypExps}[2][1=\Psi, usedefault=@]% + {#1 \vdash #2 ~\syn{exports-wf}} +\newcommandx*{\JWfPhCtxDeps}[2][1=\Psi, usedefault=@]% + {#1 \vdash #2 ~\syn{deps-wf}} +\newcommandx*{\JWfPhCtxDepsOne}[4][1=\Psi, usedefault=@]% + {#1 \vdash \styp{#2}{#3}{#4} ~\syn{deps-wf}} + +% WF SHAPE STUFF IN EL +\newcommandx*{\JWfShPhCtx}[2][1=\nil, usedefault=@]% + {#1 \vdashsh #2 ~\syn{wf}} +\newcommandx*{\JWfModSh}[2][1=\sh\Psi, usedefault=@]% + {#1 \vdashsh #2 ~\syn{wf}} +\newcommandx*{\JWfModShPol}[3][1=\sh\Psi, usedefault=@]% + {#1 \vdashsh #2^{#3} ~\syn{wf}} +\newcommandx*{\JWfShLogSig}[2][1=\sh\Psi, usedefault=@]% + {#1 \vdashsh #2 ~\syn{wf}} +\newcommandx*{\JWfShSpc}[2][1=\sh\Psi, usedefault=@]% + {#1 \vdashsh #2 ~\syn{wf}} +\newcommandx*{\JWfShESpc}[2][1=\sh\Psi, usedefault=@]% + {#1 \vdashsh #2 ~\syn{wf}} +\newcommandx*{\JWfShSig}[2][1=\nil, usedefault=@]% + {#1 \vdashsh #2 ~\syn{wf}} +\newcommandx*{\JWfModShSpecs}[2][1=\sh\Psi, usedefault=@]% + {#1 \vdashsh #2 ~\syn{specs-wf}} +\newcommandx*{\JWfModShPolSpecs}[3][1=\sh\Psi, usedefault=@]% + {#1 \vdashsh #2^{#3} ~\syn{specs-wf}} +\newcommandx*{\JWfModShExps}[2][1=\sh\Psi, usedefault=@]% + {#1 \vdashsh #2 ~\syn{exports-wf}} +\newcommandx*{\JWfEenv}[4][1=\sh\Psi, 2=\nu_0, 3=\Hdefs, usedefault=@]% + {#1;#2;#3 \vdashshghc #4 ~\syn{wf}} + +\newcommandx*{\JCoreKnd}[4][1=\Psi, 2=\kenv, usedefault=@]% + {#1;#2 \vdashghc #3 \mathrel{\cc} #4} + +\newcommandx*{\JStampEq}[2]% + {\vdash #1 \equiv #2} +\newcommandx*{\JStampNeq}[2]% + {\vdash #1 \not\equiv #2} +\newcommandx*{\JUnif}[3]% + {\syn{unify}(#1 \doteq #2) \elabto #3} +\newcommandx*{\JUnifM}[2]% + {\syn{unify}(#1) \elabto #2} + +\newcommandx*{\JModTypWf}[1]% + {\vdash #1 ~\syn{wf}} + +\newcommandx*{\JModSub}[2]% + {\vdash #1 \le #2} +\newcommandx*{\JModSup}[2]% + {\vdash #1 \ge #2} +\newcommandx*{\JShModSub}[2]% + {\vdashsh #1 \le #2} + +\newcommandx*{\JModEq}[2]% + {\vdash #1 \equiv #2} +% \newcommandx*{\JCShModEq}[3][3=\C]% +% {\vdashsh #1 \equiv #2 \mathbin{|} #3} + +\newcommandx*{\JETyp}[4][1=\Gamma, 2=\shctxsigma, usedefault=@]% + {#1;#2 \vdash #3 : #4} +\newcommandx*{\JETypElab}[5][1=\Gamma, 2=\shctxsigma, usedefault=@]% + {\JETyp[#1][#2]{#3}{#4} \elabto #5} +\newcommandx*{\JESh}[3][1=\sh\Gamma, usedefault=@]% + {#1 \vdashsh #2 \Rightarrow #3} + +\newcommandx*{\JBTyp}[5][1=\Delta, 2=\Gamma, 3=\shctx, usedefault=@]% + {#1;#2;#3 \vdash #4 : #5} +\newcommandx*{\JBTypElab}[6][1=\Delta, 2=\Gamma, 3=\shctx, usedefault=@]% + % {\JBTyp[#1][#2][#3]{#4}{#5} \elabto #6} + {\JBTyp[#1][#2][#3]{#4}{#5} \;\shade{\elabto #6}} +\newcommandx*{\JBSh}[4][1=\Delta, 2=\sh\Gamma, usedefault=@]% + {#1;#2 \vdashsh #3 \Rightarrow #4} + +\newcommandx*{\JBVTyp}[4][1=\Delta, 2=\shctx, usedefault=@]% + {#1;#2 \vdash #3 : #4} +\newcommandx*{\JBVTypElab}[5][1=\Delta, 2=\shctx, usedefault=@]% + % {\JBVTyp[#1][#2]{#3}{#4} \elabto #5} + {\JBVTyp[#1][#2]{#3}{#4} \;\shade{\elabto #5}} +\newcommandx*{\JBVSh}[4][1=\Delta, usedefault=@]% + {#1 \vdashsh #2 \Rightarrow #3;\, #4} + +\newcommandx*{\JImp}[3][1=\Gamma, usedefault=@]% + {#1 \vdashimp #2 \elabto #3} +\newcommandx*{\JShImp}[3][1=\sh\Gamma, usedefault=@]% + {#1 \vdashshimp #2 \elabto #3} + +\newcommandx*{\JGhcMod}[4]% + {#1; #2 \vdashghc #3 : #4} +\newcommandx*{\JShGhcMod}[4]% + {#1; #2 \vdashshghc #3 : #4} + +\newcommandx*{\JGhcSig}[5]% + {#1; #2 \vdashghc #3 \elabto #4;#5} +\newcommandx*{\JShGhcSig}[5]% + {#1; #2 \vdashshghc #3 \elabto #4;#5} + +\newcommandx*{\JThin}[3][1=t, usedefault=@]% + {\vdash #2 \xrightarrow{~#1~} #3} +\newcommandx*{\JShThin}[3][1=t, usedefault=@]% + {\vdashsh #2 \xrightarrow{~#1~} #3} + +\newcommandx*{\JShMatch}[3][1=\nu, usedefault=@]% + {#1 \vdash #2 \sqsubseteq #3} + +\newcommandx*{\JShTrans}[4]% + {\vdash #1 \le_{#2} #3 \elabto #4} + +\newcommandx*{\JMerge}[3]% + {\vdash #1 + #2 \Rightarrow #3} +\newcommandx*{\JShMerge}[5]% + {\vdashsh #1 + #2 \Rightarrow #3;\, #4;\, #5} +\newcommandx*{\JShMergeNew}[4]% + {\vdashsh #1 + #2 \Rightarrow #3;\, #4} +\newcommandx*{\JShMergeSimple}[3]% + {\vdashsh #1 + #2 \Rightarrow #3} + +\newcommandx*{\JDTyp}[3][1=\Delta, usedefault=@]% + {#1 \vdash #2 : #3} +\newcommandx*{\JDTypElab}[4][1=\Delta, usedefault=@]% + % {#1 \vdash #2 : #3 \elabto #4} + {#1 \vdash #2 : #3 \;\shade{\elabto #4}} + +\newcommandx*{\JTTyp}[2][1=\Delta, usedefault=@]% + {#1 \vdash #2} + +\newcommandx*{\JSound}[3][1=\Psi_\syn{ctx}, usedefault=@]% + {#1 \vdash #2 \sim #3} + +\newcommandx*{\JSoundOne}[4][1=\Psi, 2=\fenv, usedefault=@]% + {\vdash #3 \sim #4} +% \newcommand{\Smodi}[4]{\ensuremath{\oxb{=#2 \cc #3 \imps #4}^{#1}}} +\newcommand{\Smodi}[3]{\ensuremath{\oxb{=#2 \cc #3}^{#1}}} +\newcommand{\Smod}[2]{\Smodi{+}{#1}{#2}} +\newcommand{\Ssig}[2]{\Smodi{-}{#1}{#2}} +\newcommand{\Sreq}[2]{\Smodi{?}{#1}{#2}} +\newcommand{\Shole}[2]{\Smodi{\circ}{#1}{#2}} + +\newcommand{\SSmodi}[2]{\ensuremath{\oxb{=#2}^{#1}}} +\newcommand{\SSmod}[1]{\SSmodi{+}{#1}} +\newcommand{\SSsig}[1]{\SSmodi{-}{#1}} +\newcommand{\SSreq}[1]{\SSmodi{?}{#1}} +\newcommand{\SShole}[1]{\SSmodi{\circ}{#1}} + +% \newcommand{\styp}[3]{\oxb{{#1}\cc{#2}}^{#3}} +\newcommand{\styp}[3]{{#1}{:}{#2}^{#3}} +\newcommand{\stm}[2]{\styp{#1}{#2}{\scriptscriptstyle+}} +\newcommand{\sts}[2]{\styp{#1}{#2}{\scriptscriptstyle-}} + +% \newcommand{\mtypsep}{[\!]} +\newcommand{\mtypsep}{\mbox{$\bm{;}$}} +\newcommand{\mtypsepsp}{\hspace{.3em}} +\newcommand{\msh}[3]{\aoxb{#1 ~\mtypsep~ #2 ~\mtypsep~ #3}} +\newcommand{\mtyp}[3]{ + \aoxb{\mtypsepsp #1 \mtypsepsp\mtypsep\mtypsepsp + #2 \mtypsepsp\mtypsep\mtypsepsp + #3 \mtypsepsp}} +\newcommand{\bigmtyp}[3]{\ensuremath{ + \left\langle\!\vrule \begin{array}{l} + #1 ~\mtypsep \\[0pt] + #2 ~\mtypsep \\ + #3 + \end{array} \vrule\!\right\rangle +}} + + +\newcommand{\mtypm}[2]{\mtyp{#1}{#2}^{\scriptstyle+}} +\newcommand{\mtyps}[2]{\mtyp{#1}{#2}^{\scriptstyle-}} +\newcommand{\bigmtypm}[2]{\bigmtyp{#1}{#2}^{\scriptstyle+}} +\newcommand{\bigmtyps}[2]{\bigmtyp{#1}{#2}^{\scriptstyle-}} + +\newcommand{\mref}{\ensuremath{\mathit{mref}}} +\newcommand{\selfpath}{\msyn{Local}} + +% \newcommand{\Ltyp}[3]{\oxb{#1 \mathbin{\scriptstyle\MVAt} #2}^{#3}} +% \newcommand{\Ltyp}[2]{\poxb{#1 \mathbin{\scriptstyle\MVAt} #2}} +\newcommand{\Ltyp}[2]{#1 {\scriptstyle\MVAt} #2} + +\newcommand{\Sshape}[1]{\ensuremath{\syn{shape}(#1)}} +\newcommand{\Srename}[2]{\ensuremath{\syn{rename}(#1;#2)}} +\newcommand{\Scons}[2]{\ensuremath{\syn{cons}(#1;#2)}} +\newcommand{\Smkreq}[1]{\ensuremath{\syn{hide}(#1)}} +\newcommand{\Sfv}[1]{\ensuremath{\syn{fv}(#1)}} +\newcommand{\Sdom}[1]{\ensuremath{\syn{dom}(#1)}} +\newcommand{\Srng}[1]{\ensuremath{\syn{rng}(#1)}} +\newcommand{\Sdomp}[2]{\ensuremath{\syn{dom}_{#1}(#2)}} +\newcommand{\Sclos}[1]{\ensuremath{\syn{clos}(#1)}} +\newcommand{\Scloss}[2]{\ensuremath{\syn{clos}_{#1}(#2)}} +\newcommand{\Snorm}[1]{\ensuremath{\syn{norm}(#1)}} +\newcommand{\Sident}[1]{\ensuremath{\syn{ident}(#1)}} +\newcommand{\Snec}[2]{\ensuremath{\syn{nec}(#1; #2)}} +\newcommand{\Sprovs}[1]{\ensuremath{\syn{provs}(#1)}} +\newcommand{\Smkstamp}[2]{\ensuremath{\syn{mkident}(#1; #2)}} +\newcommand{\Sname}[1]{\ensuremath{\syn{name}(#1)}} +\newcommand{\Snames}[1]{\ensuremath{\syn{names}(#1)}} +\newcommand{\Sallnames}[1]{\ensuremath{\syn{allnames}(#1)}} +\newcommand{\Shassubs}[1]{\ensuremath{\syn{hasSubs}(#1)}} +\newcommand{\Snooverlap}[1]{\ensuremath{\syn{nooverlap}(#1)}} +\newcommand{\Sreduce}[2]{\ensuremath{\syn{apply}(#1; #2)}} +\newcommand{\Smkfenv}[1]{\ensuremath{\syn{mkfenv}(#1)}} +\newcommand{\Svalidspc}[2]{\ensuremath{\syn{validspc}(#1; #2)}} +\newcommand{\Srepath}[2]{\ensuremath{\syn{repath}(#1; #2)}} +\newcommand{\Smksigenv}[2]{\ensuremath{\syn{mksigenv}(#1; #2)}} +\newcommand{\Smksigshenv}[2]{\ensuremath{\syn{mksigshenv}(#1; #2)}} +\newcommand{\Squalify}[2]{\ensuremath{\syn{qualify}(#1; #2)}} +\newcommandx*{\Sdepends}[2][1=\Psi, usedefault=@]% + {\ensuremath{\syn{depends}_{#1}(#2)}} +\newcommandx*{\Sdependss}[3][1=\Psi, 2=N, usedefault=@]% + {\ensuremath{\syn{depends}_{#1;#2}(#3)}} +\newcommandx*{\Sdependsss}[4][1=\Psi, 2=V, 3=\theta, usedefault=@]% + {\ensuremath{\syn{depends}_{#1;#2;#3}(#4)}} +\newcommand{\Snormsubst}[2]{\ensuremath{\syn{norm}(#1; #2)}} + +% \newcommand{\Smergeable}[2]{\ensuremath{\syn{mergeable}(#1; #2)}} +\newcommand{\mdef}{\mathrel{\bot}} +\newcommand{\Smergeable}[2]{\ensuremath{#1 \mdef #2}} + +\newcommand{\Sstamp}[1]{\ensuremath{\syn{stamp}(#1)}} +\newcommand{\Stype}[1]{\ensuremath{\syn{type}(#1)}} + +\newcommand{\Strue}{\ensuremath{\syn{true}}} +\newcommand{\Sfalse}{\ensuremath{\syn{false}}} + +\newcommandx*{\refsstar}[2][1=\nu_0, usedefault=@]% + {\ensuremath{\syn{refs}^{\star}}_{#1}(#2)} + +\renewcommand{\merge}{\boxplus} +\newcommand{\meet}{\sqcap} + +\newcommand{\Shaslocaleenv}[3]{\ensuremath{\syn{haslocaleenv}(#1;#2;#3)}} +\newcommand{\MTvalidnewmod}[3]{\ensuremath{\syn{validnewmod}(#1;#2;#3)}} +\newcommand{\Sdisjoint}[1]{\ensuremath{\syn{disjoint}(#1)}} +\newcommand{\Sconsistent}[1]{\ensuremath{\syn{consistent}(#1)}} +\newcommand{\Slocmatch}[2]{\ensuremath{\syn{locmatch}(#1;#2)}} +\newcommand{\Sctxmatch}[2]{\ensuremath{\syn{ctxmatch}(#1;#2)}} +\newcommand{\Snolocmatch}[2]{\ensuremath{\syn{nolocmatch}(#1;#2)}} +\newcommand{\Snoctxmatch}[2]{\ensuremath{\syn{noctxmatch}(#1;#2)}} +\newcommand{\Sislocal}[2]{\ensuremath{\syn{islocal}(#1;#2)}} +\newcommand{\Slocalespcs}[2]{\ensuremath{\syn{localespcs}(#1;#2)}} + +\newcommand{\Cprod}[1]{\syn{productive}(#1)} +\newcommand{\Cnil}{\nil} +\newcommand{\id}{\syn{id}} + +\newcommand{\nui}{\nu_{\syn{i}}} +\newcommand{\taui}{\tau_{\syn{i}}} +\newcommand{\Psii}{\Psi_{\syn{i}}} + +\newcommand{\vis}{\ensuremath{\mathsf{\scriptstyle V}}} +\newcommand{\hid}{\ensuremath{\mathsf{\scriptstyle H}}} + +\newcommand{\taum}[1]{\ensuremath{\tau_{#1}^{m_{#1}}}} + +\newcommand{\sigmamod}{\sigma_{\syn{m}}} +\newcommand{\sigmaprov}{\sigma_{\syn{p}}} + +\newcommand{\Svalidsubst}[2]{\ensuremath{\syn{validsubst}(#1;#2)}} +\newcommand{\Salias}[1]{\ensuremath{\syn{alias}(#1)}} +\newcommand{\Saliases}[1]{\ensuremath{\syn{aliases}(#1)}} +\newcommand{\Simp}[1]{\ensuremath{\syn{imp}(#1)}} +\newcommand{\Styp}[1]{\ensuremath{\syn{typ}(#1)}} +\newcommand{\Spol}[1]{\ensuremath{\syn{pol}(#1)}} + +\newcommand{\stoff}{\stof{(-)}} +\newcommand{\stheta}{\stof\theta} + + +%%%%%%% FOR THE PAPER! +\newcommand{\secref}[1]{Section~\ref{sec:#1}} +\newcommand{\figref}[1]{Figure~\ref{fig:#1}} + +% typesetting for module/path names +\newcommand{\mname}[1]{\textsf{#1}} +\newcommand{\m}[1]{\mname{#1}} + +% typesetting for package names +\newcommand{\pname}[1]{\textsf{#1}} + +\newcommand{\kpm}[2]{\angb{\pname{#1}.#2}} + +% for core entities +\newcommand{\code}[1]{\texttt{#1}} +\newcommand{\core}[1]{\texttt{#1}} + +\newcommand{\req}{\bsyn{req}} +\newcommand{\hiding}[1]{\req~\m{#1}} + +\newcommand{\Emod}[1]{\ensuremath{[#1]}} +\newcommand{\Esig}[1]{\ensuremath{[\cc#1]}} +\newcommand{\Epkg}[2]{\bsyn{package}~\pname{#1}~\bsyn{where}~{#2}} +% \newcommand{\Epkgt}[3]{\bsyn{package}~{#1}~\bsyn{only}~{#2}~\bsyn{where}~{#3}} +\newcommand{\Epkgt}[3]{\bsyn{package}~\pname{#1}~{#2}~\bsyn{where}~{#3}} +\newcommand{\Einc}[1]{\bsyn{include}~\pname{#1}} +% \newcommand{\Einct}[2]{\bsyn{include}~{#1}~\bsyn{only}~{#2}} +% \newcommand{\Einctr}[3]{\bsyn{include}~{#1}~\bsyn{only}~{#2}~{#3}} +\newcommand{\Einct}[2]{\bsyn{include}~\pname{#1}~(#2)} +\newcommand{\Eincr}[2]{\bsyn{include}~\pname{#1}~\angb{#2}} +\newcommand{\Einctr}[3]{\bsyn{include}~\pname{#1}~(#2)~\angb{#3}} +\newcommand{\Emv}[2]{#1 \mapsto #2} +\newcommand{\Emvp}[2]{\m{#1} \mapsto \m{#2}} +\newcommand{\Etr}[3][~]{{#2}{#1}\langle #3 \rangle} +\newcommand{\Erm}[3][~]{{#2}{#1}\langle #3 \mapnil \rangle} +\newcommand{\Ethin}[1]{(#1)} +\newcommand{\Ethinn}[2]{(#1; #2)} + + +% \newcommand{\Pdef}[2]{\ensuremath{\begin{array}{l} \Phead{#1} #2\end{array}}} +% \newcommand{\Phead}[1]{\bsyn{package}~\pname{#1}~\bsyn{where} \\} +% \newcommand{\Pbndd}[2]{\hspace{1em}{#1} = {#2} \\} +% \newcommand{\Pbnd}[2]{\hspace{1em}\mname{#1} = {#2} \\} +% \newcommand{\Pref}[2]{\hspace{1em}\mname{#1} = \mname{#2} \\} +% \newcommand{\Pmod}[2]{\hspace{1em}\mname{#1} = [\code{#2}] \\} +% \newcommand{\Psig}[2]{\hspace{1em}\mname{#1} \cc [\code{#2}] \\} +\newcommand{\Pdef}[2]{\ensuremath{ + \begin{array}{@{\hspace{1em}}L@{\;\;}c@{\;\;}l} + \multicolumn{3}{@{}l}{\Phead{#1}} \\ + #2 + \end{array} +}} +\newcommand{\Pdeft}[3]{\ensuremath{ + \begin{array}{@{\hspace{1em}}L@{\;\;}c@{\;\;}l} + \multicolumn{3}{@{}l}{\Pheadt{#1}{#2}} \\ + #3 + \end{array} +}} +\newcommand{\Phead}[1]{\bsyn{package}~\pname{#1}~\bsyn{where}} +\newcommand{\Pheadt}[2]{\bsyn{package}~\pname{#1}~(#2)~\bsyn{where}} +\newcommand{\Pbnd}[2]{#1 &=& #2 \\} +\newcommand{\Pref}[2]{\mname{#1} &=& \mname{#2} \\} +\newcommand{\Pmod}[2]{\mname{#1} &=& [\code{#2}] \\} +\newcommand{\Pmodd}[2]{\mname{#1} &=& #2 \\} +\newcommand{\Psig}[2]{\mname{#1} &\cc& [\code{#2}] \\} +\newcommand{\Psigg}[2]{\mname{#1} &\cc& #2 \\} +\newcommand{\Pmulti}[1]{\multicolumn{3}{@{\hspace{1em}}l} {#1} \\} +\newcommand{\Pinc}[1]{\Pmulti{\Einc{#1}}} +\newcommand{\Pinct}[2]{\Pmulti{\Einct{#1}{#2}}} +\newcommand{\Pincr}[2]{\Pmulti{\Eincr{#1}{#2}}} +\newcommand{\Pinctr}[3]{\Pmulti{\Einctr{#1}{#2}{#3}}} +\newcommand{\Pmodbig}[2]{\mname{#1} &=& \left[ + \begin{codeblock} + #2 + \end{codeblock} +\right] \\} +\newcommand{\Psigbig}[2]{\mname{#1} &\cc& \left[ + \begin{codeblock} + #2 + \end{codeblock} +\right] \\} + +\newcommand{\Mimp}[1]{\msyn{import}~\mname{#1}} +\newcommand{\Mimpq}[1]{\msyn{import}~\msyn{qualified}~\mname{#1}} +\newcommand{\Mimpas}[2]{\msyn{import}~\mname{#1}~\msyn{as}~\mname{#2}} +\newcommand{\Mimpqas}[2]{\msyn{import}~\msyn{qualified}~\mname{#1}~\msyn{as}~\mname{#2}} +\newcommand{\Mexp}[1]{\msyn{export}~(#1)} + +\newcommand{\illtyped}{\hfill ($\times$) \; ill-typed} + +\newenvironment{example}[1][LL]% + {\ignorespaces \begin{flushleft}\begin{tabular}{@{\hspace{1em}}#1} }% + {\end{tabular}\end{flushleft} \ignorespacesafterend} + +\newenvironment{counterexample}[1][LL]% + {\ignorespaces \begin{flushleft}\begin{tabular}{@{\hspace{1em}}#1} }% + {& \text{\illtyped} \end{tabular}\end{flushleft} \ignorespacesafterend} + +\newenvironment{codeblock}% + {\begin{varwidth}{\textwidth}\begin{alltt}}% + {\end{alltt}\end{varwidth}} + +\newcommand{\fighead}{\hrule\vspace{1.5ex}} +\newcommand{\figfoot}{\vspace{1ex}\hrule} +\newenvironment{myfig}{\fighead\small}{\figfoot} + +\newcommand{\Mhead}[2]{\syn{module}~{#1}~\syn{(}{#2}\syn{)}~\syn{where}} +\newcommand{\Mdef}[3]{\ensuremath{ + \begin{array}{@{\hspace{1em}}L} + \multicolumn{1}{@{}L}{\Mhead{#1}{\core{#2}}} \\ + #3 + \end{array} +}} + +\newcommand{\HMstof}[1]{\ensuremath{#1}} +% \newcommand{\HMstof}[1]{\ensuremath{\lfloor #1 \rfloor}} +% \newcommand{\HMstof}[1]{\ensuremath{\underline{#1}}} +% \newcommand{\HMstof}[1]{{#1}^{\star}} +\newcommand{\HMhead}[2]{\syn{module}~\(\HMstof{#1}\)~\syn{(}{#2}\syn{)}~\syn{where}} +\newcommand{\HMdef}[3]{\ensuremath{ + \begin{array}{@{\hspace{1em}}L} + \multicolumn{1}{@{}L}{\HMhead{#1}{\core{#2}}} \\ + #3 + \end{array} +}} +\newcommand{\HMimpas}[3]{% + \msyn{import}~\ensuremath{\HMstof{#1}}~% + \msyn{as}~\mname{#2}~\msyn{(}\core{#3}\msyn{)}} +\newcommand{\HMimpqas}[3]{% + \msyn{import}~\msyn{qualified}~\ensuremath{\HMstof{#1}}~% + \msyn{as}~\mname{#2}~\msyn{(}\core{#3}\msyn{)}} + +\newcommand{\stackedenv}[2][c]{\ensuremath{ + \begin{array}{#1} + #2 + \end{array} +}} + +% \renewcommand{\nil}{\mathsf{nil}} +\renewcommand{\nil}{\mathrel\emptyset} + +% \newcommand{\ee}{\mathit{ee}} +\newcommand{\ee}{\mathit{dent}} + +\renewcommand{\gets}{\mathbin{\coloneqq}}
\ No newline at end of file diff --git a/docs/backpack/commands-rebindings.tex b/docs/backpack/commands-rebindings.tex new file mode 100644 index 0000000000..96ad2bb2cc --- /dev/null +++ b/docs/backpack/commands-rebindings.tex @@ -0,0 +1,57 @@ + + +%% hide the full syntax of shapes/types for the paper +\newcommand{\fullmsh}[3]{\aoxb{#1 ~\mtypsep~ #2 ~\mtypsep~ #3}} +\newcommand{\fullmtyp}[3]{ + \aoxb{\mtypsepsp #1 \mtypsepsp\mtypsep\mtypsepsp + #2 \mtypsepsp\mtypsep\mtypsepsp + #3 \mtypsepsp}} +\newcommand{\fullbigmtyp}[3]{\ensuremath{ + \left\langle\!\vrule \begin{array}{l} + #1 ~\mtypsep \\[0pt] + #2 ~\mtypsep \\ + #3 + \end{array} \vrule\!\right\rangle +}} +\renewcommand{\msh}[2]{\aoxb{#1 \mtypsepsp\mtypsep\mtypsepsp #2}} +\renewcommand{\mtyp}[2]{ + \aoxb{#1 ~\mtypsep~ #2}} +\newcommand{\mtypstretch}[2]{ + \left\langle\!\vrule + \mtypsepsp #1 \mtypsepsp\mtypsep\mtypsepsp #2 \mtypsepsp + \vrule\!\right\rangle +} +\renewcommand{\bigmtyp}[2]{\ensuremath{ + \left\langle\!\vrule \begin{array}{l} + #1 ~\mtypsep \\[0pt] #2 + \end{array} \vrule\!\right\rangle +}} + + + +%% change syntax of signatures +\renewcommand{\Esig}[1]{\ensuremath{\,[#1]}} + +\renewcommandx*{\JBVSh}[3][1=\Delta, usedefault=@]% + {#1 \vdashsh #2 \Rightarrow #3} + + +% JUDGMENTS +\renewcommandx*{\JBTypElab}[6][1=\Delta, 2=\Gamma, 3=\shctx, usedefault=@]% + % {\JBTyp[#1][#2][#3]{#4}{#5} \elabto #6} + {\JBTyp[#1][#2][#3]{#4}{#5} \;\shade{\elabto #6}} +\renewcommandx*{\JBVTypElab}[5][1=\Delta, 2=\shctx, usedefault=@]% + % {\JBVTyp[#1][#2]{#3}{#4} \elabto #5} + {\JBVTyp[#1][#2]{#3}{#4} \;\shade{\elabto #5}} +\renewcommandx*{\JDTypElab}[4][1=\Delta, usedefault=@]% + % {#1 \vdash #2 : #3 \elabto #4} + {#1 \vdash #2 : #3 \;\shade{\elabto #4}} +\renewcommandx*{\JCModElab}[5][1=\Gamma, 2=\nu_0, usedefault=@]% + % {#1; #2 \vdashghc #3 : #4 \elabto #5} + {#1; #2 \vdashghc #3 : #4 \;\shade{\elabto #5}} + + +%%% Local Variables: +%%% mode: latex +%%% TeX-master: "paper" +%%% End: diff --git a/docs/docbook-cheat-sheet/Makefile b/docs/docbook-cheat-sheet/Makefile deleted file mode 100644 index 8cd9f51869..0000000000 --- a/docs/docbook-cheat-sheet/Makefile +++ /dev/null @@ -1,9 +0,0 @@ -TOP = ../.. -include $(TOP)/mk/boilerplate.mk - -XML_DOC = docbook-cheat-sheet -INSTALL_XML_DOC = docbook-cheat-sheet - -include $(TOP)/mk/bindist.mk - -include $(TOP)/mk/target.mk diff --git a/docs/docbook-cheat-sheet/docbook-cheat-sheet.xml b/docs/docbook-cheat-sheet/docbook-cheat-sheet.xml deleted file mode 100644 index d48b3ef6f2..0000000000 --- a/docs/docbook-cheat-sheet/docbook-cheat-sheet.xml +++ /dev/null @@ -1,223 +0,0 @@ -<?xml version="1.0" encoding="iso-8859-1"?> -<!DOCTYPE article PUBLIC "-//OASIS//DTD DocBook XML V4.5//EN" - "http://www.oasis-open.org/docbook/xml/4.5/docbookx.dtd"> - -<article id="docbook-cheat-sheet"> - - <articleinfo> - <title>Using DocBook to write GHC documentation</title> - <author><othername>The GHC Team</othername></author> - <address><email>glasgow-haskell-{users,bugs}@dcs.gla.ac.uk</email></address> - <pubdate>January 2000</pubdate> - </articleinfo> - - <sect1 id="sec-getting-docbook"> - <title>Getting the DocBook tools</title> - <para>See the installation guide.</para> - </sect1> - - <sect1 id="doc-layout"> - <title>Document layout</title> - - <para>The GHC documentation is written using DocBook XML V4.5, so - the first few lines should look like this:</para> - -<programlisting> -<?xml version="1.0" encoding="iso-8859-1"?> -<!DOCTYPE article PUBLIC "-//OASIS//DTD DocBook XML V4.5//EN" - "http://www.oasis-open.org/docbook/xml/4.5/docbookx.dtd"> -</programlisting> - - <para>The encoding can of course be chosen according to taste.</para> - - <para> This guide is <emphasis>not</emphasis> meant to teach you - how to write DocBook; read the <ulink - url="http://www.docbook.org/">DocBook book</ulink> for that. It is - more of a reference than a tutorial, so see the <ulink - url="http://www.oasis-open.org/docbook/">DocBook home page</ulink> - for other links.</para> - - <para>However, by popular demand, here are some useful points: - </para> - - <itemizedlist> - <listitem> - <para>Remember to use <sgmltag class="starttag">para</sgmltag> - inside <sgmltag class="starttag">listitem</sgmltag>s.</para> - </listitem> - </itemizedlist> - - <para>The rest of this section outlines the use of several tags - which may not be obvious (DocBook is rather scholastic in style: - it has tags for many things from C function prototypes to keyboard - bindings; at the same time it has many omissions and - oddities). The current scheme has many infelicities, partly - because it was dreamt up in a hurry while the author was learning - DocBook and converting the documentation thereto, and partly - because DocBook is rather C-centric.</para> - - <variablelist> - - <varlistentry> - <term>Comments</term> - <listitem> - <para>Comments in XML look like this: <sgmltag - class="sgmlcomment">This is a comment</sgmltag>.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term><sgmltag class="starttag">command</sgmltag></term> - <listitem> - <para>Used for commands typed into interactive sessions - (e.g. <command>cp foo bar</command> and the names of - programs such as <command>gmake</command>.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term><sgmltag class="starttag">constant</sgmltag></term> - <listitem> - <para>Used for system constants such as - <constant>U_MAXINT</constant> and - <filename>Makefile</filename> variables like - <constant>SRC_FILES</constant> (because they are usually - constant for a given run of <command>make</command>, and - hence have a constant feel to them).</para> - </listitem> - </varlistentry> - - <varlistentry> - <term><sgmltag class="starttag">email</sgmltag></term> - <listitem> - <para>For email addresses. This is a tag that's easy to - overlook if you don't know it's there.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term><sgmltag class="starttag">filename</sgmltag></term> - <listitem> - <para>Used for paths, filenames, file extensions.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term><sgmltag class="starttag">function</sgmltag></term> - <listitem> - <para>Used for functions and constructors.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term><sgmltag class="starttag">indexterm</sgmltag></term> - <listitem> - <para>The normal way to mark up an index term is - <literal><indexterm><primary>term</primary></indexterm></literal>.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term><sgmltag class="starttag">keycap</sgmltag></term> - <term><sgmltag class="starttag">keycombo</sgmltag></term> - <listitem> - <para>Some more tags you may miss. Used for combinations - such as - <keycombo><keycap>Control</keycap><keycap>D</keycap></keycombo>.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term><sgmltag class="starttag">literal</sgmltag></term> - <listitem> - <para>Used for everything that should appear in typewriter - font that has no other obvious tag: types, monads, small - snippets of program text that are formatted inline, and the - like.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term><sgmltag class="starttag">option</sgmltag></term> - <listitem> - <para>Used for compiler options and similar.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term><sgmltag class="starttag">programlisting</sgmltag></term> - <listitem> - <para>For displayed program listings (including shell - scripts).</para> - </listitem> - </varlistentry> - - <varlistentry> - <term><sgmltag class="starttag">screen</sgmltag></term> - <listitem> - <para>For displayed screen dumps, such as portions of shell - interaction. It's easy to tell the difference between these - and shell scripts: the latter lack a shell prompt.</para> - </listitem> - </varlistentry> - - <varlistentry> - <term><sgmltag class="starttag">varname</sgmltag></term> - <listitem> - <para>Used for variables, but not type variables.</para> - </listitem> - </varlistentry> - - </variablelist> - - </sect1> - - <sect1 id="docbook-tables"> - <title>Tables</title> - - <para>Tables are quite complicated to write in DocBook XML (as in HTML, - there are lots of fiddly tags), so here's an example you can - cannibalise. In the spirit of the LaTeX short introduction I don't - repeat all the markup verbatim; you have to look at the source for - that.</para> - - <informaltable> - <tgroup cols="3"> - <colspec colname="one" align="left" colsep="0"/> - <colspec colname="two" align="center" colsep="0"/> - <colspec colname="three" align="right" colsep="0"/> - <tbody> - - <row> - <entry>Here's</entry> - <entry>a sample</entry> - <entry>table</entry> - </row> - - <row> - <entry>With differently</entry> - <entry>aligned</entry> - <entry>cells</entry> - </row> - - <row> - <entry namest="one" nameend="three" morerows="1"> - <para> There's not much else to it. Entries can span - both extra rows and extra columns; just be careful when - using block markup (such as <sgmltag - class="starttag">para</sgmltag>s) within an <sgmltag - class="starttag">entry</sgmltag> that there is no space - between the open and close <sgmltag - class="starttag">entry</sgmltag> tags and the adjacent - text, as otherwise you will suffer from <ulink - url="http://www.docbook.org/tdg/html/entry.html">Pernicious - Mixed Content</ulink> (the parser will think you're - using inline markup).</para> - </entry> - </row> - - </tbody> - </tgroup> - </informaltable> - </sect1> -</article> diff --git a/docs/users_guide/7.10.1-notes.xml b/docs/users_guide/7.10.1-notes.xml index b45721cd7b..0af4c3145b 100644 --- a/docs/users_guide/7.10.1-notes.xml +++ b/docs/users_guide/7.10.1-notes.xml @@ -42,7 +42,20 @@ <itemizedlist> <listitem> <para> - TODO FIXME + GHC now checks that all the language extensions required for + the inferred type signatures are explicitly enabled. This + means that if any of the type signatures inferred in your + program requires some language extension you will need to + enable it. The motivation is that adding a missing type + signature inferred by GHC should yield a program that + typechecks. Previously this was not the case. + </para> + <para> + This is a breaking change. Code that used to compile in the + past might fail with an error message requiring some + particular language extension (most likely + <option>-XTypeFamilies</option>, <option>-XGADTs</option> or + <option>-XFlexibleContexts</option>). </para> </listitem> </itemizedlist> @@ -86,7 +99,21 @@ <itemizedlist> <listitem> <para> - TODO FIXME + <literal>ghc-pkg</literal> now respects <option>--user</option> + and <option>--global</option> when modifying packages (e.g. + changing exposed/trust flag or unregistering). Previously, + <literal>ghc-pkg</literal> would ignore these flags and modify + whichever package it found first on the database stack. To + recover the old behavior, simply omit these flags. + </para> + </listitem> + <listitem> + <para> + <literal>ghc-pkg</literal> accepts a <option>--user-package-db</option> + flag which allows a user to override the location of the user package + database. Unlike databases specified using <option>--package-db</option>, + a user package database configured this way respects + the <option>--user</option> flag. </para> </listitem> </itemizedlist> @@ -207,6 +234,27 @@ </sect3> <sect3> + <title>ghc</title> + <itemizedlist> + <listitem> + <para> + Many internal functions in GHC related to package IDs have been + renamed to refer to package keys, e.g. <literal>PackageId</literal> + is now <literal>PackageKey</literal>, the wired-in names + such as <literal>primPackageId</literal> are now + <literal>primPackageKey</literal>, etc. This reflects a distinction + that we are now making: a package ID is, as before, the user-visible + ID from Cabal <literal>foo-1.0</literal>; a package key is now + a compiler-internal entity used for generating linking symbols, and + may not correspond at all to the package ID. In + particular, there may be multiple package keys per + package ID. + </para> + </listitem> + </itemizedlist> + </sect3> + + <sect3> <title>ghc-prim</title> <itemizedlist> <listitem> diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 1dd224a611..8381ca1254 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -590,7 +590,7 @@ </thead> <tbody> <row> - <entry><option>-package-name</option> <replaceable>P</replaceable></entry> + <entry><option>-this-package-key</option> <replaceable>P</replaceable></entry> <entry>Compile to be part of package <replaceable>P</replaceable></entry> <entry>static</entry> <entry>-</entry> diff --git a/docs/users_guide/ghci.xml b/docs/users_guide/ghci.xml index 50b59e9e25..729f96f244 100644 --- a/docs/users_guide/ghci.xml +++ b/docs/users_guide/ghci.xml @@ -3296,12 +3296,38 @@ Prelude> :set -fno-warn-incomplete-patterns -XNoMultiParamTypeClasses <title>Setting options for interactive evaluation only</title> <para> - GHCi actually maintains two sets of options: one set that - applies when loading modules, and another set that applies for - expressions and commands typed at the prompt. The - <literal>:set</literal> command modifies both, but there is + GHCi actually maintains <emphasis>two</emphasis> sets of options: +<itemizedlist> +<listitem><para> + The <emphasis>loading options</emphasis> apply when loading modules +</para></listitem> +<listitem><para> + The <emphasis>interactive options</emphasis> apply when evaluating expressions and commands typed at the GHCi prompt. +</para></listitem> +</itemizedlist> +The <literal>:set</literal> command modifies both, but there is also a <literal>:seti</literal> command (for "set - interactive") that affects only the second set. + interactive") that affects only the interactive options set. + </para> + + <para> + It is often useful to change the interactive options, + without having that option apply to loaded modules + too. For example +<screen> +:seti -XMonoLocalBinds +</screen> + It would be undesirable if <option>-XMonoLocalBinds</option> were to + apply to loaded modules too: that might cause a compilation error, but + more commonly it will cause extra recompilation, because GHC will think + that it needs to recompile the module because the flags have changed. + </para> + + <para> + If you are setting language options in your <literal>.ghci</literal> file, it is good practice + to use <literal>:seti</literal> rather than <literal>:set</literal>, + unless you really do want them to apply to all modules you + load in GHCi. </para> <para> @@ -3309,8 +3335,6 @@ Prelude> :set -fno-warn-incomplete-patterns -XNoMultiParamTypeClasses <literal>:set</literal> and <literal>:seti</literal> commands respectively, with no arguments. For example, in a clean GHCi session we might see something like this: - </para> - <screen> Prelude> :seti base language is: Haskell2010 @@ -3324,38 +3348,24 @@ other dynamic, non-language, flag settings: -fimplicit-import-qualified warning settings: </screen> - <para> - Note that the option <option>-XExtendedDefaultRules</option> - is on, because we apply special defaulting rules to + </para> +<para> +The two sets of options are initialised as follows. First, both sets of options +are initialised as described in <xref linkend="ghci-dot-files"/>. +Then the interactive options are modified as follows: +<itemizedlist> +<listitem><para> + The option <option>-XExtendedDefaultRules</option> + is enabled, in order to apply special defaulting rules to expressions typed at the prompt (see <xref linkend="extended-default-rules" />). - </para> - - <para> - Furthermore, the Monomorphism Restriction is disabled by default in - GHCi (see <xref linkend="monomorphism" />). - </para> - - <para> - It is often useful to change the language options for expressions typed - at the prompt only, without having that option apply to loaded modules - too. For example -<screen> -:seti -XMonoLocalBinds -</screen> - It would be undesirable if <option>-XMonoLocalBinds</option> were to - apply to loaded modules too: that might cause a compilation error, but - more commonly it will cause extra recompilation, because GHC will think - that it needs to recompile the module because the flags have changed. - </para> + </para></listitem> - <para> - It is therefore good practice if you are setting language - options in your <literal>.ghci</literal> file, to use - <literal>:seti</literal> rather than <literal>:set</literal> - unless you really do want them to apply to all modules you - load in GHCi. - </para> +<listitem> <para> + The Monomorphism Restriction is disabled (see <xref linkend="monomorphism" />). + </para></listitem> +</itemizedlist> +</para> </sect2> </sect1> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index e97d5798fe..de0d494997 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -987,9 +987,15 @@ Which enables us to rewrite our functions in a much cleaner style: In this case, <literal>Head</literal> <replaceable>x</replaceable> cannot be used in expressions, only patterns, since it wouldn't specify a value for the <replaceable>xs</replaceable> on the -right-hand side. +right-hand side. We can give an explicit inversion of a pattern +synonym using the following syntax: </para> +<programlisting> + pattern Head x <- x:xs where + Head x = [x] +</programlisting> + <para> The syntax and semantics of pattern synonyms are elaborated in the following subsections. @@ -1008,6 +1014,10 @@ bidirectional. The syntax for unidirectional pattern synonyms is: and the syntax for bidirectional pattern synonyms is: <programlisting> pattern Name args = pat +</programlisting> or +<programlisting> + pattern Name args <- pat where + Name args = expr </programlisting> Either prefix or infix syntax can be used. @@ -1020,11 +1030,12 @@ bidirectional. The syntax for unidirectional pattern synonyms is: </para> <para> The variables in the left-hand side of the definition are bound by - the pattern on the right-hand side. For bidirectional pattern - synonyms, all the variables of the right-hand side must also occur - on the left-hand side; also, wildcard patterns and view patterns are - not allowed. For unidirectional pattern synonyms, there is no - restriction on the right-hand side pattern. + the pattern on the right-hand side. For implicitly bidirectional + pattern synonyms, all the variables of the right-hand side must also + occur on the left-hand side; also, wildcard patterns and view + patterns are not allowed. For unidirectional and + explicitly-bidirectional pattern synonyms, there is no restriction + on the right-hand side pattern. </para> <para> @@ -1912,7 +1923,8 @@ the comprehension being over an arbitrary monad. functions <literal>(>>=)</literal>, <literal>(>>)</literal>, and <literal>fail</literal>, are in scope (not the Prelude - versions). List comprehensions, mdo (<xref linkend="recursive-do-notation"/>), and parallel array + versions). List comprehensions, <literal>mdo</literal> + (<xref linkend="recursive-do-notation"/>), and parallel array comprehensions, are unaffected. </para></listitem> <listitem> @@ -2449,7 +2461,7 @@ warns if you hide something that the imported module does not export. </sect3> <sect3> - <title>Package-qualified imports</title> + <title id="package-qualified-imports">Package-qualified imports</title> <para>With the <option>-XPackageImports</option> flag, GHC allows import declarations to be qualified by the package name that the @@ -2472,7 +2484,9 @@ import "network" Network.Socket added mainly so that we can build backwards-compatible versions of packages when APIs change. It can lead to fragile dependencies in the common case: modules occasionally move from one package to - another, rendering any package-qualified imports broken.</para> + another, rendering any package-qualified imports broken. + See also <xref linkend="package-thinning-and-renaming" /> for + an alternative way of disambiguating between module names.</para> </sect3> <sect3 id="safe-imports-ext"> @@ -5010,40 +5024,128 @@ with <option>-fcontext-stack=</option><emphasis>N</emphasis>. 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 -can be modified by two flags: <option>-XOverlappingInstances</option> +should be used to resolve a type-class constraint</emphasis>. +GHC also provides a way to to loosen +the instance resolution, by +allowing more than one instance to match, <emphasis>provided there is a most +specific one</emphasis>. Moreover, it can be loosened further, by allowing more than one instance to match +irespective of whether there is a most specific one. +This section gives the details. +</para> +<para> +To control the choice of instance, it is possible to specify the overlap behavior for individual +instances with a pragma, written immediately after the +<literal>instance</literal> keyword. The pragma may be one of: +<literal>{-# OVERLAPPING #-}</literal>, +<literal>{-# OVERLAPPABLE #-}</literal>, +<literal>{-# OVERLAPS #-}</literal>, +or <literal>{-# INCOHERENT #-}</literal>. +</para> +<para> +The matching behaviour is also influenced by two module-level language extension flags: <option>-XOverlappingInstances</option> <indexterm><primary>-XOverlappingInstances </primary></indexterm> and <option>-XIncoherentInstances</option> <indexterm><primary>-XIncoherentInstances -</primary></indexterm>, as this section discusses. Both these -flags are dynamic flags, and can be set on a per-module basis, using -an <literal>LANGUAGE</literal> pragma if desired (<xref linkend="language-pragma"/>).</para> +</primary></indexterm>. These flags are now deprecated (since GHC 7.10) in favour of +the fine-grained per-instance pragmas. +</para> + <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>. The <option>-XIncoherentInstances</option> flag -further loosens the resolution, by allowing more than one instance to match, -irespective of whether there is a most specific one. +A more precise specification is as follows. +The willingness to be overlapped or incoherent is a property of +the <emphasis>instance declaration</emphasis> itself, controlled as follows: +<itemizedlist> +<listitem><para>An instance is <emphasis>incoherent</emphasis> if: it has an <literal>INCOHERENT</literal> pragma; or if the instance has no pragma and it appears in a module compiled with <literal>-XIncoherentInstances</literal>. +</para></listitem> +<listitem><para>An instance is <emphasis>overlappable</emphasis> if: it has an <literal>OVERLAPPABLE</literal> or <literal>OVERLAPS</literal> pragma; or if the instance has no pragma and it appears in a module compiled with <literal>-XOverlappingInstances</literal>; or if the instance is incoherent. +</para></listitem> +<listitem><para>An instance is <emphasis>overlapping</emphasis> if: it has an <literal>OVERLAPPING</literal> or <literal>OVERLAPS</literal> pragma; or if the instance has no pragma and it appears in a module compiled with <literal>-XOverlappingInstances</literal>; or if the instance is incoherent. +</para></listitem> +</itemizedlist> </para> <para> -For example, consider +Now suppose that, in some client module, we are searching for an instance of the +<emphasis>target constraint</emphasis> <literal>(C ty1 .. tyn)</literal>. +The search works like this. +<itemizedlist> +<listitem><para> +Find all instances I that <emphasis>match</emphasis> the target constraint; +that is, the target constraint is a substitution instance of I. These +instance declarations are the <emphasis>candidates</emphasis>. +</para></listitem> + +<listitem><para> +Eliminate any candidate IX for which both of the following hold: + +<itemizedlist> + <listitem><para>There is another candidate IY that is strictly more specific; + that is, IY is a substitution instance of IX but not vice versa. + </para></listitem> + <listitem><para> + Either IX is <emphasis>overlappable</emphasis>, or IY is + <emphasis>overlapping</emphasis>. (This "either/or" design, rather than a "both/and" design, + allow a client to deliberately override an instance from a library, without requiring a change to the library.) + </para></listitem> + </itemizedlist> +</para> +</listitem> + +<listitem><para> +If exactly one non-incoherent candidate remains, select it. If all +remaining candidates are incoherent, select an arbitary +one. Otherwise the search fails (i.e. when more than one surviving candidate is not incoherent). +</para></listitem> + +<listitem><para> +If the selected candidate (from the previous step) is incoherent, the search succeeds, returning that candidate. +</para></listitem> + +<listitem><para> +If not, find all instances that <emphasis>unify</emphasis> with the target +constraint, but do not <emphasis>match</emphasis> it. +Such non-candidate instances might match when the target constraint is further +instantiated. If all of them are incoherent, the search succeeds, returning the selected candidate; +if not, the search fails. +</para></listitem> + +</itemizedlist> +Notice that these rules are not influenced by flag settings in the client module, where +the instances are <emphasis>used</emphasis>. +These rules make it possible for a library author to design a library that relies on +overlapping instances without the client having to know. +</para> +<para> +Errors are reported <emphasis>lazily</emphasis> (when attempting to solve a constraint), rather than <emphasis>eagerly</emphasis> +(when the instances themselves are defined). Consider, for example <programlisting> - instance context1 => C Int b where ... -- (A) - instance context2 => C a Bool where ... -- (B) - instance context3 => C a [b] where ... -- (C) - instance context4 => C Int [Int] where ... -- (D) + instance C Int b where .. + instance C a Bool where .. </programlisting> -compiled with <option>-XOverlappingInstances</option> enabled. The constraint -<literal>C Int [Int]</literal> matches instances (A), (C) and (D), but the last +These potentially overlap, but GHC will not complain about the instance declarations +themselves, regardless of flag settings. If we later try to solve the constraint +<literal>(C Int Char)</literal> then only the first instance matches, and all is well. +Similarly with <literal>(C Bool Bool)</literal>. But if we try to solve <literal>(C Int Bool)</literal>, +both instances match and an error is reported. +</para> + +<para> +As a more substantial example of the rules in action, consider +<programlisting> + instance {-# OVERLAPPABLE #-} context1 => C Int b where ... -- (A) + instance {-# OVERLAPPABLE #-} context2 => C a Bool where ... -- (B) + instance {-# OVERLAPPABLE #-} context3 => C a [b] where ... -- (C) + instance {-# OVERLAPPING #-} context4 => C Int [Int] where ... -- (D) +</programlisting> +Now suppose that the type inference +engine needs to solve the constraint +<literal>C Int [Int]</literal>. This constraint matches instances (A), (C) and (D), but the last is more specific, and hence is chosen. </para> <para>If (D) did not exist then (A) and (C) would still be matched, but neither is -most specific. In that case, the program would be rejected even with -<option>-XOverlappingInstances</option>. With -<option>-XIncoherentInstances</option> enabled, it would be accepted and (A) or +most specific. In that case, the program would be rejected, unless +<option>-XIncoherentInstances</option> is enabled, in which case it would be accepted and (A) or (C) would be chosen arbitrarily. </para> <para> @@ -5053,7 +5155,7 @@ the head of former is a substitution instance of the latter. For example substituting <literal>a:=Int</literal>. </para> <para> -However, GHC is conservative about committing to an overlapping instance. For example: +GHC is conservative about committing to an overlapping instance. For example: <programlisting> f :: [b] -> [b] f x = ... @@ -5150,56 +5252,6 @@ the program prints would be to reject module <literal>Help</literal> on the grounds that a later instance declaration might overlap the local one.) </para> -<para> -The willingness to be overlapped or incoherent is a property of -the <emphasis>instance declaration</emphasis> itself, controlled by the -presence or otherwise of the <option>-XOverlappingInstances</option> -and <option>-XIncoherentInstances</option> flags when that module is -being defined. Suppose we are searching for an instance of the -<emphasis>target constraint</emphasis> <literal>(C ty1 .. tyn)</literal>. -The search works like this. -<itemizedlist> -<listitem><para> -Find all instances I that <emphasis>match</emphasis> the target constraint; -that is, the target constraint is a substitution instance of I. These -instance declarations are the <emphasis>candidates</emphasis>. -</para></listitem> - -<listitem><para> -Find all <emphasis>non-candidate</emphasis> instances -that <emphasis>unify</emphasis> with the target constraint. -Such non-candidates instances might match when the target constraint is further -instantiated. If all of them were compiled with -<option>-XIncoherentInstances</option>, proceed; if not, the search fails. -</para></listitem> - -<listitem><para> -Eliminate any candidate IX for which both of the following hold: - -<itemizedlist> -<listitem><para>There is another candidate IY that is strictly more specific; -that is, IY is a substitution instance of IX but not vice versa. -</para></listitem> -<listitem><para>Either IX or IY was compiled with -<option>-XOverlappingInstances</option>. -</para></listitem> -</itemizedlist> - -</para></listitem> - -<listitem><para> -If only one candidate remains, pick it. -Otherwise if all remaining candidates were compiled with -<option>-XInccoherentInstances</option>, pick an arbitrary candidate. -</para></listitem> - -</itemizedlist> -These rules make it possible for a library author to design a library that relies on -overlapping instances without the library client having to know. -</para> -<para>The <option>-XIncoherentInstances</option> flag implies the -<option>-XOverlappingInstances</option> flag, but not vice versa. -</para> </sect3> <sect3 id="instance-sigs"> @@ -6023,28 +6075,39 @@ instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where data GMap (Either a b) v = GMapEither (GMap a v) (GMap b v) ... -instance (Eq (Elem [e])) => Collects ([e]) where +instance Eq (Elem [e]) => Collects [e] where type Elem [e] = e ... </programlisting> - The most important point about associated family instances is that the - type indexes corresponding to class parameters must be identical to - the type given in the instance head; here this is the first argument - of <literal>GMap</literal>, namely <literal>Either a b</literal>, - which coincides with the only class parameter. - </para> - <para> - Instances for an associated family can only appear as part of - instance declarations of the class in which the family was declared - - just as with the equations of the methods of a class. Also in - correspondence to how methods are handled, declarations of associated - types can be omitted in class instances. If an associated family - instance is omitted, the corresponding instance type is not inhabited; +Note the following points: +<itemizedlist> +<listitem><para> + The type indexes corresponding to class parameters must have precisely the same shape + the type given in the instance head. To have the same "shape" means that + the two types are identical modulo renaming of type variables. For example: +<programlisting> +instance Eq (Elem [e]) => Collects [e] where + -- Choose one of the following alternatives: + type Elem [e] = e -- OK + type Elem [x] = x -- OK + type Elem x = x -- BAD; shape of 'x' is different to '[e]' + type Elem [Maybe x] = x -- BAD: shape of '[Maybe x]' is different to '[e]' +</programlisting> +</para></listitem> +<listitem><para> + An instances for an associated family can only appear as part of + an instance declarations of the class in which the family was declared, + just as with the equations of the methods of a class. +</para></listitem> +<listitem><para> + The instance for an associated type can be omitted in class instances. In that case, + unless there is a default instance (see <xref linkend="assoc-decl-defs"/>), + the corresponding instance type is not inhabited; i.e., only diverging expressions, such as <literal>undefined</literal>, can assume the type. - </para> - <para> - Although it is unusual, there can be <emphasis>multiple</emphasis> +</para></listitem> +<listitem><para> + Although it is unusual, there (currently) can be <emphasis>multiple</emphasis> instances for an associated family in a single instance declaration. For example, this is legitimate: <programlisting> @@ -6058,8 +6121,10 @@ instance GMapKey Flob where Since you cannot give any <emphasis>subsequent</emphasis> instances for <literal>(GMap Flob ...)</literal>, this facility is most useful when the free indexed parameter is of a kind with a finite number of alternatives - (unlike <literal>*</literal>). - </para> + (unlike <literal>*</literal>). WARNING: this facility may be withdrawn in the future. +</para></listitem> +</itemizedlist> +</para> </sect3> <sect3 id="assoc-decl-defs"> @@ -6077,22 +6142,50 @@ class IsBoolMap v where instance IsBoolMap [(Int, Bool)] where lookupKey = lookup </programlisting> -The <literal>instance</literal> keyword is optional. - </para> +In an <literal>instance</literal> declaration for the class, if no explicit +<literal>type instance</literal> declaration is given for the associated type, the default declaration +is used instead, just as with default class methods. +</para> <para> -There can also be multiple defaults for a single type, as long as they do not -overlap: +Note the following points: +<itemizedlist> +<listitem><para> + The <literal>instance</literal> keyword is optional. +</para></listitem> +<listitem><para> + There can be at most one default declaration for an associated type synonym. +</para></listitem> +<listitem><para> + A default declaration is not permitted for an associated + <emphasis>data</emphasis> type. +</para></listitem> +<listitem><para> + The default declaration must mention only type <emphasis>variables</emphasis> on the left hand side, + and the right hand side must mention only type varaibels bound on the left hand side. + However, unlike the associated type family declaration itself, + the type variables of the default instance are independent of those of the parent class. +</para></listitem> +</itemizedlist> +Here are some examples: <programlisting> -class C a where - type F a b - type F a Int = Bool - type F a Bool = Int + class C a where + type F1 a :: * + type instance F1 a = [a] -- OK + type instance F1 a = a->a -- BAD; only one default instance is allowed + + type F2 b a -- OK; note the family has more type + -- variables than the class + type instance F2 c d = c->d -- OK; you don't have to use 'a' in the type instance + + type F3 a + type F3 [b] = b -- BAD; only type variables allowed on the LHS + + type F4 a + type F4 b = a -- BAD; 'a' is not in scope in the RHS </programlisting> +</para> -A default declaration is not permitted for an associated -<emphasis>data</emphasis> type. - </para> - </sect3> +</sect3> <sect3 id="scoping-class-params"> <title>Scoping of class parameters</title> @@ -8120,7 +8213,7 @@ scope over the methods defined in the <literal>where</literal> part. For exampl of the Haskell Report) can be completely switched off by <option>-XNoMonomorphismRestriction</option>. Since GHC 7.8.1, the monomorphism -restriction is switched off by default in GHCi. +restriction is switched off by default in GHCi's interactive options (see <xref linkend="ghci-interactive-options"/>). </para> </sect3> @@ -10711,6 +10804,23 @@ data T = T {-# NOUNPACK #-} !(Int,Int) </para> </sect2> +<sect2 id="overlap-pragma"> +<title>OVERLAPPING, OVERLAPPABLE, OVERLAPS, and INCOHERENT pragmas</title> +<para> +The pragmas + <literal>OVERLAPPING</literal>, + <literal>OVERLAPPABLE</literal>, + <literal>OVERLAPS</literal>, + <literal>INCOHERENT</literal> are used to specify the overlap +behavior for individual instances, as described in Section +<xref linkend="instance-overlap"/>. The pragmas are written immediately +after the <literal>instance</literal> keyword, like this: +</para> +<programlisting> +instance {-# OVERLAPPING #-} C t where ... +</programlisting> +</sect2> + </sect1> <!-- ======================= REWRITE RULES ======================== --> diff --git a/docs/users_guide/packages.xml b/docs/users_guide/packages.xml index 3f2dd97aa5..ee29cb1c2f 100644 --- a/docs/users_guide/packages.xml +++ b/docs/users_guide/packages.xml @@ -88,7 +88,11 @@ $ ghc-pkg list to expose a hidden package or hide an exposed one. Only modules from exposed packages may be imported by your Haskell code; if you try to import a module from a hidden package, GHC will emit - an error message. + an error message. If there are a multiple exposed versions of a package, + GHC will prefer the latest one. Additionally, some packages may be + broken: that is, they are missing from the package database, or one of + their dependencies are broken; in this case; these packages are excluded + from the default set of packages. </para> <para> @@ -137,8 +141,11 @@ exposed-modules: Network.BSD, (e.g. <literal>network-1.0</literal>) or the version number can be omitted if there is only one version of the package installed. If there are multiple versions - of <replaceable>P</replaceable> installed, then all other - versions will become hidden.</para> + of <replaceable>P</replaceable> installed and + <option>-hide-all-packages</option> was not specified, then all + other versions will become hidden. <option>-package</option> + supports thinning and renaming described in <xref + linkend="package-thinning-and-renaming" />.</para> <para>The <option>-package <replaceable>P</replaceable></option> option also causes package <replaceable>P</replaceable> to @@ -183,10 +190,12 @@ exposed-modules: Network.BSD, <listitem> <para> Exposes a package like <option>-package</option>, but the - package is named by its ID rather than by name. This is a + package is named by its installed package ID rather than by name. This is a more robust way to name packages, and can be used to select packages that would otherwise be shadowed. Cabal passes <option>-package-id</option> flags to GHC. + <option>-package-id</option> supports thinning and renaming + described in <xref linkend="package-thinning-and-renaming" />. </para> </listitem> </varlistentry> @@ -258,19 +267,15 @@ exposed-modules: Network.BSD, </varlistentry> <varlistentry> - <term><option>-package-name</option> <replaceable>foo</replaceable> - <indexterm><primary><option>-package-name</option></primary> + <term><option>-this-package-key</option> <replaceable>foo</replaceable> + <indexterm><primary><option>-this-package-key</option></primary> </indexterm></term> <listitem> <para>Tells GHC the the module being compiled forms part of - package <replaceable>foo</replaceable>. + package key <replaceable>foo</replaceable>; internally, these + keys are used to determine type equality and linker symbols. If this flag is omitted (a very common case) then the default package <literal>main</literal> is assumed.</para> - <para>Note: the argument to <option>-package-name</option> - should be the full - package <literal>name-version</literal> for the package. - For example: - <literal>-package mypkg-1.2</literal>.</para> </listitem> </varlistentry> @@ -328,7 +333,7 @@ exposed-modules: Network.BSD, <para>Every complete Haskell program must define <literal>main</literal> in module <literal>Main</literal> - in package <literal>main</literal>. (Omitting the <option>-package-name</option> flag compiles + in package <literal>main</literal>. (Omitting the <option>-this-package-key</option> flag compiles code for package <literal>main</literal>.) Failure to do so leads to a somewhat obscure link-time error of the form: <programlisting> @@ -367,6 +372,52 @@ _ZCMain_main_closure name.</para> </sect2> + <sect2 id="package-thinning-and-renaming"> + <title>Thinning and renaming modules</title> + + <para>When incorporating packages from multiple sources, you may end up + in a situation where multiple packages publish modules with the same name. + Previously, the only way to distinguish between these modules was to + use <xref linkend="package-qualified-imports" />. However, since GHC 7.10, + the <option>-package</option> flags (and their variants) have been extended + to allow a user to explicitly control what modules a package brings into + scope, by analogy to the import lists that users can attach to module imports. + </para> + + <para> + The basic syntax is that instead of specifying a package name P to the package + flag <literal>-package</literal>, instead we specify both a package name and a + parenthesized, comma-separated list of module names to import. For example, + <literal>-package "base (Data.List, Data.Bool)"</literal> makes only + <literal>Data.List</literal> and <literal>Data.Bool</literal> visible from + package <literal>base</literal>. + We also support renaming of modules, in case you need to refer to both modules + simultaneously; this is supporting by writing <literal>OldModName as + NewModName</literal>, e.g. <literal>-package "base (Data.Bool as + Bool)</literal>. It's important to specify quotes + so that your shell passes the package name and thinning/renaming list as a + single argument to GHC.</para> + + <para>Package imports with thinning/renaming do not hide other versions of the + package: e.g. if containers-0.9 is already exposed, <literal>-package + "containers-0.8 (Data.List as ListV8)"</literal> will only add an additional + binding to the environment. Similarly, <literal>-package "base (Data.Bool as + Bool)" -package "base (Data.List as List)"</literal> is equivalent to + <literal>-package "base (Data.Bool as Bool, Data.List as List)"</literal>. + Literal names must refer to modules defined by the original package, so for + example <literal>-package "base (Data.Bool as Bool, Bool as Baz)"</literal> is + invalid unless there was a <literal>Bool</literal> module defined in the + original package. Hiding a package also clears all of its renamings. </para> + + <para> + You can use renaming to provide an alternate prelude, e.g. + <literal>-hide-all-packages -package "basic-prelude (BasicPrelude as + Prelude)"</literal>, in lieu of the <xref + linkend="rebindable-syntax">NoImplicitPrelude</xref> extension. + </para> + + </sect2> + <sect2 id="package-databases"> <title>Package Databases</title> @@ -528,12 +579,11 @@ _ZCMain_main_closure </sect2> <sect2 id="package-ids"> - <title>Package IDs, dependencies, and broken packages</title> + <title>Installed package IDs, dependencies, and broken packages</title> <para>Each installed package has a unique identifier (the - “installed package ID”, or just “package - ID” for short) , which distinguishes it from all other - installed packages on the system. To see the package IDs + “installed package ID”), which distinguishes it from all other + installed packages on the system. To see the installed package IDs associated with each installed package, use <literal>ghc-pkg list -v</literal>:</para> @@ -549,10 +599,10 @@ using cache: /usr/lib/ghc-6.12.1/package.conf.d/package.cache </screen> <para> - The string in parentheses after the package name is the package + The string in parentheses after the package name is the installed package ID: it normally begins with the package name and version, and ends in a hash string derived from the compiled package. - Dependencies between packages are expressed in terms of package + Dependencies between packages are expressed in terms of installed package IDs, rather than just packages and versions. For example, take a look at the dependencies of the <literal>haskell98</literal> package: @@ -570,14 +620,14 @@ depends: array-0.2.0.1-9cbf76a576b6ee9c1f880cf171a0928d </screen> <para> - The purpose of the package ID is to detect problems caused by + The purpose of the installed package ID is to detect problems caused by re-installing a package without also recompiling the packages that depend on it. Recompiling dependencies is necessary, because the newly compiled package may have a different ABI (Application Binary Interface) than the previous version, even if both packages were built from the same source code using the - same compiler. With package IDs, a recompiled - package will have a different package ID from the previous + same compiler. With installed package IDs, a recompiled + package will have a different installed package ID from the previous version, so packages that depended on the previous version are now orphaned - one of their dependencies is not satisfied. Packages that are broken in this way are shown in @@ -691,7 +741,9 @@ haskell98-1.0.1.0 package; the specified action will be applied to all the matching packages. A package specifier that matches all version of the package can also be written <replaceable>pkg</replaceable><literal>-*</literal>, - to make it clearer that multiple packages are being matched.</para> + to make it clearer that multiple packages are being matched. To match + against the installed package ID instead of just package name and version, + pass the <option>--ipid</option> flag.</para> <variablelist> <varlistentry> @@ -1047,8 +1099,25 @@ ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf <para>Output the <literal>ghc-pkg</literal> version number.</para> </listitem> </varlistentry> - </variablelist> + <varlistentry> + <term> + <option>--ipid</option> + <indexterm><primary> + <option>--ipid</option> + </primary></indexterm> + </term> + <listitem> + <para>Causes <literal>ghc-pkg</literal> to interpret arguments + as installed package IDs (e.g., an identifier like + <literal>unix-2.3.1.0-de7803f1a8cd88d2161b29b083c94240 + </literal>). This is useful if providing just the package + name and version are ambiguous (in old versions of GHC, this + was guaranteed to be unique, but this invariant no longer + necessarily holds).</para> + </listitem> + </varlistentry> + </variablelist> </sect2> <sect2 id="building-packages"> @@ -1152,8 +1221,8 @@ ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf </itemizedlist> <para>To compile a module which is to be part of a new package, - use the <literal>-package-name</literal> option (<xref linkend="using-packages"/>). - Failure to use the <literal>-package-name</literal> option + use the <literal>-this-package-key</literal> option (<xref linkend="using-packages"/>). + Failure to use the <literal>-this-package-key</literal> option when compiling a package will probably result in disaster, but you will only discover later when you attempt to import modules from the package. At this point GHC will complain that the @@ -1288,7 +1357,7 @@ haddock-html: /usr/share/doc/ghc/html/libraries/unix <indexterm><primary><literal>id</literal></primary><secondary>package specification</secondary></indexterm> </term> <listitem> - <para>The package ID. It is up to you to choose a suitable + <para>The installed package ID. It is up to you to choose a suitable one.</para> </listitem> </varlistentry> @@ -1447,6 +1516,25 @@ haddock-html: /usr/share/doc/ghc/html/libraries/unix <varlistentry> <term> + <literal>reexported-modules</literal> + <indexterm><primary><literal>reexported-modules</literal></primary><secondary>reexport specification</secondary></indexterm> + </term> + <listitem> + <para>Modules reexported by this package. This list takes + the form of <literal>pkg:OldName as NewName + (A@orig-pkg-0.1-HASH)</literal>: the first portion of the + string is the user-written reexport specification (possibly + omitting the package qualifier and the renaming), while the + parenthetical is the original package which exposed the + module under are particular name. Reexported modules have + a relaxed overlap constraint: it's permissible for two + packages to reexport the same module as the same name if the + reexported moduleis identical.</para> + </listitem> + </varlistentry> + + <varlistentry> + <term> <literal>trusted</literal> <indexterm><primary><literal>trusted</literal></primary><secondary>package specification</secondary></indexterm> </term> diff --git a/docs/vh/Makefile b/docs/vh/Makefile deleted file mode 100644 index 4410e4953d..0000000000 --- a/docs/vh/Makefile +++ /dev/null @@ -1,7 +0,0 @@ -TOP = ../.. -include $(TOP)/mk/boilerplate.mk - -XML_DOC = vh -INSTALL_XML_DOC = vh - -include $(TOP)/mk/target.mk diff --git a/docs/vh/vh.xml b/docs/vh/vh.xml deleted file mode 100644 index 5c25e3109c..0000000000 --- a/docs/vh/vh.xml +++ /dev/null @@ -1,312 +0,0 @@ -<?xml version="1.0" encoding="iso-8859-1"?> -<!DOCTYPE article PUBLIC "-//OASIS//DTD DocBook XML V4.5//EN" - "http://www.oasis-open.org/docbook/xml/4.5/docbookx.dtd" [ -]> -<article id="visual-haskell"> - - <articleinfo> - - <title>Visual Haskell User's Guide</title> - <author> - <firstname>Simon</firstname> - <surname>Marlow</surname> - <email>simonmar@microsoft.com</email> - </author> - <author> - <firstname>Krasimir</firstname> - <surname>Angelov</surname> - <email>kr.angelov@gmail.com</email> - </author> - - </articleinfo> - - <section id="sec-introduction"> - <title>Introduction</title> - - <para>Visual Haskell is a plugin for Microsoft's Visual Studio - development environment to support development of Haskell software. - Like the other Visual languages, Visual Haskell integrates with the - Visual Studio editor to provide interactive features to aid Haskell - development, and it enables the construction of projects consisting of - multiple Haskell modules.</para> - - <section id="sec-obtaining"> - <title>Installing Visual Haskell</title> - - <para>In order to use Visual Haskell, you need <ulink url="http://msdn.microsoft.com/vstudio/productinfo/">Visual Studio .NET - 2003</ulink>. Right now, this is the only supported version of Visual - Studio - unfortunately we haven't yet added support for the 2005 - Beta. The Express languages (Visual C++ Express etc.) also will not - work, because they don't have support for plugins.</para> - - <para>You don't need to install GHC separately: Visual Haskell - is bundled with a complete GHC distribution, and various other tools - (Happy, Alex, Haddock).</para> - - <para>The latest Visual Haskell installer can be obtained from - here:</para> - - <para><ulink - url="http://www.haskell.org/visualhaskell/"><literal>http://www.haskell.org/visualhaskell/</literal></ulink></para> - </section> - - <section id="release-notes"> - <title>Release Notes</title> - - <section> - <title>Version 0.0, first release</title> - - <para>This release is a technology preview, and should be considered - alpha quality. It works for us, but you are fairly likely to - encounter problems. If you're willing to try it out and report - bugs, we'd be grateful for the feedback.</para> - - <itemizedlist> - <listitem> - <para>This release of Visual Haskell is bundled with a - development snapshot of GHC, version 6.5 from around 14 - September 2005. This version of GHC is used to provide the - interactive editing features, and will be used to compile all - code inside Visual Haskell. It is possible that in future - releases we may be able to relax this tight coupling between - Visual Haskell and the bundled GHC.</para> - - <para>Please note that future releases of Visual - Haskell will update the compiler, and hence the - packages, and so may break your code. Also note that because - the bundled GHC is not a released version, it may have bugs and - quirks itself: please report them as usual to - <email>glasgow-haskell-bugs@haskell.org</email>.</para> - </listitem> - - <listitem> - <para>We're not making source code for the plugin generally - available at this time, due to licensing restrictions on the - Visual Studio APIs that the plugin uses (for more - information see <ulink - url="http://msdn.microsoft.com/vstudio/extend/">Visual Studio - Extensibility Center</ulink>). If you're interested in - contributing to Visual Haskell, please get in touch with the - authors.</para> - </listitem> - </itemizedlist> - </section> - </section> - - <section id="sec-bugs"> - <title>Getting support, reporting bugs</title> - <para>Please report bugs to - <email>glasgow-haskell-bugs@haskell.org</email> (subscribe <ulink url="http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs">here</ulink>), clearly indicating - that your bug report relates to Visual Haskell, and giving as much - information as possible so that we can reproduce the bug. Even if - you can't reproduce the bug reliably, it is still useful to report - what you've seen.</para> - - <para>For help and support, use the - <email>glasgow-haskell-users@haskell.org</email> (subscribe <ulink - url="http://www.haskell.org/mailman/listinfo/glasgow-haskell-users">here</ulink>) mailing list.</para> - </section> - - <section id="sec-license"> - <title>License</title> - - <blockquote> - <para>Copyright © Microsoft Corporation. All rights reserved.</para> - <para>Copyright © The University of Glasgow. All rights reserved.</para> - <para>Copyright © Krasimir Angelov. All rights reserved.</para> - - <para>Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met:</para> - - <itemizedlist> - <listitem> - <para>Redistributions of source code must retain the above - copyright notice, this list of conditions and the following - disclaimer.</para> - </listitem> - - <listitem> - <para>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.</para> - </listitem> - - <listitem> - <para>The names of the copyright holders may not be used to endorse - or promote products derived from this software without specific - prior written permission.</para> - </listitem> - </itemizedlist> - - <para>THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS - "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 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.</para> - </blockquote> - </section> - - </section> - - <section id="sec-using"> - <title>Using Visual Haskell</title> - - <section> - <title>Overview of features</title> - - <para>The following features are provided in the Visual Studio editor - when editing Haskell code:</para> - - <itemizedlist> - <listitem> - <para>Automatic checking of code as you type, and visual indication - of parse errors, scoping errors and type errors.</para> - </listitem> - - <listitem> - <para>Quick info: hovering the mouse over an identifier pops up - an information box, including the type of the identifier.</para> - </listitem> - - <listitem> - <para>A drop-down bar at the top of the editing window lists the - top-level declarations in the module, and allows quick navigation - to a declaration.</para> - </listitem> - - <listitem> - <para>Name completion for identifiers in scope: press Ctrl+Space - after a partial identifier to see the completions.</para> - </listitem> - - <listitem> - <para>Go to declaration: right clicking on an identifier and - selecting "Go to declaration" will jump the cursor to the - declaration of the identifier. This works for locally-defined - identifiers and those defined in another module of the project; it - does not work for library functions currently.</para> - </listitem> - </itemizedlist> - - <para>The following features are provided by the project system for - constructing Haskell projects:</para> - - <itemizedlist> - <listitem> - <para>Multi-module Haskell projects are fully supported, based on the - <ulink url="http://www.haskell.org/cabal">Cabal</ulink> - infrastructure. A project in Visual Haskell <emphasis>is</emphasis> - a Cabal package, and vice-versa. A Visual Studio project can be - taken to a machine without Visual Haskell and built/installed as a - normal Cabal package, and an existing Cabal package can be edited - directly in Visual Haskell<footnote><para>This works as long as the - Cabal package is using Cabal's simple build system; Cabal - packages using their own build systems cannot be edited in Visual - Haskell.</para> - </footnote>.</para> - </listitem> - - <listitem> - <para>Editing of most of the package meta-data is supported through - the project property pages.</para> - </listitem> - - <listitem> - <para>The interactive editing features work across multiple modules in - a project. When one module is edited, changes are automatically - propagated to dependent modules, even if the edited module has not yet - been saved.</para> - </listitem> - - <listitem> - <para>Building is supported through the Cabal build system, and build - errors are communicated back to the editor and placed in the task - list. Use any of the Visual Studio build commands (e.g. Build - Project from the context menu on the project, or Ctrl-Shift-B to - build the whole solution).</para> - </listitem> - - </itemizedlist> - - <para>Additionally, Visual Haskell is bundled with a large collection of - documentation: the GHC manual, the hierarchical libraries reference, and - other material all of which can be browsed within Visual Studio - itself.</para> - </section> - - <section> - <title>Getting Started</title> - - <para>After installing Visual Haskell, start up Visual Studio as you - would normally, and observe that on the splash screen where it lists - the supported languages you should now see an icon for Visual - Haskell (if you don't see this, something has gone wrong... please let - us know).</para> - - <para>Firstly, take a look at the bundled documentation. Go to - Help->Contents, and you should see the “Visual Haskell Help - Collection”, which contains a large collection of GHC and - Haskell-related documentaiton, including this document.</para> - - <para>To start using Visual Haskell right away, create a new - project (File->New->Project...). Select one of the Haskell - project types (Console Application or Library Package), and hit Ok. - The project will be created for you, and an example module - added: <literal>Main.hs</literal> for an application, or - <literal>Module1.hs</literal> for a library.</para> - - <para>You can now start adding code to - <literal>Main.hs</literal>, or adding new modules. To add a new - module, right-click on the <literal>src</literal> directory, and - select Add->New Item. Visual Haskell supports hierarchical - modules too: you can add new folders using the same Add menu to - create new nodes in the hierarchy.</para> - - <para>If you have any errors in your code, they will be underlined with - a red squiggly line. Select the Tasks window (usually a tab near the - bottom of the Visual Studio window) to see the error messages, and - click on an error message to jump to it in the editor.</para> - - <para>To build the program, hit Ctrl-Shift-B, or select one of the - options from the Build menu.</para> - </section> - - <section> - <title>Editing Haskell code</title> - - <para>(ToDo: more detail here)</para> - - <para>Your module must be plain Haskell (<literal>.hs</literal>) for - the interactive features to fully work. If your module is - pre-processed with CPP or Literate Haskell, then Visual Haskell will - only check the module when it is saved; between saves the source will - not be checked for errors and the type information will not be - updated. If the source file is - pre-processed with Happy or another pre-processor, then you may have - to build the project before the type information will be updated - (because the pre-processor is only run as part of the build process). - Pre-processed source files work fine in a multi-module setting; you - can have modules which depend on a pre-processed module and full - interactive checking will still be available in those modules.</para> - - <para>Because Visual Haskell is using GHC as a backend for its - interactive editing features, it supports the full GHC language, - including all extensions.</para> - </section> - - <section> - <title>Using Projects</title> - <para>(ToDo: more detail here)</para> - </section> - - </section> -</article> diff --git a/driver/ghc-usage.txt b/driver/ghc-usage.txt index 9de4090bc4..0b56db7419 100644 --- a/driver/ghc-usage.txt +++ b/driver/ghc-usage.txt @@ -73,7 +73,7 @@ Given the above, here are some TYPICAL invocations of $$: The User's Guide has more information about GHC's *many* options. An online copy can be found here: - http://haskell.org/haskellwiki/GHC + http://www.haskell.org/ghc/docs/latest/html/users_guide/ If you *really* want to see every option, then you can pass '--show-options' to the compiler. diff --git a/driver/ghci-usage.txt b/driver/ghci-usage.txt index d9628b2c41..1a848fc9b5 100644 --- a/driver/ghci-usage.txt +++ b/driver/ghci-usage.txt @@ -21,4 +21,4 @@ GHC does. Some of the options that are commonly used are: Full details can be found in the User's Guide, an online copy of which can be found here: - http://haskell.org/haskellwiki/GHC + http://www.haskell.org/ghc/docs/latest/html/users_guide/ diff --git a/driver/ghci/ghc.mk b/driver/ghci/ghc.mk index 4c5c09e761..ba6984c37a 100644 --- a/driver/ghci/ghc.mk +++ b/driver/ghci/ghc.mk @@ -22,7 +22,7 @@ install_driver_ghci: $(call removeFiles, "$(WRAPPER)") $(CREATE_SCRIPT) "$(WRAPPER)" echo '#!$(SHELL)' >> "$(WRAPPER)" - echo 'exec "$(bindir)/ghc-$(ProjectVersion)" --interactive $${1+"$$@"}' >> "$(WRAPPER)" + echo 'exec "$(bindir)/ghc-$(ProjectVersion)" --interactive "$$@"' >> "$(WRAPPER)" $(EXECUTABLE_FILE) "$(WRAPPER)" $(call removeFiles,"$(DESTDIR)$(bindir)/ghci") $(LN_S) ghci-$(ProjectVersion) "$(DESTDIR)$(bindir)/ghci" @@ -57,7 +57,7 @@ install_driver_ghcii: $(call INSTALL_DIR,$(DESTDIR)$(bindir)) $(call removeFiles,"$(GHCII_SCRIPT)") echo "#!$(SHELL)" >> $(GHCII_SCRIPT) - echo 'exec "$$0"/../ghc --interactive $${1+"$$@"}' >> $(GHCII_SCRIPT) + echo 'exec "$$(dirname "$$0")"/ghc --interactive "$$@"' >> $(GHCII_SCRIPT) $(EXECUTABLE_FILE) $(GHCII_SCRIPT) cp $(GHCII_SCRIPT) $(GHCII_SCRIPT_VERSIONED) $(EXECUTABLE_FILE) $(GHCII_SCRIPT_VERSIONED) @@ -452,9 +452,17 @@ ifneq "$(CrossCompiling)" "YES" define addExtraPackage ifeq "$2" "-" # Do nothing; this package is already handled above -else ifeq "$2 $$(GhcProfiled)" "dph YES" -# Ignore the package: These packages need TH, which is incompatible -# with a profiled GHC +else ifeq "$2" "dph" +## DPH-specific clause +ifeq "$$(GhcProfiled)" "YES" +# Ignore package: The DPH packages need TH, which is incompatible with +# a profiled GHC +else ifneq "$$(BUILD_DPH)" "YES" +# Ignore package: DPH was disabled +else +PACKAGES_STAGE2 += $1 +endif +## end of DPH-specific clause else PACKAGES_STAGE2 += $1 endif @@ -635,8 +643,10 @@ ifneq "$(CLEANING)" "YES" BUILD_DIRS += $(patsubst %, libraries/%, $(PACKAGES_STAGE2)) BUILD_DIRS += $(patsubst %, libraries/%, $(PACKAGES_STAGE1)) BUILD_DIRS += $(patsubst %, libraries/%, $(filter-out $(PACKAGES_STAGE1),$(PACKAGES_STAGE0))) +ifeq "$(BUILD_DPH)" "YES" BUILD_DIRS += $(wildcard libraries/dph) endif +endif ifeq "$(INTEGER_LIBRARY)" "integer-gmp" @@ -901,10 +911,10 @@ install_packages: rts/dist/package.conf.install $(call INSTALL_DIR,"$(DESTDIR)$(topdir)") $(call removeTrees,"$(INSTALLED_PACKAGE_CONF)") $(call INSTALL_DIR,"$(INSTALLED_PACKAGE_CONF)") - $(call INSTALL_DIR,"$(DESTDIR)$(topdir)/rts-1.0") - $(call installLibsTo, $(RTS_INSTALL_LIBS), "$(DESTDIR)$(topdir)/rts-1.0") + $(call INSTALL_DIR,"$(DESTDIR)$(topdir)/rts") + $(call installLibsTo, $(RTS_INSTALL_LIBS), "$(DESTDIR)$(topdir)/rts") $(foreach p, $(INSTALL_DYNLIBS), \ - $(call installLibsTo, $(wildcard $p/dist-install/build/*.so $p/dist-install/build/*.dll $p/dist-install/build/*.dylib), "$(DESTDIR)$(topdir)/$($p_PACKAGE)-$($p_dist-install_VERSION)")) + $(call installLibsTo, $(wildcard $p/dist-install/build/*.so $p/dist-install/build/*.dll $p/dist-install/build/*.dylib), "$(DESTDIR)$(topdir)/$($p_dist-install_PACKAGE_KEY)")) $(foreach p, $(INSTALL_PACKAGES), \ $(call make-command, \ "$(ghc-cabal_INPLACE)" copy \ @@ -1225,7 +1235,8 @@ clean_files : $(call removeFiles,$(CLEAN_FILES)) # this is here since CLEAN_FILES can't handle folders $(call removeTrees,includes/dist-derivedconstants) - $(call removeTrees,inplace) + $(call removeTrees,inplace/bin) + $(call removeTrees,inplace/lib) .PHONY: clean_libraries clean_libraries: $(patsubst %,clean_libraries/%_dist-install,$(PACKAGES_STAGE1) $(PACKAGES_STAGE2)) diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 0a56799679..3d871d9d1d 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -39,14 +39,13 @@ import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, setInteractivePrintName ) import Module import Name -import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap ) +import Packages ( trusted, getPackageDetails, listVisibleModuleNames, pprFlag ) import PprTyThing import RdrName ( getGRE_NameQualifier_maybes ) import SrcLoc import qualified Lexer import StringBuffer -import UniqFM ( eltsUFM ) import Outputable hiding ( printForUser, printForUserPartWay, bold ) -- Other random utilities @@ -586,8 +585,9 @@ nextInputLine show_prompt is_tty fileLoop stdin -- NOTE: We only read .ghci files if they are owned by the current user, --- and aren't world writable. Otherwise, we could be accidentally --- running code planted by a malicious third party. +-- and aren't world writable (files owned by root are ok, see #9324). +-- Otherwise, we could be accidentally running code planted by +-- a malicious third party. -- Furthermore, We only read ./.ghci if . is owned by the current user -- and isn't writable by anyone else. I think this is sufficient: we @@ -602,18 +602,14 @@ checkPerms name = handleIO (\_ -> return False) $ do st <- getFileStatus name me <- getRealUserID - if fileOwner st /= me then do - putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!" - return False - else do - let mode = System.Posix.fileMode st - if (groupWriteMode == (mode `intersectFileModes` groupWriteMode)) - || (otherWriteMode == (mode `intersectFileModes` otherWriteMode)) - then do - putStrLn $ "*** WARNING: " ++ name ++ - " is writable by someone else, IGNORING!" - return False - else return True + let mode = System.Posix.fileMode st + ok = (fileOwner st == me || fileOwner st == 0) && + groupWriteMode /= mode `intersectFileModes` groupWriteMode && + otherWriteMode /= mode `intersectFileModes` otherWriteMode + unless ok $ + putStrLn $ "*** WARNING: " ++ name ++ + " is writable by someone else, IGNORING!" + return ok #endif incrementLineNo :: InputT GHCi () @@ -1141,9 +1137,10 @@ runMain s = case toArgs s of Left err -> liftIO (hPutStrLn stderr err) Right args -> do dflags <- getDynFlags - case mainFunIs dflags of - Nothing -> doWithArgs args "main" - Just f -> doWithArgs args f + let main = fromMaybe "main" (mainFunIs dflags) + -- Wrap the main function in 'void' to discard its value instead + -- of printing it (#9086). See Haskell 2010 report Chapter 5. + doWithArgs args $ "Control.Monad.void (" ++ main ++ ")" ----------------------------------------------------------------------------- -- :run @@ -1606,26 +1603,25 @@ isSafeModule m = do liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off") when (not $ null good) (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++ - (intercalate ", " $ map packageIdString good)) + (intercalate ", " $ map (showPpr dflags) good)) case msafe && null bad of True -> liftIO $ putStrLn $ mname ++ " is trusted!" False -> do when (not $ null bad) (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): " - ++ (intercalate ", " $ map packageIdString bad)) + ++ (intercalate ", " $ map (showPpr dflags) bad)) liftIO $ putStrLn $ mname ++ " is NOT trusted!" where mname = GHC.moduleNameString $ GHC.moduleName m packageTrusted dflags md - | thisPackage dflags == modulePackageId md = True - | otherwise = trusted $ getPackageDetails (pkgState dflags) (modulePackageId md) + | thisPackage dflags == modulePackageKey md = True + | otherwise = trusted $ getPackageDetails dflags (modulePackageKey md) tallyPkgs dflags deps | not (packageTrustOn dflags) = ([], []) | otherwise = partition part deps - where state = pkgState dflags - part pkg = trusted $ getPackageDetails state pkg + where part pkg = trusted $ getPackageDetails dflags pkg ----------------------------------------------------------------------------- -- :browse @@ -2335,15 +2331,9 @@ showPackages :: GHCi () showPackages = do dflags <- getDynFlags let pkg_flags = packageFlags dflags - liftIO $ putStrLn $ showSDoc dflags $ vcat $ - text ("active package flags:"++if null pkg_flags then " none" else "") - : map showFlag pkg_flags - where showFlag (ExposePackage p) = text $ " -package " ++ p - showFlag (HidePackage p) = text $ " -hide-package " ++ p - showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p - showFlag (ExposePackageId p) = text $ " -package-id " ++ p - showFlag (TrustPackage p) = text $ " -trust " ++ p - showFlag (DistrustPackage p) = text $ " -distrust " ++ p + liftIO $ putStrLn $ showSDoc dflags $ + text ("active package flags:"++if null pkg_flags then " none" else "") $$ + nest 2 (vcat (map pprFlag pkg_flags)) showPaths :: GHCi () showPaths = do @@ -2478,7 +2468,7 @@ completeIdentifier = wrapIdentCompleter $ \w -> do completeModule = wrapIdentCompleter $ \w -> do dflags <- GHC.getSessionDynFlags - let pkg_mods = allExposedModules dflags + let pkg_mods = allVisibleModules dflags loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules return $ filter (w `isPrefixOf`) $ map (showPpr dflags) $ loaded_mods ++ pkg_mods @@ -2490,7 +2480,7 @@ completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do imports <- GHC.getContext return $ map iiModuleName imports _ -> do - let pkg_mods = allExposedModules dflags + let pkg_mods = allVisibleModules dflags loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules return $ loaded_mods ++ pkg_mods return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules @@ -2535,22 +2525,21 @@ unionComplete f1 f2 line = do wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi wrapCompleter breakChars fun = completeWord Nothing breakChars - $ fmap (map simpleCompletion) . fmap sort . fun + $ fmap (map simpleCompletion . nubSort) . fun wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi wrapIdentCompleter = wrapCompleter word_break_chars wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars - $ \rest -> fmap (map simpleCompletion) . fmap sort . fun (getModifier rest) + $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest) where getModifier = find (`elem` modifChars) -allExposedModules :: DynFlags -> [ModuleName] -allExposedModules dflags - = concat (map exposedModules (filter exposed (eltsUFM pkg_db))) - where - pkg_db = pkgIdMap (pkgState dflags) +-- | Return a list of visible module names for autocompletion. +-- (NB: exposed != visible) +allVisibleModules :: DynFlags -> [ModuleName] +allVisibleModules dflags = listVisibleModuleNames dflags completeExpression = completeQuotedWord (Just '\\') "\"" listFiles completeIdentifier @@ -3133,7 +3122,7 @@ lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module lookupModuleName mName = GHC.lookupModule mName Nothing isHomeModule :: Module -> Bool -isHomeModule m = GHC.modulePackageId m == mainPackageId +isHomeModule m = GHC.modulePackageKey m == mainPackageKey -- TODO: won't work if home dir is encoded. -- (changeDirectory may not work either in that case.) @@ -3163,7 +3152,7 @@ wantInterpretedModuleName modname = do modl <- lookupModuleName modname let str = moduleNameString modname dflags <- getDynFlags - when (GHC.modulePackageId modl /= thisPackage dflags) $ + when (GHC.modulePackageKey modl /= thisPackage dflags) $ throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) is_interpreted <- GHC.moduleIsInterpreted modl when (not is_interpreted) $ diff --git a/ghc/Main.hs b/ghc/Main.hs index 2bb156c5b9..70dde39824 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -33,7 +33,7 @@ import InteractiveUI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings ) import Config import Constants import HscTypes -import Packages ( dumpPackages, simpleDumpPackages ) +import Packages ( dumpPackages, simpleDumpPackages, pprModuleMap ) import DriverPhases import BasicTypes ( failed ) import StaticFlags @@ -217,6 +217,11 @@ main' postLoadMode dflags0 args flagWarnings = do when (verbosity dflags6 >= 3) $ do liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) + + when (dopt Opt_D_dump_mod_map dflags6) . liftIO $ + printInfoForUser (dflags6 { pprCols = 200 }) + (pkgQual dflags6) (pprModuleMap dflags6) + ---------------- Final sanity checking ----------- liftIO $ checkOptions postLoadMode dflags6 srcs objs diff --git a/includes/rts/Constants.h b/includes/rts/Constants.h index 842c37b369..6fd0dc0dfc 100644 --- a/includes/rts/Constants.h +++ b/includes/rts/Constants.h @@ -202,32 +202,34 @@ */ #define NotBlocked 0 #define BlockedOnMVar 1 -#define BlockedOnMVarRead 2 -#define BlockedOnBlackHole 3 -#define BlockedOnRead 4 -#define BlockedOnWrite 5 -#define BlockedOnDelay 6 -#define BlockedOnSTM 7 +#define BlockedOnMVarRead 14 /* TODO: renumber me, see #9003 */ +#define BlockedOnBlackHole 2 +#define BlockedOnRead 3 +#define BlockedOnWrite 4 +#define BlockedOnDelay 5 +#define BlockedOnSTM 6 /* Win32 only: */ -#define BlockedOnDoProc 8 +#define BlockedOnDoProc 7 /* Only relevant for PAR: */ /* blocked on a remote closure represented by a Global Address: */ -#define BlockedOnGA 9 +#define BlockedOnGA 8 /* same as above but without sending a Fetch message */ -#define BlockedOnGA_NoSend 10 +#define BlockedOnGA_NoSend 9 /* Only relevant for THREADED_RTS: */ -#define BlockedOnCCall 11 -#define BlockedOnCCall_Interruptible 12 +#define BlockedOnCCall 10 +#define BlockedOnCCall_Interruptible 11 /* same as above but permit killing the worker thread */ /* Involved in a message sent to tso->msg_cap */ -#define BlockedOnMsgThrowTo 13 +#define BlockedOnMsgThrowTo 12 /* The thread is not on any run queues, but can be woken up by tryWakeupThread() */ -#define ThreadMigrating 14 +#define ThreadMigrating 13 + +/* WARNING WARNING top number is BlockedOnMVarRead 14, not 13!! */ /* * These constants are returned to the scheduler by a thread that has diff --git a/includes/rts/EventLogFormat.h b/includes/rts/EventLogFormat.h index e08a44996f..a1e038f823 100644 --- a/includes/rts/EventLogFormat.h +++ b/includes/rts/EventLogFormat.h @@ -162,6 +162,8 @@ #define EVENT_TASK_MIGRATE 56 /* (taskID, cap, new_cap) */ #define EVENT_TASK_DELETE 57 /* (taskID) */ #define EVENT_USER_MARKER 58 /* (marker_name) */ +#define EVENT_HACK_BUG_T9003 59 /* Hack: see trac #9003 */ + /* Range 59 - 59 is available for new GHC and common events. */ /* Range 60 - 80 is used by eden for parallel tracing @@ -177,7 +179,7 @@ * ranges higher than this are reserved but not currently emitted by ghc. * This must match the size of the EventDesc[] array in EventLog.c */ -#define NUM_GHC_EVENT_TAGS 59 +#define NUM_GHC_EVENT_TAGS 60 #if 0 /* DEPRECATED EVENTS: */ /* we don't actually need to record the thread, it's implicit */ diff --git a/includes/rts/SpinLock.h b/includes/rts/SpinLock.h index b6eccced8a..b54d678fa5 100644 --- a/includes/rts/SpinLock.h +++ b/includes/rts/SpinLock.h @@ -34,8 +34,6 @@ typedef struct SpinLock_ typedef StgWord SpinLock; #endif -typedef StgWord SpinLockCount; - #if defined(PROF_SPIN) // PROF_SPIN enables counting the number of times we spin on a lock diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h index 0c4d2f9eaf..ee5a119aa1 100644 --- a/includes/stg/MiscClosures.h +++ b/includes/stg/MiscClosures.h @@ -348,7 +348,6 @@ RTS_FUN_DECL(stg_newByteArrayzh); RTS_FUN_DECL(stg_newPinnedByteArrayzh); RTS_FUN_DECL(stg_newAlignedPinnedByteArrayzh); RTS_FUN_DECL(stg_casIntArrayzh); -RTS_FUN_DECL(stg_fetchAddIntArrayzh); RTS_FUN_DECL(stg_newArrayzh); RTS_FUN_DECL(stg_newArrayArrayzh); RTS_FUN_DECL(stg_copyArrayzh); diff --git a/includes/stg/SMP.h b/includes/stg/SMP.h index 01663dd86e..00608c707c 100644 --- a/includes/stg/SMP.h +++ b/includes/stg/SMP.h @@ -107,7 +107,10 @@ EXTERN_INLINE StgWord xchg(StgPtr p, StgWord w) { StgWord result; -#if i386_HOST_ARCH || x86_64_HOST_ARCH +#if defined(NOSMP) + result = *p; + *p = w; +#elif i386_HOST_ARCH || x86_64_HOST_ARCH result = w; __asm__ __volatile__ ( // NB: the xchg instruction is implicitly locked, so we do not @@ -154,9 +157,6 @@ xchg(StgPtr p, StgWord w) : "r" (w), "r" (p) : "memory" ); -#elif !defined(WITHSMP) - result = *p; - *p = w; #else #error xchg() unimplemented on this architecture #endif @@ -170,7 +170,14 @@ xchg(StgPtr p, StgWord w) EXTERN_INLINE StgWord cas(StgVolatilePtr p, StgWord o, StgWord n) { -#if i386_HOST_ARCH || x86_64_HOST_ARCH +#if defined(NOSMP) + StgWord result; + result = *p; + if (result == o) { + *p = n; + } + return result; +#elif i386_HOST_ARCH || x86_64_HOST_ARCH __asm__ __volatile__ ( "lock\ncmpxchg %3,%1" :"=a"(o), "+m" (*(volatile unsigned int *)p) @@ -225,13 +232,6 @@ cas(StgVolatilePtr p, StgWord o, StgWord n) : "cc","memory"); return result; -#elif !defined(WITHSMP) - StgWord result; - result = *p; - if (result == o) { - *p = n; - } - return result; #else #error cas() unimplemented on this architecture #endif @@ -302,7 +302,9 @@ busy_wait_nop(void) */ EXTERN_INLINE void write_barrier(void) { -#if i386_HOST_ARCH || x86_64_HOST_ARCH +#if defined(NOSMP) + return; +#elif i386_HOST_ARCH || x86_64_HOST_ARCH __asm__ __volatile__ ("" : : : "memory"); #elif powerpc_HOST_ARCH __asm__ __volatile__ ("lwsync" : : : "memory"); @@ -313,8 +315,6 @@ write_barrier(void) { __asm__ __volatile__ ("" : : : "memory"); #elif arm_HOST_ARCH && !defined(arm_HOST_ARCH_PRE_ARMv7) __asm__ __volatile__ ("dmb st" : : : "memory"); -#elif !defined(WITHSMP) - return; #else #error memory barriers unimplemented on this architecture #endif @@ -322,7 +322,9 @@ write_barrier(void) { EXTERN_INLINE void store_load_barrier(void) { -#if i386_HOST_ARCH +#if defined(NOSMP) + return; +#elif i386_HOST_ARCH __asm__ __volatile__ ("lock; addl $0,0(%%esp)" : : : "memory"); #elif x86_64_HOST_ARCH __asm__ __volatile__ ("lock; addq $0,0(%%rsp)" : : : "memory"); @@ -332,8 +334,6 @@ store_load_barrier(void) { __asm__ __volatile__ ("membar #StoreLoad" : : : "memory"); #elif arm_HOST_ARCH && !defined(arm_HOST_ARCH_PRE_ARMv7) __asm__ __volatile__ ("dmb" : : : "memory"); -#elif !defined(WITHSMP) - return; #else #error memory barriers unimplemented on this architecture #endif @@ -341,7 +341,9 @@ store_load_barrier(void) { EXTERN_INLINE void load_load_barrier(void) { -#if i386_HOST_ARCH +#if defined(NOSMP) + return; +#elif i386_HOST_ARCH __asm__ __volatile__ ("" : : : "memory"); #elif x86_64_HOST_ARCH __asm__ __volatile__ ("" : : : "memory"); @@ -352,8 +354,6 @@ load_load_barrier(void) { __asm__ __volatile__ ("" : : : "memory"); #elif arm_HOST_ARCH && !defined(arm_HOST_ARCH_PRE_ARMv7) __asm__ __volatile__ ("dmb" : : : "memory"); -#elif !defined(WITHSMP) - return; #else #error memory barriers unimplemented on this architecture #endif diff --git a/libraries/Cabal b/libraries/Cabal -Subproject 597ed8f613db327cfab958aa64da6c0f9e1ee29 +Subproject 6cc46998f0778c04b535c805416604995fe153b diff --git a/libraries/base/.gitignore b/libraries/base/.gitignore index 69a9c5124b..54bc34c8af 100644 --- a/libraries/base/.gitignore +++ b/libraries/base/.gitignore @@ -1,14 +1,7 @@ *.o *.aux *.hi -*.comp.stderr -*.comp.stdout -*.interp.stderr -*.interp.stdout -*.run.stderr -*.run.stdout -*.eventlog -*.genscript +*.tix # Backup files *~ @@ -26,242 +19,3 @@ /include/HsBaseConfig.h /include/HsBaseConfig.h.in -tests/.hpc/ -tests/4006 -tests/CPUTime001 -tests/Concurrent/.hpc/ -tests/Concurrent/4876 -tests/Concurrent/ThreadDelay001 -tests/IO/.hpc/ -tests/IO/2122 -tests/IO/2122-test -tests/IO/3307 -tests/IO/4808 -tests/IO/4808.test -tests/IO/4855 -tests/IO/4895 -tests/IO/IOError001 -tests/IO/IOError002 -tests/IO/T4144 -tests/IO/chinese-file-* -tests/IO/chinese-name -tests/IO/concio002 -tests/IO/countReaders001 -tests/IO/countReaders001.txt -tests/IO/decodingerror001 -tests/IO/decodingerror002 -tests/IO/encoding001 -tests/IO/encoding001.utf16 -tests/IO/encoding001.utf16.utf16be -tests/IO/encoding001.utf16.utf16le -tests/IO/encoding001.utf16.utf32 -tests/IO/encoding001.utf16.utf32be -tests/IO/encoding001.utf16.utf32le -tests/IO/encoding001.utf16.utf8 -tests/IO/encoding001.utf16.utf8_bom -tests/IO/encoding001.utf16be -tests/IO/encoding001.utf16be.utf16 -tests/IO/encoding001.utf16be.utf16le -tests/IO/encoding001.utf16be.utf32 -tests/IO/encoding001.utf16be.utf32be -tests/IO/encoding001.utf16be.utf32le -tests/IO/encoding001.utf16be.utf8 -tests/IO/encoding001.utf16be.utf8_bom -tests/IO/encoding001.utf16le -tests/IO/encoding001.utf16le.utf16 -tests/IO/encoding001.utf16le.utf16be -tests/IO/encoding001.utf16le.utf32 -tests/IO/encoding001.utf16le.utf32be -tests/IO/encoding001.utf16le.utf32le -tests/IO/encoding001.utf16le.utf8 -tests/IO/encoding001.utf16le.utf8_bom -tests/IO/encoding001.utf32 -tests/IO/encoding001.utf32.utf16 -tests/IO/encoding001.utf32.utf16be -tests/IO/encoding001.utf32.utf16le -tests/IO/encoding001.utf32.utf32be -tests/IO/encoding001.utf32.utf32le -tests/IO/encoding001.utf32.utf8 -tests/IO/encoding001.utf32.utf8_bom -tests/IO/encoding001.utf32be -tests/IO/encoding001.utf32be.utf16 -tests/IO/encoding001.utf32be.utf16be -tests/IO/encoding001.utf32be.utf16le -tests/IO/encoding001.utf32be.utf32 -tests/IO/encoding001.utf32be.utf32le -tests/IO/encoding001.utf32be.utf8 -tests/IO/encoding001.utf32be.utf8_bom -tests/IO/encoding001.utf32le -tests/IO/encoding001.utf32le.utf16 -tests/IO/encoding001.utf32le.utf16be -tests/IO/encoding001.utf32le.utf16le -tests/IO/encoding001.utf32le.utf32 -tests/IO/encoding001.utf32le.utf32be -tests/IO/encoding001.utf32le.utf8 -tests/IO/encoding001.utf32le.utf8_bom -tests/IO/encoding001.utf8 -tests/IO/encoding001.utf8.utf16 -tests/IO/encoding001.utf8.utf16be -tests/IO/encoding001.utf8.utf16le -tests/IO/encoding001.utf8.utf32 -tests/IO/encoding001.utf8.utf32be -tests/IO/encoding001.utf8.utf32le -tests/IO/encoding001.utf8.utf8_bom -tests/IO/encoding001.utf8_bom -tests/IO/encoding001.utf8_bom.utf16 -tests/IO/encoding001.utf8_bom.utf16be -tests/IO/encoding001.utf8_bom.utf16le -tests/IO/encoding001.utf8_bom.utf32 -tests/IO/encoding001.utf8_bom.utf32be -tests/IO/encoding001.utf8_bom.utf32le -tests/IO/encoding001.utf8_bom.utf8 -tests/IO/encoding002 -tests/IO/encodingerror001 -tests/IO/environment001 -tests/IO/finalization001 -tests/IO/hClose001 -tests/IO/hClose001.tmp -tests/IO/hClose002 -tests/IO/hClose002.tmp -tests/IO/hClose003 -tests/IO/hDuplicateTo001 -tests/IO/hFileSize001 -tests/IO/hFileSize002 -tests/IO/hFileSize002.out -tests/IO/hFlush001 -tests/IO/hFlush001.out -tests/IO/hGetBuf001 -tests/IO/hGetBuffering001 -tests/IO/hGetChar001 -tests/IO/hGetLine001 -tests/IO/hGetLine002 -tests/IO/hGetLine003 -tests/IO/hGetPosn001 -tests/IO/hGetPosn001.out -tests/IO/hIsEOF001 -tests/IO/hIsEOF002 -tests/IO/hIsEOF002.out -tests/IO/hReady001 -tests/IO/hReady002 -tests/IO/hSeek001 -tests/IO/hSeek002 -tests/IO/hSeek003 -tests/IO/hSeek004 -tests/IO/hSeek004.out -tests/IO/hSetBuffering002 -tests/IO/hSetBuffering003 -tests/IO/hSetBuffering004 -tests/IO/hSetEncoding001 -tests/IO/ioeGetErrorString001 -tests/IO/ioeGetFileName001 -tests/IO/ioeGetHandle001 -tests/IO/isEOF001 -tests/IO/misc001 -tests/IO/misc001.out -tests/IO/newline001 -tests/IO/newline001.out -tests/IO/openFile001 -tests/IO/openFile002 -tests/IO/openFile003 -tests/IO/openFile004 -tests/IO/openFile004.out -tests/IO/openFile005 -tests/IO/openFile005.out1 -tests/IO/openFile005.out2 -tests/IO/openFile006 -tests/IO/openFile006.out -tests/IO/openFile007 -tests/IO/openFile007.out -tests/IO/openFile008 -tests/IO/openTempFile001 -tests/IO/putStr001 -tests/IO/readFile001 -tests/IO/readFile001.out -tests/IO/readwrite001 -tests/IO/readwrite001.inout -tests/IO/readwrite002 -tests/IO/readwrite002.inout -tests/IO/readwrite003 -tests/IO/readwrite003.txt -tests/IO/tmp -tests/Numeric/.hpc/ -tests/Numeric/num001 -tests/Numeric/num002 -tests/Numeric/num003 -tests/Numeric/num004 -tests/Numeric/num005 -tests/Numeric/num006 -tests/Numeric/num007 -tests/Numeric/num008 -tests/Numeric/num009 -tests/Numeric/num010 -tests/System/.hpc/ -tests/System/exitWith001 -tests/System/getArgs001 -tests/System/getEnv001 -tests/System/system001 -tests/Text.Printf/.hpc/ -tests/Text.Printf/1548 -tests/addr001 -tests/assert -tests/char001 -tests/char002 -tests/cstring001 -tests/data-fixed-show-read -tests/dynamic001 -tests/dynamic002 -tests/dynamic003 -tests/dynamic004 -tests/dynamic005 -tests/echo001 -tests/enum01 -tests/enum02 -tests/enum03 -tests/enum04 -tests/enumDouble -tests/enumRatio -tests/exceptionsrun001 -tests/exceptionsrun002 -tests/fixed -tests/genericNegative001 -tests/hGetBuf002 -tests/hGetBuf003 -tests/hPutBuf001 -tests/hPutBuf002 -tests/hPutBuf002.out -tests/hTell001 -tests/hTell002 -tests/hash001 -tests/ioref001 -tests/ix001 -tests/length001 -tests/lex001 -tests/list001 -tests/list002 -tests/list003 -tests/memo001 -tests/memo002 -tests/performGC001 -tests/quotOverflow -tests/rand001 -tests/ratio001 -tests/readDouble001 -tests/readFloat -tests/readInteger001 -tests/readLitChar -tests/reads001 -tests/show001 -tests/showDouble -tests/stableptr001 -tests/stableptr003 -tests/stableptr004 -tests/stableptr005 -tests/take001 -tests/tempfiles -tests/text001 -tests/trace001 -tests/tup001 -tests/unicode001 -tests/unicode002 -tests/weak001 - diff --git a/libraries/base/Control/Applicative.hs b/libraries/base/Control/Applicative.hs index 4e77479e15..81ce513a58 100644 --- a/libraries/base/Control/Applicative.hs +++ b/libraries/base/Control/Applicative.hs @@ -54,7 +54,7 @@ import Control.Monad (liftM, ap, MonadPlus(..)) import Control.Monad.ST.Safe (ST) import qualified Control.Monad.ST.Lazy.Safe as Lazy (ST) import Data.Functor ((<$>), (<$)) -import Data.Monoid (Monoid(..)) +import Data.Monoid (Monoid(..), First(..), Last(..)) import Data.Proxy import Text.ParserCombinators.ReadP (ReadP) @@ -281,6 +281,15 @@ instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where empty = WrapArrow zeroArrow WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v) +-- Added in base-4.8.0.0 +instance Applicative First where + pure x = First (Just x) + First x <*> First y = First (x <*> y) + +instance Applicative Last where + pure x = Last (Just x) + Last x <*> Last y = Last (x <*> y) + -- | Lists, but with an 'Applicative' functor based on zipping, so that -- -- @f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsn = 'ZipList' (zipWithn f xs1 ... xsn)@ diff --git a/libraries/base/Control/Concurrent.hs b/libraries/base/Control/Concurrent.hs index c487190f27..e5a0ebfe20 100644 --- a/libraries/base/Control/Concurrent.hs +++ b/libraries/base/Control/Concurrent.hs @@ -361,8 +361,8 @@ is /bound/, an unbound thread is created temporarily using 'forkIO'. Use this function /only/ in the rare case that you have actually observed a performance loss due to the use of bound threads. A program that -doesn't need it's main thread to be bound and makes /heavy/ use of concurrency -(e.g. a web server), might want to wrap it's @main@ action in +doesn't need its main thread to be bound and makes /heavy/ use of concurrency +(e.g. a web server), might want to wrap its @main@ action in @runInUnboundThread@. Note that exceptions which are thrown to the current thread are thrown in turn diff --git a/libraries/base/Data/Data.hs b/libraries/base/Data/Data.hs index 25f2875808..49407fae16 100644 --- a/libraries/base/Data/Data.hs +++ b/libraries/base/Data/Data.hs @@ -777,12 +777,12 @@ mkCharConstr dt c = case datarep dt of ------------------------------------------------------------------------------ -- --- Non-representations for non-presentable types +-- Non-representations for non-representable types -- ------------------------------------------------------------------------------ --- | Constructs a non-representation for a non-presentable type +-- | Constructs a non-representation for a non-representable type mkNoRepType :: String -> DataType mkNoRepType str = DataType { tycon = str diff --git a/libraries/base/Data/List.hs b/libraries/base/Data/List.hs index a5e52e548e..2cd9a3b4d1 100644 --- a/libraries/base/Data/List.hs +++ b/libraries/base/Data/List.hs @@ -216,7 +216,7 @@ import GHC.Real import GHC.List import GHC.Base -infix 5 \\ -- comment to fool cpp +infix 5 \\ -- comment to fool cpp: https://www.haskell.org/ghc/docs/latest/html/users_guide/options-phases.html#cpp-string-gaps -- ----------------------------------------------------------------------------- -- List functions diff --git a/libraries/base/Data/Monoid.hs b/libraries/base/Data/Monoid.hs index b71176b19c..2100518e3a 100644 --- a/libraries/base/Data/Monoid.hs +++ b/libraries/base/Data/Monoid.hs @@ -3,6 +3,7 @@ {-# LANGUAGE AutoDeriveTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} ----------------------------------------------------------------------------- -- | @@ -251,6 +252,13 @@ instance Monoid (First a) where r@(First (Just _)) `mappend` _ = r First Nothing `mappend` r = r +instance Functor First where + fmap f (First x) = First (fmap f x) + +instance Monad First where + return x = First (Just x) + First x >>= m = First (x >>= getFirst . m) + -- | Maybe monoid returning the rightmost non-Nothing value. newtype Last a = Last { getLast :: Maybe a } deriving (Eq, Ord, Read, Show, Generic, Generic1) @@ -260,6 +268,13 @@ instance Monoid (Last a) where _ `mappend` r@(Last (Just _)) = r r `mappend` Last Nothing = r +instance Functor Last where + fmap f (Last x) = Last (fmap f x) + +instance Monad Last where + return x = Last (Just x) + Last x >>= m = Last (x >>= getLast . m) + {- {-------------------------------------------------------------------- Testing diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs index e962752ad7..b67f88c446 100644 --- a/libraries/base/Data/Typeable/Internal.hs +++ b/libraries/base/Data/Typeable/Internal.hs @@ -264,6 +264,7 @@ type Typeable7 (a :: * -> * -> * -> * -> * -> * -> * -> *) = Typeable a -- | Kind-polymorphic Typeable instance for type application instance (Typeable s, Typeable a) => Typeable (s a) where + -- See Note [The apparent incoherence of Typable] typeRep# = \_ -> rep -- Note [Memoising typeOf] where !ty1 = typeRep# (proxy# :: Proxy# s) !ty2 = typeRep# (proxy# :: Proxy# a) @@ -446,9 +447,20 @@ lifted types with infinitely many inhabitants. Indeed, `Nat` is isomorphic to (lifted) `[()]` and `Symbol` is isomorphic to `[Char]`. -} --- See `Note [Kinds Containing Only Literals]` in `types/Unify.hs` for --- an explanation of how we avoid overlap with `Typeable (f a)`. -instance KnownNat n => Typeable (n :: Nat) where +{- Note [The apparent incoherence of Typable] See Trac #9242 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The reason we have INCOHERENT on Typeable (n:Nat) and Typeable (s:Symbol) +because we also have an instance Typable (f a). Now suppose we have + [Wanted] Typeable (a :: Nat) +we should pick the (x::Nat) instance, even though the instance +matching rules would worry that 'a' might later be instantiated to +(f b), for some f and b. But we type theorists know that there are no +type constructors f of kind blah -> Nat, so this can never happen and +it's safe to pick the second instance. -} + + +instance {-# INCOHERENT #-} KnownNat n => Typeable (n :: Nat) where + -- See Note [The apparent incoherence of Typable] -- See #9203 for an explanation of why this is written as `\_ -> rep`. typeRep# = \_ -> rep where @@ -465,9 +477,8 @@ instance KnownNat n => Typeable (n :: Nat) where mk a b c = a ++ " " ++ b ++ " " ++ c --- See `Note [Kinds Containing Only Literals]` in `types/Unify.hs` for --- an explanation of how we avoid overlap with `Typeable (f a)`. -instance KnownSymbol s => Typeable (s :: Symbol) where +instance {-# INCOHERENT #-} KnownSymbol s => Typeable (s :: Symbol) where + -- See Note [The apparent incoherence of Typable] -- See #9203 for an explanation of why this is written as `\_ -> rep`. typeRep# = \_ -> rep where diff --git a/libraries/base/Debug/Trace.hs b/libraries/base/Debug/Trace.hs index eedacfa83f..92e5b205c8 100644 --- a/libraries/base/Debug/Trace.hs +++ b/libraries/base/Debug/Trace.hs @@ -52,6 +52,7 @@ import qualified GHC.Foreign import GHC.IO.Encoding import GHC.Ptr import GHC.Stack +import Data.List -- $tracing -- @@ -70,9 +71,15 @@ import GHC.Stack -- /Since: 4.5.0.0/ traceIO :: String -> IO () traceIO msg = do - withCString "%s\n" $ \cfmt -> - withCString msg $ \cmsg -> + withCString "%s\n" $ \cfmt -> do + -- NB: debugBelch can't deal with null bytes, so filter them + -- out so we don't accidentally truncate the message. See Trac #9395 + let (nulls, msg') = partition (=='\0') msg + withCString msg' $ \cmsg -> debugBelch cfmt cmsg + when (not (null nulls)) $ + withCString "WARNING: previous trace message had null bytes" $ \cmsg -> + debugBelch cfmt cmsg -- don't use debugBelch() directly, because we cannot call varargs functions -- using the FFI. diff --git a/libraries/base/GHC/Conc/Sync.lhs b/libraries/base/GHC/Conc/Sync.lhs index ebb7226d09..bd60ebd8fc 100644 --- a/libraries/base/GHC/Conc/Sync.lhs +++ b/libraries/base/GHC/Conc/Sync.lhs @@ -219,10 +219,10 @@ forkIOWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId forkIOWithUnmask io = forkIO (io unsafeUnmask) {- | -Like 'forkIO', but lets you specify on which processor the thread +Like 'forkIO', but lets you specify on which capability the thread should run. Unlike a `forkIO` thread, a thread created by `forkOn` -will stay on the same processor for its entire lifetime (`forkIO` -threads can migrate between processors according to the scheduling +will stay on the same capability for its entire lifetime (`forkIO` +threads can migrate between capabilities according to the scheduling policy). `forkOn` is useful for overriding the scheduling policy when you know in advance how best to distribute the threads. @@ -448,7 +448,11 @@ runSparks = IO loop data BlockReason = BlockedOnMVar - -- ^blocked on on 'MVar' + -- ^blocked on 'MVar' + {- possibly (see 'threadstatus' below): + | BlockedOnMVarRead + -- ^blocked on reading an empty 'MVar' + -} | BlockedOnBlackHole -- ^blocked on a computation in progress by another thread | BlockedOnException @@ -480,15 +484,15 @@ threadStatus (ThreadId t) = IO $ \s -> case threadStatus# t s of (# s', stat, _cap, _locked #) -> (# s', mk_stat (I# stat) #) where - -- NB. keep these in sync with includes/Constants.h + -- NB. keep these in sync with includes/rts/Constants.h mk_stat 0 = ThreadRunning mk_stat 1 = ThreadBlocked BlockedOnMVar - mk_stat 2 = ThreadBlocked BlockedOnMVar -- XXX distinguish? - mk_stat 3 = ThreadBlocked BlockedOnBlackHole - mk_stat 7 = ThreadBlocked BlockedOnSTM + mk_stat 2 = ThreadBlocked BlockedOnBlackHole + mk_stat 6 = ThreadBlocked BlockedOnSTM + mk_stat 10 = ThreadBlocked BlockedOnForeignCall mk_stat 11 = ThreadBlocked BlockedOnForeignCall - mk_stat 12 = ThreadBlocked BlockedOnForeignCall - mk_stat 13 = ThreadBlocked BlockedOnException + mk_stat 12 = ThreadBlocked BlockedOnException + mk_stat 14 = ThreadBlocked BlockedOnMVar -- possibly: BlockedOnMVarRead -- NB. these are hardcoded in rts/PrimOps.cmm mk_stat 16 = ThreadFinished mk_stat 17 = ThreadDied diff --git a/libraries/base/GHC/Event/Poll.hsc b/libraries/base/GHC/Event/Poll.hsc index bb0b6e570b..2ed25bec8b 100644 --- a/libraries/base/GHC/Event/Poll.hsc +++ b/libraries/base/GHC/Event/Poll.hsc @@ -14,6 +14,7 @@ module GHC.Event.Poll #if !defined(HAVE_POLL_H) import GHC.Base +import qualified GHC.Event.Internal as E new :: IO E.Backend new = error "Poll back end not implemented for this platform" diff --git a/libraries/base/GHC/Event/Thread.hs b/libraries/base/GHC/Event/Thread.hs index 6e991bfb6c..dcfa32aa28 100644 --- a/libraries/base/GHC/Event/Thread.hs +++ b/libraries/base/GHC/Event/Thread.hs @@ -39,6 +39,7 @@ import GHC.Event.Manager (Event, EventManager, evtRead, evtWrite, loop, import qualified GHC.Event.Manager as M import qualified GHC.Event.TimerManager as TM import GHC.Num ((-), (+)) +import GHC.Show (showSignedInt) import System.IO.Unsafe (unsafePerformIO) import System.Posix.Types (Fd) @@ -244,11 +245,14 @@ startIOManagerThreads = forM_ [0..high] (startIOManagerThread eventManagerArray) writeIORef numEnabledEventManagers (high+1) +show_int :: Int -> String +show_int i = showSignedInt 0 i "" + restartPollLoop :: EventManager -> Int -> IO ThreadId restartPollLoop mgr i = do M.release mgr !t <- forkOn i $ loop mgr - labelThread t "IOManager" + labelThread t ("IOManager on cap " ++ show_int i) return t startIOManagerThread :: IOArray Int (Maybe (ThreadId, EventManager)) @@ -258,7 +262,7 @@ startIOManagerThread eventManagerArray i = do let create = do !mgr <- new True !t <- forkOn i $ loop mgr - labelThread t "IOManager" + labelThread t ("IOManager on cap " ++ show_int i) writeIOArray eventManagerArray i (Just (t,mgr)) old <- readIOArray eventManagerArray i case old of diff --git a/libraries/base/GHC/IO/FD.hs b/libraries/base/GHC/IO/FD.hs index 7b30504f8e..1134e95f8d 100644 --- a/libraries/base/GHC/IO/FD.hs +++ b/libraries/base/GHC/IO/FD.hs @@ -261,7 +261,7 @@ mkFD fd iomode mb_stat is_socket is_nonblock = do _other_type -> return () #ifdef mingw32_HOST_OS - _ <- setmode fd True -- unconditionally set binary mode + unless is_socket $ setmode fd True >> return () #endif return (FD{ fdFD = fd, @@ -414,7 +414,8 @@ foreign import ccall safe "fdReady" isTerminal :: FD -> IO Bool isTerminal fd = #if defined(mingw32_HOST_OS) - is_console (fdFD fd) >>= return.toBool + if fdIsSocket fd then return False + else is_console (fdFD fd) >>= return.toBool #else c_isatty (fdFD fd) >>= return.toBool #endif diff --git a/libraries/base/GHC/List.lhs b/libraries/base/GHC/List.lhs index e004ded1e8..9b6cc2eb19 100644 --- a/libraries/base/GHC/List.lhs +++ b/libraries/base/GHC/List.lhs @@ -83,11 +83,8 @@ last [x] = x last (_:xs) = last xs last [] = errorEmptyList "last" #else --- eliminate repeated cases -last [] = errorEmptyList "last" -last (x:xs) = last' x xs - where last' y [] = y - last' _ (y:ys) = last' y ys +-- use foldl to allow fusion +last = foldl (\_ x -> x) (errorEmptyList "last") #endif -- | Return all the elements of a list except the last one. diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs index 004ff54777..5cd0351fdb 100644 --- a/libraries/base/System/IO.hs +++ b/libraries/base/System/IO.hs @@ -241,7 +241,6 @@ import GHC.IO.Handle import GHC.IO.Handle.Text ( hGetBufSome, hPutStrLn ) import GHC.IO.Exception ( userError ) import GHC.IO.Encoding -import GHC.Num import Text.Read import GHC.Show import GHC.MVar @@ -464,9 +463,7 @@ openBinaryTempFileWithDefaultPermissions tmp_dir template openTempFile' :: String -> FilePath -> String -> Bool -> CMode -> IO (FilePath, Handle) -openTempFile' loc tmp_dir template binary mode = do - pid <- c_getpid - findTempName pid +openTempFile' loc tmp_dir template binary mode = findTempName where -- We split off the last extension, so we can use .foo.ext files -- for temporary files (hidden on Unix OSes). Unfortunately we're @@ -485,10 +482,13 @@ openTempFile' loc tmp_dir template binary mode = do -- beginning with '.' as the second component. _ -> error "bug in System.IO.openTempFile" - findTempName x = do + findTempName = do + rs <- rand_string + let filename = prefix ++ rs ++ suffix + filepath = tmp_dir `combine` filename r <- openNewFile filepath binary mode case r of - FileExists -> findTempName (x + 1) + FileExists -> findTempName OpenNewError errno -> ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) NewFileCreated fd -> do (fD,fd_type) <- FD.mkFD fd ReadWriteMode Nothing{-no stat-} @@ -501,9 +501,6 @@ openTempFile' loc tmp_dir template binary mode = do return (filepath, h) where - filename = prefix ++ show x ++ suffix - filepath = tmp_dir `combine` filename - -- XXX bits copied from System.FilePath, since that's not available here combine a b | null b = a @@ -511,6 +508,16 @@ openTempFile' loc tmp_dir template binary mode = do | last a == pathSeparator = a ++ b | otherwise = a ++ [pathSeparator] ++ b +-- int rand(void) from <stdlib.h>, limited by RAND_MAX (small value, 32768) +foreign import ccall "rand" c_rand :: IO CInt + +-- build large digit-alike number +rand_string :: IO String +rand_string = do + r1 <- c_rand + r2 <- c_rand + return $ show r1 ++ show r2 + data OpenNewFileResult = NewFileCreated CInt | FileExists diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index e56724ce4f..b7828a9c20 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -328,6 +328,6 @@ Library GHC.Event.TimerManager GHC.Event.Unique - -- We need to set the package name to base (without a version number) + -- We need to set the package key to base (without a version number) -- as it's magic. - ghc-options: -package-name base + ghc-options: -this-package-key base diff --git a/libraries/base/cbits/inputReady.c b/libraries/base/cbits/inputReady.c index 51f278feb1..dac9d9b524 100644 --- a/libraries/base/cbits/inputReady.c +++ b/libraries/base/cbits/inputReady.c @@ -25,7 +25,11 @@ fdReady(int fd, int write, int msecs, int isSock) int maxfd, ready; fd_set rfd, wfd; struct timeval tv; - + if ((fd >= (int)FD_SETSIZE) || (fd < 0)) { + /* avoid memory corruption on too large FDs */ + errno = EINVAL; + return -1; + } FD_ZERO(&rfd); FD_ZERO(&wfd); if (write) { diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index 4efb1216e1..06c9fa5a97 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -14,6 +14,23 @@ * Add `Control.Monad.(<$!>)` as a strict version of `(<$>)` + * The `Data.Monoid` module now has the `PolyKinds` extension + enabled, so that the `Monoid` instance for `Proxy` are polykinded + like `Proxy` itself is. + +## 4.7.0.1 *Jul 2014* + + * Bundled with GHC 7.8.3 + + * Unhide `Foreign.ForeignPtr` in Haddock (#8475) + + * Fix recomputation of `TypeRep` in `Typeable` type-application instance + (#9203) + + * Fix regression in Data.Fixed Read instance (#9231) + + * Fix `fdReady` to honor `FD_SETSIZE` (#9168) + ## 4.7.0.0 *Apr 2014* * Bundled with GHC 7.8.1 diff --git a/libraries/base/tests/.gitignore b/libraries/base/tests/.gitignore index a909c5cf51..b7b2dc8e76 100644 --- a/libraries/base/tests/.gitignore +++ b/libraries/base/tests/.gitignore @@ -1,93 +1,271 @@ -.hpc.CPUTime001 -.hpc.CatEntail -.hpc.CatPairs -.hpc.T4006 -.hpc.T5943 -.hpc.T5962 -.hpc.T7034 -.hpc.T7457 -.hpc.T7653 -.hpc.T7773 -.hpc.T7787 -.hpc.addr001 -.hpc.assert -.hpc.char001 -.hpc.char002 -.hpc.cstring001 -.hpc.data-fixed-show-read -.hpc.dynamic001 -.hpc.dynamic002 -.hpc.dynamic003 -.hpc.dynamic004 -.hpc.dynamic005 -.hpc.echo001 -.hpc.enum01 -.hpc.enum02 -.hpc.enum03 -.hpc.enum04 -.hpc.enumDouble -.hpc.enumRatio -.hpc.exceptionsrun001 -.hpc.exceptionsrun002 -.hpc.fixed -.hpc.genericNegative001 -.hpc.hGetBuf002 -.hpc.hGetBuf003 -.hpc.hPutBuf001 -.hpc.hPutBuf002 -.hpc.hTell001 -.hpc.hTell002 -.hpc.ioref001 -.hpc.ix001 -.hpc.length001 -.hpc.lex001 -.hpc.list001 -.hpc.list002 -.hpc.list003 -.hpc.memo001 -.hpc.memo002 -.hpc.performGC001 -.hpc.qsem001 -.hpc.qsemn001 -.hpc.quotOverflow -.hpc.rand001 -.hpc.ratio001 -.hpc.readDouble001 -.hpc.readFixed001 -.hpc.readFloat -.hpc.readInteger001 -.hpc.readLitChar -.hpc.reads001 -.hpc.show001 -.hpc.showDouble -.hpc.stableptr001 -.hpc.stableptr003 -.hpc.stableptr004 -.hpc.stableptr005 -.hpc.take001 -.hpc.tempfiles -.hpc.text001 -.hpc.topHandler01 -.hpc.topHandler02 -.hpc.topHandler03 -.hpc.trace001 -.hpc.tup001 -.hpc.unicode001 -.hpc.unicode002 -.hpc.weak001 -T4006 -T5943 -T5962 -T7034 -T7457 -T7653 -T7773 -T7787 -T8766 -T8766.stats -qsem001 -qsemn001 -readFixed001 -topHandler01 -topHandler02 -topHandler03 +*.eventlog +*.genscript + +*.stderr.normalised +*.stdout.normalised +*.comp.stderr +*.comp.stdout +*.interp.stderr +*.interp.stdout +*.run.stderr +*.run.stdout + +.hpc.*/ +.hpc/ + +# specific files +/CPUTime001 +/Concurrent/4876 +/Concurrent/Chan002 +/Concurrent/Chan003 +/Concurrent/ThreadDelay001 +/IO/IOError001 +/IO/IOError002 +/IO/T2122 +/IO/T2122-test +/IO/T3307 +/IO/T4144 +/IO/T4808 +/IO/T4808.test +/IO/T4855 +/IO/T4895 +/IO/T7853 +/IO/chinese-file-* +/IO/chinese-name +/IO/concio002 +/IO/countReaders001 +/IO/countReaders001.txt +/IO/decodingerror001 +/IO/decodingerror002 +/IO/encoding001 +/IO/encoding001.utf16 +/IO/encoding001.utf16.utf16be +/IO/encoding001.utf16.utf16le +/IO/encoding001.utf16.utf32 +/IO/encoding001.utf16.utf32be +/IO/encoding001.utf16.utf32le +/IO/encoding001.utf16.utf8 +/IO/encoding001.utf16.utf8_bom +/IO/encoding001.utf16be +/IO/encoding001.utf16be.utf16 +/IO/encoding001.utf16be.utf16le +/IO/encoding001.utf16be.utf32 +/IO/encoding001.utf16be.utf32be +/IO/encoding001.utf16be.utf32le +/IO/encoding001.utf16be.utf8 +/IO/encoding001.utf16be.utf8_bom +/IO/encoding001.utf16le +/IO/encoding001.utf16le.utf16 +/IO/encoding001.utf16le.utf16be +/IO/encoding001.utf16le.utf32 +/IO/encoding001.utf16le.utf32be +/IO/encoding001.utf16le.utf32le +/IO/encoding001.utf16le.utf8 +/IO/encoding001.utf16le.utf8_bom +/IO/encoding001.utf32 +/IO/encoding001.utf32.utf16 +/IO/encoding001.utf32.utf16be +/IO/encoding001.utf32.utf16le +/IO/encoding001.utf32.utf32be +/IO/encoding001.utf32.utf32le +/IO/encoding001.utf32.utf8 +/IO/encoding001.utf32.utf8_bom +/IO/encoding001.utf32be +/IO/encoding001.utf32be.utf16 +/IO/encoding001.utf32be.utf16be +/IO/encoding001.utf32be.utf16le +/IO/encoding001.utf32be.utf32 +/IO/encoding001.utf32be.utf32le +/IO/encoding001.utf32be.utf8 +/IO/encoding001.utf32be.utf8_bom +/IO/encoding001.utf32le +/IO/encoding001.utf32le.utf16 +/IO/encoding001.utf32le.utf16be +/IO/encoding001.utf32le.utf16le +/IO/encoding001.utf32le.utf32 +/IO/encoding001.utf32le.utf32be +/IO/encoding001.utf32le.utf8 +/IO/encoding001.utf32le.utf8_bom +/IO/encoding001.utf8 +/IO/encoding001.utf8.utf16 +/IO/encoding001.utf8.utf16be +/IO/encoding001.utf8.utf16le +/IO/encoding001.utf8.utf32 +/IO/encoding001.utf8.utf32be +/IO/encoding001.utf8.utf32le +/IO/encoding001.utf8.utf8_bom +/IO/encoding001.utf8_bom +/IO/encoding001.utf8_bom.utf16 +/IO/encoding001.utf8_bom.utf16be +/IO/encoding001.utf8_bom.utf16le +/IO/encoding001.utf8_bom.utf32 +/IO/encoding001.utf8_bom.utf32be +/IO/encoding001.utf8_bom.utf32le +/IO/encoding001.utf8_bom.utf8 +/IO/encoding002 +/IO/encoding003 +/IO/encoding004 +/IO/encodingerror001 +/IO/environment001 +/IO/finalization001 +/IO/hClose001 +/IO/hClose001.tmp +/IO/hClose002 +/IO/hClose002.tmp +/IO/hClose003 +/IO/hDuplicateTo001 +/IO/hFileSize001 +/IO/hFileSize002 +/IO/hFileSize002.out +/IO/hFlush001 +/IO/hFlush001.out +/IO/hGetBuf001 +/IO/hGetBuffering001 +/IO/hGetChar001 +/IO/hGetLine001 +/IO/hGetLine002 +/IO/hGetLine003 +/IO/hGetPosn001 +/IO/hGetPosn001.out +/IO/hIsEOF001 +/IO/hIsEOF002 +/IO/hIsEOF002.out +/IO/hReady001 +/IO/hReady002 +/IO/hSeek001 +/IO/hSeek002 +/IO/hSeek003 +/IO/hSeek004 +/IO/hSeek004.out +/IO/hSetBuffering002 +/IO/hSetBuffering003 +/IO/hSetBuffering004 +/IO/hSetEncoding001 +/IO/ioeGetErrorString001 +/IO/ioeGetFileName001 +/IO/ioeGetHandle001 +/IO/isEOF001 +/IO/misc001 +/IO/misc001.out +/IO/newline001 +/IO/newline001.out +/IO/openFile001 +/IO/openFile002 +/IO/openFile003 +/IO/openFile003Dir +/IO/openFile004 +/IO/openFile004.out +/IO/openFile005 +/IO/openFile005.out1 +/IO/openFile005.out2 +/IO/openFile006 +/IO/openFile006.out +/IO/openFile007 +/IO/openFile007.out +/IO/openFile008 +/IO/openTempFile001 +/IO/putStr001 +/IO/readFile001 +/IO/readFile001.out +/IO/readwrite001 +/IO/readwrite001.inout +/IO/readwrite002 +/IO/readwrite002.inout +/IO/readwrite003 +/IO/readwrite003.txt +/IO/tmp +/Numeric/num001 +/Numeric/num002 +/Numeric/num003 +/Numeric/num004 +/Numeric/num005 +/Numeric/num006 +/Numeric/num007 +/Numeric/num008 +/Numeric/num009 +/Numeric/num010 +/System/T5930 +/System/Timeout001 +/System/exitWith001 +/System/getArgs001 +/System/getEnv001 +/System/system001 +/T4006 +/T5943 +/T5962 +/T7034 +/T7457 +/T7653 +/T7773 +/T7787 +/T8766 +/T8766.stats +/Text.Printf/T1548 +/addr001 +/assert +/char001 +/char002 +/cstring001 +/data-fixed-show-read +/dynamic001 +/dynamic002 +/dynamic003 +/dynamic004 +/dynamic005 +/echo001 +/enum01 +/enum02 +/enum03 +/enum04 +/enumDouble +/enumRatio +/exceptionsrun001 +/exceptionsrun002 +/fixed +/genericNegative001 +/hGetBuf002 +/hGetBuf003 +/hPutBuf001 +/hPutBuf002 +/hPutBuf002.out +/hTell001 +/hTell002 +/hash001 +/ioref001 +/ix001 +/length001 +/lex001 +/list001 +/list002 +/list003 +/memo001 +/memo002 +/performGC001 +/qsem001 +/qsemn001 +/quotOverflow +/rand001 +/ratio001 +/readDouble001 +/readFixed001 +/readFloat +/readInteger001 +/readLitChar +/reads001 +/show001 +/showDouble +/stableptr001 +/stableptr003 +/stableptr004 +/stableptr005 +/take001 +/tempfiles +/text001 +/topHandler01 +/topHandler02 +/topHandler03 +/trace001 +/tup001 +/unicode001 +/unicode002 +/weak001 diff --git a/libraries/base/tests/Concurrent/.gitignore b/libraries/base/tests/Concurrent/.gitignore deleted file mode 100644 index 70f284856f..0000000000 --- a/libraries/base/tests/Concurrent/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -.hpc.Chan002 -.hpc.Chan003 -.hpc.ThreadDelay001 -Chan002 -Chan003 diff --git a/libraries/base/tests/IO/.gitignore b/libraries/base/tests/IO/.gitignore deleted file mode 100644 index f8fcfa8ba1..0000000000 --- a/libraries/base/tests/IO/.gitignore +++ /dev/null @@ -1,75 +0,0 @@ -.hpc.IOError001 -.hpc.IOError002 -.hpc.T2122 -.hpc.T4144 -.hpc.T4808 -.hpc.T4855 -.hpc.T4895 -.hpc.T7853 -.hpc.concio002 -.hpc.countReaders001 -.hpc.decodingerror001 -.hpc.decodingerror002 -.hpc.encoding001 -.hpc.encoding002 -.hpc.encoding003 -.hpc.encoding004 -.hpc.encodingerror001 -.hpc.finalization001 -.hpc.hClose001 -.hpc.hClose002 -.hpc.hClose003 -.hpc.hDuplicateTo001 -.hpc.hFileSize001 -.hpc.hFileSize002 -.hpc.hFlush001 -.hpc.hGetBuf001 -.hpc.hGetBuffering001 -.hpc.hGetChar001 -.hpc.hGetLine001 -.hpc.hGetLine002 -.hpc.hGetLine003 -.hpc.hGetPosn001 -.hpc.hIsEOF001 -.hpc.hIsEOF002 -.hpc.hReady001 -.hpc.hReady002 -.hpc.hSeek001 -.hpc.hSeek002 -.hpc.hSeek003 -.hpc.hSeek004 -.hpc.hSetBuffering002 -.hpc.hSetBuffering003 -.hpc.hSetBuffering004 -.hpc.hSetEncoding001 -.hpc.ioeGetErrorString001 -.hpc.ioeGetFileName001 -.hpc.ioeGetHandle001 -.hpc.isEOF001 -.hpc.misc001 -.hpc.newline001 -.hpc.openFile001 -.hpc.openFile002 -.hpc.openFile003 -.hpc.openFile004 -.hpc.openFile005 -.hpc.openFile006 -.hpc.openFile007 -.hpc.openFile008 -.hpc.openTempFile001 -.hpc.putStr001 -.hpc.readFile001 -.hpc.readwrite001 -.hpc.readwrite002 -.hpc.readwrite003 -T2122 -T2122-test -T3307 -T4808 -T4808.test -T4855 -T4895 -T7853 -encoding003 -encoding004 -openFile003Dir diff --git a/libraries/base/tests/IO/openFile003.stdout-i386-unknown-solaris2 b/libraries/base/tests/IO/openFile003.stdout-i386-unknown-solaris2 deleted file mode 100644 index 6a78a2a891..0000000000 --- a/libraries/base/tests/IO/openFile003.stdout-i386-unknown-solaris2 +++ /dev/null @@ -1,4 +0,0 @@ -Left openFile003Dir: openFile: inappropriate type (is a directory) -Left openFile003Dir: openFile: invalid argument (Invalid argument) -Left openFile003Dir: openFile: invalid argument (Invalid argument) -Left openFile003Dir: openFile: invalid argument (Invalid argument) diff --git a/libraries/base/tests/Numeric/.gitignore b/libraries/base/tests/Numeric/.gitignore deleted file mode 100644 index b944456eae..0000000000 --- a/libraries/base/tests/Numeric/.gitignore +++ /dev/null @@ -1,10 +0,0 @@ -.hpc.num001 -.hpc.num002 -.hpc.num003 -.hpc.num004 -.hpc.num005 -.hpc.num006 -.hpc.num007 -.hpc.num008 -.hpc.num009 -.hpc.num010 diff --git a/libraries/base/tests/System/.gitignore b/libraries/base/tests/System/.gitignore deleted file mode 100644 index fa2ab73827..0000000000 --- a/libraries/base/tests/System/.gitignore +++ /dev/null @@ -1,8 +0,0 @@ -.hpc.T5930 -.hpc.Timeout001 -.hpc.exitWith001 -.hpc.getArgs001 -.hpc.getEnv001 -.hpc.system001 -T5930 -Timeout001 diff --git a/libraries/base/tests/T9395.hs b/libraries/base/tests/T9395.hs new file mode 100644 index 0000000000..c86b1279b4 --- /dev/null +++ b/libraries/base/tests/T9395.hs @@ -0,0 +1,2 @@ +import Debug.Trace +main = trace "333\0UUUU" $ return () diff --git a/libraries/base/tests/T9395.stderr b/libraries/base/tests/T9395.stderr new file mode 100644 index 0000000000..4a4fb3f7c1 --- /dev/null +++ b/libraries/base/tests/T9395.stderr @@ -0,0 +1,2 @@ +333UUUU +WARNING: previous trace message had null bytes diff --git a/libraries/base/tests/Text.Printf/.gitignore b/libraries/base/tests/Text.Printf/.gitignore deleted file mode 100644 index 377d9ffcbd..0000000000 --- a/libraries/base/tests/Text.Printf/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -.hpc.T1548 -T1548 diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T index 12a241085a..aa752c2a73 100644 --- a/libraries/base/tests/all.T +++ b/libraries/base/tests/all.T @@ -152,7 +152,8 @@ test('topHandler03', [when(opsys('mingw32'), skip), # As above, shells, grrr. ignore_output, - exit_code(143) # actually signal 15 SIGTERM + when(opsys('solaris2'), exit_code(15)), # Solaris signals 15 correctly + when(not opsys('solaris2'), exit_code(143)) # actually signal 15 SIGTERM ], compile_and_run, ['']) @@ -168,3 +169,4 @@ test('T8766', ['-O']) test('T9111', normal, compile, ['']) +test('T9395', normal, compile_and_run, ['']) diff --git a/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs b/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs index 6ad169787f..baf8a05159 100644 --- a/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs +++ b/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs @@ -22,6 +22,7 @@ module Distribution.InstalledPackageInfo.Binary ( import Distribution.Version import Distribution.Package hiding (depends) import Distribution.License +import Distribution.ModuleExport import Distribution.InstalledPackageInfo as IPI import Data.Binary as Bin import Control.Exception as Exception @@ -48,6 +49,7 @@ putInstalledPackageInfo :: Binary m => InstalledPackageInfo_ m -> Put putInstalledPackageInfo ipi = do put (sourcePackageId ipi) put (installedPackageId ipi) + put (packageKey ipi) put (license ipi) put (copyright ipi) put (maintainer ipi) @@ -60,6 +62,7 @@ putInstalledPackageInfo ipi = do put (category ipi) put (exposed ipi) put (exposedModules ipi) + put (reexportedModules ipi) put (hiddenModules ipi) put (trusted ipi) put (importDirs ipi) @@ -82,6 +85,7 @@ getInstalledPackageInfo :: Binary m => Get (InstalledPackageInfo_ m) getInstalledPackageInfo = do sourcePackageId <- get installedPackageId <- get + packageKey <- get license <- get copyright <- get maintainer <- get @@ -94,6 +98,7 @@ getInstalledPackageInfo = do category <- get exposed <- get exposedModules <- get + reexportedModules <- get hiddenModules <- get trusted <- get importDirs <- get @@ -158,3 +163,17 @@ instance Binary Version where deriving instance Binary PackageName deriving instance Binary InstalledPackageId + +instance Binary m => Binary (ModuleExport m) where + put (ModuleExport a b c d) = do put a; put b; put c; put d + get = do a <- get; b <- get; c <- get; d <- get; + return (ModuleExport a b c d) + +instance Binary PackageKey where + put (PackageKey a b c) = do putWord8 0; put a; put b; put c + put (OldPackageKey a) = do putWord8 1; put a + get = do n <- getWord8 + case n of + 0 -> do a <- get; b <- get; c <- get; return (PackageKey a b c) + 1 -> do a <- get; return (OldPackageKey a) + _ -> error ("Binary PackageKey: bad branch " ++ show n) diff --git a/libraries/bin-package-db/bin-package-db.cabal b/libraries/bin-package-db/bin-package-db.cabal index dd84f9ca4b..e8b4fd45ee 100644 --- a/libraries/bin-package-db/bin-package-db.cabal +++ b/libraries/bin-package-db/bin-package-db.cabal @@ -26,5 +26,5 @@ Library build-depends: base >= 4 && < 5, binary >= 0.5 && < 0.8, - Cabal >= 1.20 && < 1.21 + Cabal >= 1.20 && < 1.22 diff --git a/libraries/ghc-prim/cbits/atomic.c b/libraries/ghc-prim/cbits/atomic.c new file mode 100644 index 0000000000..e3d6cc1e95 --- /dev/null +++ b/libraries/ghc-prim/cbits/atomic.c @@ -0,0 +1,306 @@ +#include "Rts.h" + +// Fallbacks for atomic primops on byte arrays. The builtins used +// below are supported on both GCC and LLVM. +// +// Ideally these function would take StgWord8, StgWord16, etc but +// older GCC versions incorrectly assume that the register that the +// argument is passed in has been zero extended, which is incorrect +// according to the ABI and is not what GHC does when it generates +// calls to these functions. + +// FetchAddByteArrayOp_Int + +extern StgWord hs_atomic_add8(volatile StgWord8 *x, StgWord val); +StgWord +hs_atomic_add8(volatile StgWord8 *x, StgWord val) +{ + return __sync_fetch_and_add(x, (StgWord8) val); +} + +extern StgWord hs_atomic_add16(volatile StgWord16 *x, StgWord val); +StgWord +hs_atomic_add16(volatile StgWord16 *x, StgWord val) +{ + return __sync_fetch_and_add(x, (StgWord16) val); +} + +extern StgWord hs_atomic_add32(volatile StgWord32 *x, StgWord val); +StgWord +hs_atomic_add32(volatile StgWord32 *x, StgWord val) +{ + return __sync_fetch_and_add(x, (StgWord32) val); +} + +extern StgWord64 hs_atomic_add64(volatile StgWord64 *x, StgWord64 val); +StgWord64 +hs_atomic_add64(volatile StgWord64 *x, StgWord64 val) +{ + return __sync_fetch_and_add(x, val); +} + +// FetchSubByteArrayOp_Int + +extern StgWord hs_atomic_sub8(volatile StgWord8 *x, StgWord val); +StgWord +hs_atomic_sub8(volatile StgWord8 *x, StgWord val) +{ + return __sync_fetch_and_sub(x, (StgWord8) val); +} + +extern StgWord hs_atomic_sub16(volatile StgWord16 *x, StgWord val); +StgWord +hs_atomic_sub16(volatile StgWord16 *x, StgWord val) +{ + return __sync_fetch_and_sub(x, (StgWord16) val); +} + +extern StgWord hs_atomic_sub32(volatile StgWord32 *x, StgWord val); +StgWord +hs_atomic_sub32(volatile StgWord32 *x, StgWord val) +{ + return __sync_fetch_and_sub(x, (StgWord32) val); +} + +extern StgWord64 hs_atomic_sub64(volatile StgWord64 *x, StgWord64 val); +StgWord64 +hs_atomic_sub64(volatile StgWord64 *x, StgWord64 val) +{ + return __sync_fetch_and_sub(x, val); +} + +// FetchAndByteArrayOp_Int + +extern StgWord hs_atomic_and8(volatile StgWord8 *x, StgWord val); +StgWord +hs_atomic_and8(volatile StgWord8 *x, StgWord val) +{ + return __sync_fetch_and_and(x, (StgWord8) val); +} + +extern StgWord hs_atomic_and16(volatile StgWord16 *x, StgWord val); +StgWord +hs_atomic_and16(volatile StgWord16 *x, StgWord val) +{ + return __sync_fetch_and_and(x, (StgWord16) val); +} + +extern StgWord hs_atomic_and32(volatile StgWord32 *x, StgWord val); +StgWord +hs_atomic_and32(volatile StgWord32 *x, StgWord val) +{ + return __sync_fetch_and_and(x, (StgWord32) val); +} + +extern StgWord64 hs_atomic_and64(volatile StgWord64 *x, StgWord64 val); +StgWord64 +hs_atomic_and64(volatile StgWord64 *x, StgWord64 val) +{ + return __sync_fetch_and_and(x, val); +} + +// FetchNandByteArrayOp_Int + +// Workaround for http://llvm.org/bugs/show_bug.cgi?id=8842 +#define CAS_NAND(x, val) \ + { \ + __typeof__ (*(x)) tmp = *(x); \ + while (!__sync_bool_compare_and_swap(x, tmp, ~(tmp & (val)))) { \ + tmp = *(x); \ + } \ + return tmp; \ + } + +extern StgWord hs_atomic_nand8(volatile StgWord8 *x, StgWord val); +StgWord +hs_atomic_nand8(volatile StgWord8 *x, StgWord val) +{ +#ifdef __clang__ + CAS_NAND(x, (StgWord8) val) +#else + return __sync_fetch_and_nand(x, (StgWord8) val); +#endif +} + +extern StgWord hs_atomic_nand16(volatile StgWord16 *x, StgWord val); +StgWord +hs_atomic_nand16(volatile StgWord16 *x, StgWord val) +{ +#ifdef __clang__ + CAS_NAND(x, (StgWord16) val); +#else + return __sync_fetch_and_nand(x, (StgWord16) val); +#endif +} + +extern StgWord hs_atomic_nand32(volatile StgWord32 *x, StgWord val); +StgWord +hs_atomic_nand32(volatile StgWord32 *x, StgWord val) +{ +#ifdef __clang__ + CAS_NAND(x, (StgWord32) val); +#else + return __sync_fetch_and_nand(x, (StgWord32) val); +#endif +} + +extern StgWord64 hs_atomic_nand64(volatile StgWord64 *x, StgWord64 val); +StgWord64 +hs_atomic_nand64(volatile StgWord64 *x, StgWord64 val) +{ +#ifdef __clang__ + CAS_NAND(x, val); +#else + return __sync_fetch_and_nand(x, val); +#endif +} + +// FetchOrByteArrayOp_Int + +extern StgWord hs_atomic_or8(volatile StgWord8 *x, StgWord val); +StgWord +hs_atomic_or8(volatile StgWord8 *x, StgWord val) +{ + return __sync_fetch_and_or(x, (StgWord8) val); +} + +extern StgWord hs_atomic_or16(volatile StgWord16 *x, StgWord val); +StgWord +hs_atomic_or16(volatile StgWord16 *x, StgWord val) +{ + return __sync_fetch_and_or(x, (StgWord16) val); +} + +extern StgWord hs_atomic_or32(volatile StgWord32 *x, StgWord val); +StgWord +hs_atomic_or32(volatile StgWord32 *x, StgWord val) +{ + return __sync_fetch_and_or(x, (StgWord32) val); +} + +extern StgWord64 hs_atomic_or64(volatile StgWord64 *x, StgWord64 val); +StgWord64 +hs_atomic_or64(volatile StgWord64 *x, StgWord64 val) +{ + return __sync_fetch_and_or(x, val); +} + +// FetchXorByteArrayOp_Int + +extern StgWord hs_atomic_xor8(volatile StgWord8 *x, StgWord val); +StgWord +hs_atomic_xor8(volatile StgWord8 *x, StgWord val) +{ + return __sync_fetch_and_xor(x, (StgWord8) val); +} + +extern StgWord hs_atomic_xor16(volatile StgWord16 *x, StgWord val); +StgWord +hs_atomic_xor16(volatile StgWord16 *x, StgWord val) +{ + return __sync_fetch_and_xor(x, (StgWord16) val); +} + +extern StgWord hs_atomic_xor32(volatile StgWord32 *x, StgWord val); +StgWord +hs_atomic_xor32(volatile StgWord32 *x, StgWord val) +{ + return __sync_fetch_and_xor(x, (StgWord32) val); +} + +extern StgWord64 hs_atomic_xor64(volatile StgWord64 *x, StgWord64 val); +StgWord64 +hs_atomic_xor64(volatile StgWord64 *x, StgWord64 val) +{ + return __sync_fetch_and_xor(x, val); +} + +// CasByteArrayOp_Int + +extern StgWord hs_cmpxchg8(volatile StgWord8 *x, StgWord old, StgWord new); +StgWord +hs_cmpxchg8(volatile StgWord8 *x, StgWord old, StgWord new) +{ + return __sync_val_compare_and_swap(x, (StgWord8) old, (StgWord8) new); +} + +extern StgWord hs_cmpxchg16(volatile StgWord16 *x, StgWord old, StgWord new); +StgWord +hs_cmpxchg16(volatile StgWord16 *x, StgWord old, StgWord new) +{ + return __sync_val_compare_and_swap(x, (StgWord16) old, (StgWord16) new); +} + +extern StgWord hs_cmpxchg32(volatile StgWord32 *x, StgWord old, StgWord new); +StgWord +hs_cmpxchg32(volatile StgWord32 *x, StgWord old, StgWord new) +{ + return __sync_val_compare_and_swap(x, (StgWord32) old, (StgWord32) new); +} + +extern StgWord hs_cmpxchg64(volatile StgWord64 *x, StgWord64 old, StgWord64 new); +StgWord +hs_cmpxchg64(volatile StgWord64 *x, StgWord64 old, StgWord64 new) +{ + return __sync_val_compare_and_swap(x, old, new); +} + +// AtomicReadByteArrayOp_Int + +extern StgWord hs_atomicread8(volatile StgWord8 *x); +StgWord +hs_atomicread8(volatile StgWord8 *x) +{ + return *x; +} + +extern StgWord hs_atomicread16(volatile StgWord16 *x); +StgWord +hs_atomicread16(volatile StgWord16 *x) +{ + return *x; +} + +extern StgWord hs_atomicread32(volatile StgWord32 *x); +StgWord +hs_atomicread32(volatile StgWord32 *x) +{ + return *x; +} + +extern StgWord64 hs_atomicread64(volatile StgWord64 *x); +StgWord64 +hs_atomicread64(volatile StgWord64 *x) +{ + return *x; +} + +// AtomicWriteByteArrayOp_Int + +extern void hs_atomicwrite8(volatile StgWord8 *x, StgWord val); +void +hs_atomicwrite8(volatile StgWord8 *x, StgWord val) +{ + *x = (StgWord8) val; +} + +extern void hs_atomicwrite16(volatile StgWord16 *x, StgWord val); +void +hs_atomicwrite16(volatile StgWord16 *x, StgWord val) +{ + *x = (StgWord16) val; +} + +extern void hs_atomicwrite32(volatile StgWord32 *x, StgWord val); +void +hs_atomicwrite32(volatile StgWord32 *x, StgWord val) +{ + *x = (StgWord32) val; +} + +extern void hs_atomicwrite64(volatile StgWord64 *x, StgWord64 val); +void +hs_atomicwrite64(volatile StgWord64 *x, StgWord64 val) +{ + *x = (StgWord64) val; +} diff --git a/libraries/ghc-prim/ghc-prim.cabal b/libraries/ghc-prim/ghc-prim.cabal index c861342b56..9c1801b4d6 100644 --- a/libraries/ghc-prim/ghc-prim.cabal +++ b/libraries/ghc-prim/ghc-prim.cabal @@ -52,12 +52,13 @@ Library exposed-modules: GHC.Prim c-sources: + cbits/atomic.c cbits/bswap.c cbits/debug.c cbits/longlong.c cbits/popcnt.c cbits/word2float.c - -- We need to set the package name to ghc-prim (without a version number) + -- We need to set the package key to ghc-prim (without a version number) -- as it's magic. - ghc-options: -package-name ghc-prim + ghc-options: -this-package-key ghc-prim diff --git a/libraries/integer-gmp/.gitignore b/libraries/integer-gmp/.gitignore index 295f5b267a..4e7da368da 100644 --- a/libraries/integer-gmp/.gitignore +++ b/libraries/integer-gmp/.gitignore @@ -11,3 +11,6 @@ /include/HsIntegerGmp.h /integer-gmp.buildinfo /mkGmpDerivedConstants/dist/ + +/gmp/gmp.h +/gmp/gmpbuild diff --git a/libraries/integer-gmp/integer-gmp.cabal b/libraries/integer-gmp/integer-gmp.cabal index c0f6b60aa4..376139f102 100644 --- a/libraries/integer-gmp/integer-gmp.cabal +++ b/libraries/integer-gmp/integer-gmp.cabal @@ -75,6 +75,6 @@ Library build-depends: ghc-prim >= 0.3.1 && < 0.4 - -- We need to set the package name to integer-gmp + -- We need to set the package key to integer-gmp -- (without a version number) as it's magic. - ghc-options: -Wall -package-name integer-gmp + ghc-options: -Wall -this-package-key integer-gmp diff --git a/libraries/integer-simple/integer-simple.cabal b/libraries/integer-simple/integer-simple.cabal index 51d3cc7b5b..d18a182012 100644 --- a/libraries/integer-simple/integer-simple.cabal +++ b/libraries/integer-simple/integer-simple.cabal @@ -28,4 +28,4 @@ Library UnliftedFFITypes, NoImplicitPrelude -- We need to set the package name to integer-simple -- (without a version number) as it's magic. - ghc-options: -package-name integer-simple -Wall + ghc-options: -this-package-key integer-simple -Wall diff --git a/libraries/template-haskell/template-haskell.cabal b/libraries/template-haskell/template-haskell.cabal index fb8dbd7ab0..db268be212 100644 --- a/libraries/template-haskell/template-haskell.cabal +++ b/libraries/template-haskell/template-haskell.cabal @@ -49,6 +49,6 @@ Library base == 4.7.*, pretty == 1.1.* - -- We need to set the package name to template-haskell (without a + -- We need to set the package key to template-haskell (without a -- version number) as it's magic. - ghc-options: -Wall -package-name template-haskell + ghc-options: -Wall -this-package-key template-haskell diff --git a/libraries/template-haskell/tests/.gitignore b/libraries/template-haskell/tests/.gitignore index ae0f7cb7ae..f847e98ada 100644 --- a/libraries/template-haskell/tests/.gitignore +++ b/libraries/template-haskell/tests/.gitignore @@ -1,2 +1,16 @@ -.hpc.dataToExpQUnit -dataToExpQUnit.comp.stderr +*.eventlog +*.genscript + +*.stderr.normalised +*.stdout.normalised +*.comp.stderr +*.comp.stdout +*.interp.stderr +*.interp.stdout +*.run.stderr +*.run.stdout + +.hpc.*/ +.hpc/ + +# specific files diff --git a/libraries/transformers b/libraries/transformers -Subproject 5df683cd87cb0ed13f915f73b83a7673e18aa29 +Subproject 87d9892a604b56d687ce70f1d1abc7848f78c6e diff --git a/libraries/unix b/libraries/unix -Subproject bc48ca82deb23f6985579b7a50d205632cfd5d4 +Subproject 54fbbdecb673705a67d5b9594503cf86d53265c diff --git a/mk/build.mk.sample b/mk/build.mk.sample index 3d47bbe82a..a323884334 100644 --- a/mk/build.mk.sample +++ b/mk/build.mk.sample @@ -66,6 +66,9 @@ V = 1 # working on stage 2 and want to freeze stage 1 and the libraries for # a while. +# Uncomment the following line to disable building DPH +#BUILD_DPH=NO + GhcLibWays = $(if $(filter $(DYNAMIC_GHC_PROGRAMS),YES),v dyn,v) # ----------- A Performance/Distribution build -------------------------------- diff --git a/mk/config.mk.in b/mk/config.mk.in index afe48ab5e1..7a73d4632a 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -790,6 +790,9 @@ else HSCOLOUR_SRCS = YES endif +# Build DPH? +BUILD_DPH = YES + ################################################################################ # # Library configure arguments diff --git a/nofib b/nofib -Subproject d98f7038d1111e515db9cc27d5d3bbe237e6e14 +Subproject 5bc1c75db2c74413959772c85d43f8171fdd7b8 @@ -69,9 +69,9 @@ libraries/old-time - - - libraries/pretty - - https://github.com/haskell/pretty.git libraries/process - - - libraries/terminfo - - https://github.com/judah/terminfo.git -libraries/time - - http://git.haskell.org/darcs-mirrors/time.git +libraries/time - - https://github.com/haskell/time.git libraries/transformers - - http://git.haskell.org/darcs-mirrors/transformers.git -libraries/unix - - - +libraries/unix - - ssh://git@github.com/haskell/unix.git libraries/Win32 - - https://github.com/haskell/win32.git libraries/xhtml - - https://github.com/haskell/xhtml.git nofib nofib - - diff --git a/rts/Adjustor.c b/rts/Adjustor.c index 83d5a73cf5..3c65da6784 100644 --- a/rts/Adjustor.c +++ b/rts/Adjustor.c @@ -1321,3 +1321,11 @@ freeHaskellFunctionPtr(void* ptr) } #endif // !USE_LIBFFI_FOR_ADJUSTORS + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Apply.h b/rts/Apply.h index 1c0b1623d9..4df567feee 100644 --- a/rts/Apply.h +++ b/rts/Apply.h @@ -24,3 +24,11 @@ extern RTS_PRIVATE StgFun *stg_stack_save_entries[]; #endif #endif /* APPLY_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Arena.c b/rts/Arena.c index 361c6c41be..92e479b89d 100644 --- a/rts/Arena.c +++ b/rts/Arena.c @@ -8,7 +8,7 @@ Do not assume that sequentially allocated objects will be adjacent in memory. - + Quirks: this allocator makes use of the RTS block allocator. If the current block doesn't have enough room for the requested object, then a new block is allocated. This means that allocating @@ -27,11 +27,11 @@ // Each arena struct is allocated using malloc(). struct _Arena { bdescr *current; - StgWord *free; // ptr to next free byte in current block - StgWord *lim; // limit (== last free byte + 1) + StgWord *free; // ptr to next free byte in current block + StgWord *lim; // limit (== last free byte + 1) }; -// We like to keep track of how many blocks we've allocated for +// We like to keep track of how many blocks we've allocated for // Storage.c:memInventory(). static long arena_blocks = 0; @@ -74,26 +74,26 @@ arenaAlloc( Arena *arena, size_t size ) size_w = B_TO_W(size); if ( arena->free + size_w < arena->lim ) { - // enough room in the current block... - p = arena->free; - arena->free += size_w; - return p; + // enough room in the current block... + p = arena->free; + arena->free += size_w; + return p; } else { - // allocate a fresh block... - req_blocks = (W_)BLOCK_ROUND_UP(size) / BLOCK_SIZE; - bd = allocGroup_lock(req_blocks); - arena_blocks += req_blocks; + // allocate a fresh block... + req_blocks = (W_)BLOCK_ROUND_UP(size) / BLOCK_SIZE; + bd = allocGroup_lock(req_blocks); + arena_blocks += req_blocks; - bd->gen_no = 0; - bd->gen = NULL; + bd->gen_no = 0; + bd->gen = NULL; bd->dest_no = 0; - bd->flags = 0; - bd->free = bd->start; - bd->link = arena->current; - arena->current = bd; - arena->free = bd->free + size_w; - arena->lim = bd->free + bd->blocks * BLOCK_SIZE_W; - return bd->start; + bd->flags = 0; + bd->free = bd->start; + bd->link = arena->current; + arena->current = bd; + arena->free = bd->free + size_w; + arena->lim = bd->free + bd->blocks * BLOCK_SIZE_W; + return bd->start; } } @@ -104,10 +104,10 @@ arenaFree( Arena *arena ) bdescr *bd, *next; for (bd = arena->current; bd != NULL; bd = next) { - next = bd->link; - arena_blocks -= bd->blocks; - ASSERT(arena_blocks >= 0); - freeGroup_lock(bd); + next = bd->link; + arena_blocks -= bd->blocks; + ASSERT(arena_blocks >= 0); + freeGroup_lock(bd); } stgFree(arena); } @@ -118,3 +118,10 @@ arenaBlocks( void ) return arena_blocks; } +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Arena.h b/rts/Arena.h index 086a0200ad..ac62c6cf38 100644 --- a/rts/Arena.h +++ b/rts/Arena.h @@ -23,3 +23,11 @@ RTS_PRIVATE void arenaFree ( Arena * ); RTS_PRIVATE unsigned long arenaBlocks( void ); #endif /* ARENA_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/AutoApply.h b/rts/AutoApply.h index f64bc6d894..ee756be02b 100644 --- a/rts/AutoApply.h +++ b/rts/AutoApply.h @@ -89,3 +89,11 @@ #endif /* APPLY_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/AwaitEvent.h b/rts/AwaitEvent.h index ecc13b8ff2..e80d351ab4 100644 --- a/rts/AwaitEvent.h +++ b/rts/AwaitEvent.h @@ -22,3 +22,11 @@ RTS_PRIVATE void awaitEvent(rtsBool wait); /* In posix/Select.c or #endif #endif /* AWAITEVENT_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/BeginPrivate.h b/rts/BeginPrivate.h index 6471b92a40..f7b7d198f0 100644 --- a/rts/BeginPrivate.h +++ b/rts/BeginPrivate.h @@ -8,3 +8,11 @@ #if defined(HAS_VISIBILITY_HIDDEN) && !defined(freebsd_HOST_OS) #pragma GCC visibility push(hidden) #endif + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Capability.c b/rts/Capability.c index 805a35be9f..29c5270416 100644 --- a/rts/Capability.c +++ b/rts/Capability.c @@ -1075,3 +1075,11 @@ rtsBool checkSparkCountInvariant (void) } #endif + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Capability.h b/rts/Capability.h index d36d50293a..c7dceefe9f 100644 --- a/rts/Capability.h +++ b/rts/Capability.h @@ -426,3 +426,11 @@ INLINE_HEADER rtsBool emptyInbox(Capability *cap) #include "EndPrivate.h" #endif /* CAPABILITY_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/CheckUnload.c b/rts/CheckUnload.c index 98f184b84c..170e8861f0 100644 --- a/rts/CheckUnload.c +++ b/rts/CheckUnload.c @@ -318,3 +318,11 @@ void checkUnload (StgClosure *static_objects) freeHashTable(addrs, NULL); } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/CheckUnload.h b/rts/CheckUnload.h index 7d2e5b1321..9c2bac89f1 100644 --- a/rts/CheckUnload.h +++ b/rts/CheckUnload.h @@ -18,3 +18,11 @@ void checkUnload (StgClosure *static_objects); #include "EndPrivate.h" #endif // CHECKUNLOAD_H + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/ClosureFlags.c b/rts/ClosureFlags.c index c43437dc04..def33eb9a9 100644 --- a/rts/ClosureFlags.c +++ b/rts/ClosureFlags.c @@ -91,3 +91,11 @@ StgWord16 closure_flags[] = { #if N_CLOSURE_TYPES != 65 #error Closure types changed: update ClosureFlags.c! #endif + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Disassembler.c b/rts/Disassembler.c index 44f487da89..36cd7b5595 100644 --- a/rts/Disassembler.c +++ b/rts/Disassembler.c @@ -316,3 +316,11 @@ void disassemble( StgBCO *bco ) } #endif /* DEBUG */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Disassembler.h b/rts/Disassembler.h index c6f71564c4..277361bc6b 100644 --- a/rts/Disassembler.h +++ b/rts/Disassembler.h @@ -17,3 +17,11 @@ RTS_PRIVATE void disassemble( StgBCO *bco ); #endif #endif /* DISASSEMBLER_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/EndPrivate.h b/rts/EndPrivate.h index 4cfb68f0ba..61d56fb3e1 100644 --- a/rts/EndPrivate.h +++ b/rts/EndPrivate.h @@ -1,3 +1,11 @@ #if defined(HAS_VISIBILITY_HIDDEN) && !defined(freebsd_HOST_OS) #pragma GCC visibility pop #endif + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/FileLock.c b/rts/FileLock.c index 44ff67140c..8a8dc86b28 100644 --- a/rts/FileLock.c +++ b/rts/FileLock.c @@ -5,7 +5,7 @@ * File locking support as required by Haskell * * ---------------------------------------------------------------------------*/ - + #include "PosixSource.h" #include "Rts.h" @@ -44,8 +44,9 @@ static int cmpLocks(StgWord w1, StgWord w2) static int hashLock(HashTable *table, StgWord w) { Lock *l = (Lock *)w; + StgWord key = l->inode ^ (l->inode >> 32) ^ l->device ^ (l->device >> 32); // Just xor all 32-bit words of inode and device, hope this is good enough. - return hashWord(table, l->inode ^ (l->inode >> 32) ^ l->device ^ (l->device >> 32)); + return hashWord(table, key); } void @@ -120,7 +121,7 @@ unlockFile(int fd) lock = lookupHashTable(fd_hash, fd); if (lock == NULL) { - // errorBelch("unlockFile: fd %d not found", fd); + // errorBelch("unlockFile: fd %d not found", fd); // This is normal: we didn't know when calling unlockFile // whether this FD referred to a locked file or not. RELEASE_LOCK(&file_lock_mutex); @@ -142,3 +143,11 @@ unlockFile(int fd) RELEASE_LOCK(&file_lock_mutex); return 0; } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/FileLock.h b/rts/FileLock.h index 72ab170437..fe9c52a574 100644 --- a/rts/FileLock.h +++ b/rts/FileLock.h @@ -13,3 +13,11 @@ RTS_PRIVATE void initFileLocking(void); RTS_PRIVATE void freeFileLocking(void); #endif /* POSIX_FILELOCK_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/GetEnv.h b/rts/GetEnv.h index 5e3d0cf184..497fcc9712 100644 --- a/rts/GetEnv.h +++ b/rts/GetEnv.h @@ -21,3 +21,11 @@ void freeProgEnvv (int envc, char *envv[]); #include "EndPrivate.h" #endif /* GETENV_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/GetTime.h b/rts/GetTime.h index 32c3754829..8e293a8d22 100644 --- a/rts/GetTime.h +++ b/rts/GetTime.h @@ -29,3 +29,11 @@ W_ getPageFaults (void); #include "EndPrivate.h" #endif /* GETTIME_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Globals.c b/rts/Globals.c index 2e4b99474f..d839e44f4a 100644 --- a/rts/Globals.c +++ b/rts/Globals.c @@ -140,3 +140,11 @@ getOrSetLibHSghcFastStringTable(StgStablePtr ptr) { return getOrSetKey(LibHSghcFastStringTable,ptr); } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Globals.h b/rts/Globals.h index 445072ca34..ee62f2f7c1 100644 --- a/rts/Globals.h +++ b/rts/Globals.h @@ -17,3 +17,10 @@ RTS_PRIVATE void exitGlobalStore(void); #endif +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Hash.c b/rts/Hash.c index 9ab8ffb53e..1c5897cb72 100644 --- a/rts/Hash.c +++ b/rts/Hash.c @@ -17,13 +17,13 @@ #include <string.h> #define HSEGSIZE 1024 /* Size of a single hash table segment */ - /* Also the minimum size of a hash table */ + /* Also the minimum size of a hash table */ #define HDIRSIZE 1024 /* Size of the segment directory */ - /* Maximum hash table size is HSEGSIZE * HDIRSIZE */ -#define HLOAD 5 /* Maximum average load of a single hash bucket */ + /* Maximum hash table size is HSEGSIZE * HDIRSIZE */ +#define HLOAD 5 /* Maximum average load of a single hash bucket */ -#define HCHUNK (1024 * sizeof(W_) / sizeof(HashList)) - /* Number of HashList cells to allocate in one go */ +#define HCHUNK (1024 * sizeof(W_) / sizeof(HashList)) + /* Number of HashList cells to allocate in one go */ /* Linked list of (key, data) pairs for separate chaining */ @@ -39,13 +39,13 @@ typedef struct chunklist { } HashListChunk; struct hashtable { - int split; /* Next bucket to split when expanding */ - int max; /* Max bucket of smaller table */ - int mask1; /* Mask for doing the mod of h_1 (smaller table) */ - int mask2; /* Mask for doing the mod of h_2 (larger table) */ - int kcount; /* Number of keys */ - int bcount; /* Number of buckets */ - HashList **dir[HDIRSIZE]; /* Directory of segments */ + int split; /* Next bucket to split when expanding */ + int max; /* Max bucket of smaller table */ + int mask1; /* Mask for doing the mod of h_1 (smaller table) */ + int mask2; /* Mask for doing the mod of h_2 (larger table) */ + int kcount; /* Number of keys */ + int bcount; /* Number of buckets */ + HashList **dir[HDIRSIZE]; /* Directory of segments */ HashList *freeList; /* free list of HashLists */ HashListChunk *chunks; HashFunction *hash; /* hash function */ @@ -69,8 +69,8 @@ hashWord(HashTable *table, StgWord key) bucket = key & table->mask1; if (bucket < table->split) { - /* Mod the size of the expanded hash table (also a power of 2) */ - bucket = key & table->mask2; + /* Mod the size of the expanded hash table (also a power of 2) */ + bucket = key & table->mask2; } return bucket; } @@ -83,17 +83,17 @@ hashStr(HashTable *table, char *key) s = key; for (h=0; *s; s++) { - h *= 128; - h += *s; - h = h % 1048583; /* some random large prime */ + h *= 128; + h += *s; + h = h % 1048583; /* some random large prime */ } /* Mod the size of the hash table (a power of 2) */ bucket = h & table->mask1; if (bucket < table->split) { - /* Mod the size of the expanded hash table (also a power of 2) */ - bucket = h & table->mask2; + /* Mod the size of the expanded hash table (also a power of 2) */ + bucket = h & table->mask2; } return bucket; @@ -119,8 +119,8 @@ compareStr(StgWord key1, StgWord key2) static void allocSegment(HashTable *table, int segment) { - table->dir[segment] = stgMallocBytes(HSEGSIZE * sizeof(HashList *), - "allocSegment"); + table->dir[segment] = stgMallocBytes(HSEGSIZE * sizeof(HashList *), + "allocSegment"); } @@ -143,8 +143,8 @@ expand(HashTable *table) HashList *old, *new; if (table->split + table->max >= HDIRSIZE * HSEGSIZE) - /* Wow! That's big. Too big, so don't expand. */ - return; + /* Wow! That's big. Too big, so don't expand. */ + return; /* Calculate indices of bucket to split */ oldsegment = table->split / HSEGSIZE; @@ -157,13 +157,13 @@ expand(HashTable *table) newindex = newbucket % HSEGSIZE; if (newindex == 0) - allocSegment(table, newsegment); + allocSegment(table, newsegment); if (++table->split == table->max) { - table->split = 0; - table->max *= 2; - table->mask1 = table->mask2; - table->mask2 = table->mask2 << 1 | 1; + table->split = 0; + table->max *= 2; + table->mask1 = table->mask2; + table->mask2 = table->mask2 << 1 | 1; } table->bcount++; @@ -171,14 +171,14 @@ expand(HashTable *table) old = new = NULL; for (hl = table->dir[oldsegment][oldindex]; hl != NULL; hl = next) { - next = hl->next; - if (table->hash(table, hl->key) == newbucket) { - hl->next = new; - new = hl; - } else { - hl->next = old; - old = hl; - } + next = hl->next; + if (table->hash(table, hl->key) == newbucket) { + hl->next = new; + new = hl; + } else { + hl->next = old; + old = hl; + } } table->dir[oldsegment][oldindex] = old; table->dir[newsegment][newindex] = new; @@ -199,8 +199,8 @@ lookupHashTable(HashTable *table, StgWord key) index = bucket % HSEGSIZE; for (hl = table->dir[segment][index]; hl != NULL; hl = hl->next) - if (table->compare(hl->key, key)) - return hl->data; + if (table->compare(hl->key, key)) + return hl->data; /* It's not there */ return NULL; @@ -222,15 +222,15 @@ allocHashList (HashTable *table) table->freeList = hl->next; } else { hl = stgMallocBytes(HCHUNK * sizeof(HashList), "allocHashList"); - cl = stgMallocBytes(sizeof (*cl), "allocHashList: chunkList"); + cl = stgMallocBytes(sizeof (*cl), "allocHashList: chunkList"); cl->chunk = hl; cl->next = table->chunks; table->chunks = cl; table->freeList = hl + 1; for (p = table->freeList; p < hl + HCHUNK - 1; p++) - p->next = p + 1; - p->next = NULL; + p->next = p + 1; + p->next = NULL; } return hl; } @@ -256,7 +256,7 @@ insertHashTable(HashTable *table, StgWord key, void *data) /* When the average load gets too high, we expand the table */ if (++table->kcount >= HLOAD * table->bcount) - expand(table); + expand(table); bucket = table->hash(table, key); segment = bucket / HSEGSIZE; @@ -285,16 +285,16 @@ removeHashTable(HashTable *table, StgWord key, void *data) index = bucket % HSEGSIZE; for (hl = table->dir[segment][index]; hl != NULL; hl = hl->next) { - if (table->compare(hl->key,key) && (data == NULL || hl->data == data)) { - if (prev == NULL) - table->dir[segment][index] = hl->next; - else - prev->next = hl->next; + if (table->compare(hl->key,key) && (data == NULL || hl->data == data)) { + if (prev == NULL) + table->dir[segment][index] = hl->next; + else + prev->next = hl->next; freeHashList(table,hl); - table->kcount--; - return hl->data; - } - prev = hl; + table->kcount--; + return hl->data; + } + prev = hl; } /* It's not there */ @@ -322,17 +322,17 @@ freeHashTable(HashTable *table, void (*freeDataFun)(void *) ) index = (table->max + table->split - 1) % HSEGSIZE; while (segment >= 0) { - while (index >= 0) { - for (hl = table->dir[segment][index]; hl != NULL; hl = next) { - next = hl->next; - if (freeDataFun != NULL) - (*freeDataFun)(hl->data); + while (index >= 0) { + for (hl = table->dir[segment][index]; hl != NULL; hl = next) { + next = hl->next; + if (freeDataFun != NULL) + (*freeDataFun)(hl->data); } - index--; - } - stgFree(table->dir[segment]); - segment--; - index = HSEGSIZE - 1; + index--; + } + stgFree(table->dir[segment]); + segment--; + index = HSEGSIZE - 1; } for (cl = table->chunks; cl != NULL; cl = cl_next) { cl_next = cl->next; @@ -358,7 +358,7 @@ allocHashTable_(HashFunction *hash, CompareFunction *compare) allocSegment(table, 0); for (hb = table->dir[0]; hb < table->dir[0] + HSEGSIZE; hb++) - *hb = NULL; + *hb = NULL; table->split = 0; table->max = HSEGSIZE; @@ -383,8 +383,8 @@ allocHashTable(void) HashTable * allocStrHashTable(void) { - return allocHashTable_((HashFunction *)hashStr, - (CompareFunction *)compareStr); + return allocHashTable_((HashFunction *)hashStr, + (CompareFunction *)compareStr); } void @@ -397,3 +397,11 @@ int keyCountHashTable (HashTable *table) { return table->kcount; } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Hash.h b/rts/Hash.h index d22caba555..167000c336 100644 --- a/rts/Hash.h +++ b/rts/Hash.h @@ -52,3 +52,11 @@ void exitHashTable ( void ); #include "EndPrivate.h" #endif /* HASH_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/HeapStackCheck.cmm b/rts/HeapStackCheck.cmm index 12bcfb26df..f090bff5ad 100644 --- a/rts/HeapStackCheck.cmm +++ b/rts/HeapStackCheck.cmm @@ -681,13 +681,24 @@ stg_block_async_void STM-specific waiting -------------------------------------------------------------------------- */ -stg_block_stmwait_finally -{ - ccall stmWaitUnlock(MyCapability() "ptr", R3 "ptr"); - jump StgReturn [R1]; -} - stg_block_stmwait { - BLOCK_BUT_FIRST(stg_block_stmwait_finally); + // When blocking on an MVar we have to be careful to only release + // the lock on the MVar at the very last moment (using + // BLOCK_BUT_FIRST()), since when we release the lock another + // Capability can wake up the thread, which modifies its stack and + // other state. This is not a problem for STM, because STM + // wakeups are non-destructive; the waker simply calls + // tryWakeupThread() which sends a message to the owner + // Capability. So the moment we release this lock we might start + // getting wakeup messages, but that's perfectly harmless. + // + // Furthermore, we *must* release these locks, just in case an + // exception is raised in this thread by + // maybePerformBlockedException() while exiting to the scheduler, + // which will abort the transaction, which needs to obtain a lock + // on all the TVars to remove the thread from the queues. + // + ccall stmWaitUnlock(MyCapability() "ptr", R3 "ptr"); + BLOCK_GENERIC; } @@ -404,3 +404,11 @@ exitHpc(void) { HpcModuleInfo *hs_hpc_rootModule(void) { return modules; } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/HsFFI.c b/rts/HsFFI.c index 8fae246111..d1c0964d7a 100644 --- a/rts/HsFFI.c +++ b/rts/HsFFI.c @@ -66,3 +66,11 @@ hs_thread_done(void) { freeMyTask(); } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Inlines.c b/rts/Inlines.c index e6f29b6e1b..3810e4d5a2 100644 --- a/rts/Inlines.c +++ b/rts/Inlines.c @@ -7,3 +7,11 @@ #include "Schedule.h" #include "Capability.h" #include "WSDeque.h" + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Interpreter.c b/rts/Interpreter.c index f4fe816d28..f3a5c783cd 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -1516,3 +1516,11 @@ run_BCO: barf("interpretBCO: fell off end of the interpreter"); } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Interpreter.h b/rts/Interpreter.h index fd4f7b98c3..b95c61af74 100644 --- a/rts/Interpreter.h +++ b/rts/Interpreter.h @@ -12,3 +12,11 @@ RTS_PRIVATE Capability *interpretBCO (Capability* cap); #endif /* INTERPRETER_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/LdvProfile.c b/rts/LdvProfile.c index 4530969123..677263efbe 100644 --- a/rts/LdvProfile.c +++ b/rts/LdvProfile.c @@ -249,3 +249,11 @@ LdvCensusKillAll( void ) } #endif /* PROFILING */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/LdvProfile.h b/rts/LdvProfile.h index b4418046ba..8f633225b9 100644 --- a/rts/LdvProfile.h +++ b/rts/LdvProfile.h @@ -39,3 +39,11 @@ RTS_PRIVATE void LdvCensusKillAll ( void ); #endif /* PROFILING */ #endif /* LDVPROFILE_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Linker.c b/rts/Linker.c index f7f554ce6c..480dc2a967 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -1186,7 +1186,6 @@ typedef struct _RtsSymbolVal { SymI_HasProto(stg_newBCOzh) \ SymI_HasProto(stg_newByteArrayzh) \ SymI_HasProto(stg_casIntArrayzh) \ - SymI_HasProto(stg_fetchAddIntArrayzh) \ SymI_HasProto(stg_newMVarzh) \ SymI_HasProto(stg_newMutVarzh) \ SymI_HasProto(stg_newTVarzh) \ @@ -1798,7 +1797,7 @@ internal_dlopen(const char *dll_name) // (see POSIX also) ACQUIRE_LOCK(&dl_mutex); - hdl = dlopen(dll_name, RTLD_LAZY|RTLD_LOCAL); /* see Note [RTLD_LOCAL] */ + hdl = dlopen(dll_name, RTLD_LAZY | RTLD_GLOBAL); errmsg = NULL; if (hdl == NULL) { @@ -1808,12 +1807,11 @@ internal_dlopen(const char *dll_name) errmsg_copy = stgMallocBytes(strlen(errmsg)+1, "addDLL"); strcpy(errmsg_copy, errmsg); errmsg = errmsg_copy; - } else { - o_so = stgMallocBytes(sizeof(OpenedSO), "addDLL"); - o_so->handle = hdl; - o_so->next = openedSOs; - openedSOs = o_so; } + o_so = stgMallocBytes(sizeof(OpenedSO), "addDLL"); + o_so->handle = hdl; + o_so->next = openedSOs; + openedSOs = o_so; RELEASE_LOCK(&dl_mutex); //--------------- End critical section ------------------- @@ -1821,39 +1819,14 @@ internal_dlopen(const char *dll_name) return errmsg; } -/* - Note [RTLD_LOCAL] - - In GHCi we want to be able to override previous .so's with newly - loaded .so's when we recompile something. This further implies that - when we look up a symbol in internal_dlsym() we have to iterate - through the loaded libraries (in order from most recently loaded to - oldest) looking up the symbol in each one until we find it. - - However, this can cause problems for some symbols that are copied - by the linker into the executable image at runtime - see #8935 for a - lengthy discussion. To solve that problem we need to look up - symbols in the main executable *first*, before attempting to look - them up in the loaded .so's. But in order to make that work, we - have to always call dlopen with RTLD_LOCAL, so that the loaded - libraries don't populate the global symbol table. -*/ - static void * -internal_dlsym(const char *symbol) { +internal_dlsym(void *hdl, const char *symbol) { OpenedSO* o_so; void *v; // We acquire dl_mutex as concurrent dl* calls may alter dlerror ACQUIRE_LOCK(&dl_mutex); dlerror(); - // look in program first - v = dlsym(dl_prog_handle, symbol); - if (dlerror() == NULL) { - RELEASE_LOCK(&dl_mutex); - return v; - } - for (o_so = openedSOs; o_so != NULL; o_so = o_so->next) { v = dlsym(o_so->handle, symbol); if (dlerror() == NULL) { @@ -1861,6 +1834,7 @@ internal_dlsym(const char *symbol) { return v; } } + v = dlsym(hdl, symbol); RELEASE_LOCK(&dl_mutex); return v; } @@ -2028,7 +2002,7 @@ lookupSymbol( char *lbl ) if (!ghciLookupSymbolTable(symhash, lbl, &val)) { IF_DEBUG(linker, debugBelch("lookupSymbol: symbol not found\n")); # if defined(OBJFORMAT_ELF) - return internal_dlsym(lbl); + return internal_dlsym(dl_prog_handle, lbl); # elif defined(OBJFORMAT_MACHO) # if HAVE_DLFCN_H /* On OS X 10.3 and later, we use dlsym instead of the old legacy @@ -2042,7 +2016,7 @@ lookupSymbol( char *lbl ) */ IF_DEBUG(linker, debugBelch("lookupSymbol: looking up %s with dlsym\n", lbl)); ASSERT(lbl[0] == '_'); - return internal_dlsym(lbl + 1); + return internal_dlsym(dl_prog_handle, lbl + 1); # else if (NSIsSymbolNameDefined(lbl)) { NSSymbol symbol = NSLookupAndBindSymbol(lbl); @@ -7189,3 +7163,11 @@ machoGetMisalignment( FILE * f ) #endif #endif + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/LinkerInternals.h b/rts/LinkerInternals.h index e1942bc8ae..1a203ded7e 100644 --- a/rts/LinkerInternals.h +++ b/rts/LinkerInternals.h @@ -149,3 +149,11 @@ void exitLinker( void ); void freeObjectCode (ObjectCode *oc); #endif /* LINKERINTERNALS_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Messages.c b/rts/Messages.c index c5988f8b25..2f03ae60c0 100644 --- a/rts/Messages.c +++ b/rts/Messages.c @@ -25,7 +25,7 @@ void sendMessage(Capability *from_cap, Capability *to_cap, Message *msg) { ACQUIRE_LOCK(&to_cap->lock); -#ifdef DEBUG +#ifdef DEBUG { const StgInfoTable *i = msg->header.info; if (i != &stg_MSG_THROWTO_info && @@ -44,7 +44,7 @@ void sendMessage(Capability *from_cap, Capability *to_cap, Message *msg) recordClosureMutated(from_cap,(StgClosure*)msg); if (to_cap->running_task == NULL) { - to_cap->running_task = myTask(); + to_cap->running_task = myTask(); // precond for releaseCapability_() releaseCapability_(to_cap,rtsFalse); } else { @@ -73,7 +73,7 @@ loop: if (i == &stg_MSG_TRY_WAKEUP_info) { StgTSO *tso = ((MessageWakeup *)m)->tso; - debugTraceCap(DEBUG_sched, cap, "message: try wakeup thread %ld", + debugTraceCap(DEBUG_sched, cap, "message: try wakeup thread %ld", (W_)tso->id); tryWakeupThread(cap, tso); } @@ -89,7 +89,7 @@ loop: goto loop; } - debugTraceCap(DEBUG_sched, cap, "message: throwTo %ld -> %ld", + debugTraceCap(DEBUG_sched, cap, "message: throwTo %ld -> %ld", (W_)t->source->id, (W_)t->target->id); ASSERT(t->source->why_blocked == BlockedOnMsgThrowTo); @@ -144,10 +144,10 @@ loop: This is called from two places: either we just entered a BLACKHOLE (stg_BLACKHOLE_info), or we received a MSG_BLACKHOLE in our - cap->inbox. + cap->inbox. We need to establish whether the BLACKHOLE belongs to - this Capability, and + this Capability, and - if so, arrange to block the current thread on it - otherwise, forward the message to the right place @@ -166,8 +166,8 @@ nat messageBlackHole(Capability *cap, MessageBlackHole *msg) StgClosure *bh = UNTAG_CLOSURE(msg->bh); StgTSO *owner; - debugTraceCap(DEBUG_sched, cap, "message: thread %d blocking on blackhole %p", - (W_)msg->tso->id, msg->bh); + debugTraceCap(DEBUG_sched, cap, "message: thread %d blocking on " + "blackhole %p", (W_)msg->tso->id, msg->bh); info = bh->header.info; @@ -175,8 +175,8 @@ nat messageBlackHole(Capability *cap, MessageBlackHole *msg) // BLACKHOLE has already been updated, and GC has shorted out the // indirection, so the pointer no longer points to a BLACKHOLE at // all. - if (info != &stg_BLACKHOLE_info && - info != &stg_CAF_BLACKHOLE_info && + if (info != &stg_BLACKHOLE_info && + info != &stg_CAF_BLACKHOLE_info && info != &__stg_EAGER_BLACKHOLE_info && info != &stg_WHITEHOLE_info) { // if it is a WHITEHOLE, then a thread is in the process of @@ -210,7 +210,8 @@ loop: #ifdef THREADED_RTS if (owner->cap != cap) { sendMessage(cap, owner->cap, (Message*)msg); - debugTraceCap(DEBUG_sched, cap, "forwarding message to cap %d", owner->cap->no); + debugTraceCap(DEBUG_sched, cap, "forwarding message to cap %d", + owner->cap->no); return 1; } #endif @@ -219,15 +220,15 @@ loop: // BLACKHOLE, so we first create a BLOCKING_QUEUE object. bq = (StgBlockingQueue*)allocate(cap, sizeofW(StgBlockingQueue)); - + // initialise the BLOCKING_QUEUE object SET_HDR(bq, &stg_BLOCKING_QUEUE_DIRTY_info, CCS_SYSTEM); bq->bh = bh; bq->queue = msg; bq->owner = owner; - + msg->link = (MessageBlackHole*)END_TSO_QUEUE; - + // All BLOCKING_QUEUES are linked in a list on owner->bq, so // that we can search through them in the event that there is // a collision to update a BLACKHOLE and a BLOCKING_QUEUE @@ -254,12 +255,12 @@ loop: ((StgInd*)bh)->indirectee = (StgClosure *)bq; recordClosureMutated(cap,bh); // bh was mutated - debugTraceCap(DEBUG_sched, cap, "thread %d blocked on thread %d", + debugTraceCap(DEBUG_sched, cap, "thread %d blocked on thread %d", (W_)msg->tso->id, (W_)owner->id); return 1; // blocked } - else if (info == &stg_BLOCKING_QUEUE_CLEAN_info || + else if (info == &stg_BLOCKING_QUEUE_CLEAN_info || info == &stg_BLOCKING_QUEUE_DIRTY_info) { StgBlockingQueue *bq = (StgBlockingQueue *)p; @@ -273,7 +274,8 @@ loop: #ifdef THREADED_RTS if (owner->cap != cap) { sendMessage(cap, owner->cap, (Message*)msg); - debugTraceCap(DEBUG_sched, cap, "forwarding message to cap %d", owner->cap->no); + debugTraceCap(DEBUG_sched, cap, "forwarding message to cap %d", + owner->cap->no); return 1; } #endif @@ -287,7 +289,7 @@ loop: recordClosureMutated(cap,(StgClosure*)bq); } - debugTraceCap(DEBUG_sched, cap, "thread %d blocked on thread %d", + debugTraceCap(DEBUG_sched, cap, "thread %d blocked on thread %d", (W_)msg->tso->id, (W_)owner->id); // See above, #3838 @@ -297,7 +299,7 @@ loop: return 1; // blocked } - + return 0; // not blocked } @@ -313,7 +315,7 @@ StgTSO * blackHoleOwner (StgClosure *bh) info = bh->header.info; if (info != &stg_BLACKHOLE_info && - info != &stg_CAF_BLACKHOLE_info && + info != &stg_CAF_BLACKHOLE_info && info != &__stg_EAGER_BLACKHOLE_info && info != &stg_WHITEHOLE_info) { return NULL; @@ -333,14 +335,20 @@ loop: { return (StgTSO*)p; } - else if (info == &stg_BLOCKING_QUEUE_CLEAN_info || + else if (info == &stg_BLOCKING_QUEUE_CLEAN_info || info == &stg_BLOCKING_QUEUE_DIRTY_info) { StgBlockingQueue *bq = (StgBlockingQueue *)p; return bq->owner; } - + return NULL; // not blocked } - +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Messages.h b/rts/Messages.h index 4121364b21..c965511abf 100644 --- a/rts/Messages.h +++ b/rts/Messages.h @@ -28,3 +28,11 @@ doneWithMsgThrowTo (MessageThrowTo *m) } #include "EndPrivate.h" + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/OldARMAtomic.c b/rts/OldARMAtomic.c index b2c52fc1da..949e72b041 100644 --- a/rts/OldARMAtomic.c +++ b/rts/OldARMAtomic.c @@ -48,9 +48,16 @@ void arm_atomic_spin_lock() void arm_atomic_spin_unlock() { atomic_spin = 0; -} +} #endif /* arm_HOST_ARCH && defined(arm_HOST_ARCH_PRE_ARMv6) */ #endif /* defined(THREADED_RTS) */ +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Papi.c b/rts/Papi.c index 62f5d0d396..39b9ee75f1 100644 --- a/rts/Papi.c +++ b/rts/Papi.c @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- * (c) The GHC Team 2006 - * + * * Initialization and use of the PAPI performance monitoring library * * @@ -61,10 +61,11 @@ struct _papi_events { #define BIG_STRING_LEN 512 -#define PAPI_CHECK(CALL) \ - if((papi_error=(CALL)) != PAPI_OK) { \ - debugBelch("PAPI function failed in module %s at line %d with error code %d\n", \ - __FILE__,__LINE__,papi_error); \ +#define PAPI_CHECK(CALL) \ + if((papi_error=(CALL)) != PAPI_OK) { \ + debugBelch("PAPI function failed in module %s at line %d " \ + "with error code %d\n", \ + __FILE__,__LINE__,papi_error); \ } /* While PAPI reporting is going on this flag is on */ @@ -113,41 +114,42 @@ static nat max_hardware_counters = 2; static void papi_add_event(const char *name, int code) { if (n_papi_events >= max_hardware_counters) { - errorBelch("too many PAPI events for this CPU (max: %d)", + errorBelch("too many PAPI events for this CPU (max: %d)", max_hardware_counters); stg_exit(EXIT_FAILURE); } papi_events[n_papi_events].event_code = code; papi_events[n_papi_events].event_name = name; n_papi_events++; -} +} static void -init_countable_events(void) +init_countable_events(void) { max_hardware_counters = PAPI_num_counters(); #define PAPI_ADD_EVENT(EVENT) papi_add_event(#EVENT,EVENT) if (RtsFlags.PapiFlags.eventType==PAPI_FLAG_BRANCH) { - PAPI_ADD_EVENT(FR_BR); - PAPI_ADD_EVENT(FR_BR_MIS); - /* Docs are wrong? Opteron does not count indirect branch misses exclusively */ - PAPI_ADD_EVENT(FR_BR_MISCOMPARE); + PAPI_ADD_EVENT(FR_BR); + PAPI_ADD_EVENT(FR_BR_MIS); + // Docs are wrong? Opteron does not count indirect branch + // misses exclusively + PAPI_ADD_EVENT(FR_BR_MISCOMPARE); } else if (RtsFlags.PapiFlags.eventType==PAPI_FLAG_STALLS) { - PAPI_ADD_EVENT(FR_DISPATCH_STALLS); - PAPI_ADD_EVENT(FR_DISPATCH_STALLS_BR); - PAPI_ADD_EVENT(FR_DISPATCH_STALLS_FULL_LS); + PAPI_ADD_EVENT(FR_DISPATCH_STALLS); + PAPI_ADD_EVENT(FR_DISPATCH_STALLS_BR); + PAPI_ADD_EVENT(FR_DISPATCH_STALLS_FULL_LS); } else if (RtsFlags.PapiFlags.eventType==PAPI_FLAG_CACHE_L1) { - PAPI_ADD_EVENT(PAPI_L1_DCA); - PAPI_ADD_EVENT(PAPI_L1_DCM); + PAPI_ADD_EVENT(PAPI_L1_DCA); + PAPI_ADD_EVENT(PAPI_L1_DCM); } else if (RtsFlags.PapiFlags.eventType==PAPI_FLAG_CACHE_L2) { - PAPI_ADD_EVENT(PAPI_L2_DCA); - PAPI_ADD_EVENT(PAPI_L2_DCM); + PAPI_ADD_EVENT(PAPI_L2_DCA); + PAPI_ADD_EVENT(PAPI_L2_DCM); } else if (RtsFlags.PapiFlags.eventType==PAPI_FLAG_CB_EVENTS) { - PAPI_ADD_EVENT(DC_L2_REFILL_MOES); - PAPI_ADD_EVENT(DC_SYS_REFILL_MOES); - PAPI_ADD_EVENT(FR_BR_MIS); + PAPI_ADD_EVENT(DC_L2_REFILL_MOES); + PAPI_ADD_EVENT(DC_SYS_REFILL_MOES); + PAPI_ADD_EVENT(FR_BR_MIS); } else if (RtsFlags.PapiFlags.eventType==PAPI_USER_EVENTS) { nat i; char *name; @@ -167,25 +169,25 @@ init_countable_events(void) papi_add_event(name, code); } } else { - // PAPI_ADD_EVENT(PAPI_L1_DCA); // L1 data cache accesses - // PAPI_ADD_EVENT(PAPI_L1_ICR); // L1 instruction cache reads - // PAPI_ADD_EVENT(PAPI_L1_ICM); // L1 instruction cache misses - // PAPI_ADD_EVENT(PAPI_L1_STM); // L1 store misses - // PAPI_ADD_EVENT(PAPI_L1_DCM); // L1 data cache misses - // PAPI_ADD_EVENT(PAPI_L1_LDM); // L1 load misses - // PAPI_ADD_EVENT(PAPI_L2_TCM); // L2 cache misses - // PAPI_ADD_EVENT(PAPI_L2_STM); // L2 store misses - // PAPI_ADD_EVENT(PAPI_L2_DCW); // L2 data cache writes - // PAPI_ADD_EVENT(PAPI_L2_DCR); // L2 data cache reads - // PAPI_ADD_EVENT(PAPI_L2_TCW); // L2 cache writes - // PAPI_ADD_EVENT(PAPI_L2_TCR); // L2 cache reads - // PAPI_ADD_EVENT(PAPI_CA_CLN); // exclusive access to clean cache line - // PAPI_ADD_EVENT(PAPI_TLB_DM); // TLB misses + // PAPI_ADD_EVENT(PAPI_L1_DCA); // L1 data cache accesses + // PAPI_ADD_EVENT(PAPI_L1_ICR); // L1 instruction cache reads + // PAPI_ADD_EVENT(PAPI_L1_ICM); // L1 instruction cache misses + // PAPI_ADD_EVENT(PAPI_L1_STM); // L1 store misses + // PAPI_ADD_EVENT(PAPI_L1_DCM); // L1 data cache misses + // PAPI_ADD_EVENT(PAPI_L1_LDM); // L1 load misses + // PAPI_ADD_EVENT(PAPI_L2_TCM); // L2 cache misses + // PAPI_ADD_EVENT(PAPI_L2_STM); // L2 store misses + // PAPI_ADD_EVENT(PAPI_L2_DCW); // L2 data cache writes + // PAPI_ADD_EVENT(PAPI_L2_DCR); // L2 data cache reads + // PAPI_ADD_EVENT(PAPI_L2_TCW); // L2 cache writes + // PAPI_ADD_EVENT(PAPI_L2_TCR); // L2 cache reads + // PAPI_ADD_EVENT(PAPI_CA_CLN); // exclusive access to clean cache line + // PAPI_ADD_EVENT(PAPI_TLB_DM); // TLB misses PAPI_ADD_EVENT(PAPI_TOT_INS); // Total instructions PAPI_ADD_EVENT(PAPI_TOT_CYC); // Total instructions - // PAPI_ADD_EVENT(PAPI_CA_SHR); // exclusive access to shared cache line - // PAPI_ADD_EVENT(PAPI_RES_STL); // Cycles stalled on any resource - + // PAPI_ADD_EVENT(PAPI_CA_SHR); // exclusive access to shared cache line + // PAPI_ADD_EVENT(PAPI_RES_STL); // Cycles stalled on any resource + } // We might also consider: @@ -198,7 +200,7 @@ static void papi_report_event(const char *name, StgWord64 value) { static char temp[BIG_STRING_LEN]; - showStgWord64(value,temp,rtsTrue/*commas*/); + showStgWord64(value,temp,rtsTrue/*commas*/); statsPrintf(" %15s %15s\n", name, temp); } @@ -219,16 +221,16 @@ papi_report(long_long counters[]) } if (RtsFlags.PapiFlags.eventType==PAPI_FLAG_BRANCH) { - PAPI_REPORT_PCT(counters,FR_BR_MIS,FR_BR); - PAPI_REPORT_PCT(counters,FR_BR_MISCOMPARE,FR_BR); + PAPI_REPORT_PCT(counters,FR_BR_MIS,FR_BR); + PAPI_REPORT_PCT(counters,FR_BR_MISCOMPARE,FR_BR); } else if (RtsFlags.PapiFlags.eventType==PAPI_FLAG_CACHE_L1) { - PAPI_REPORT_PCT(counters,PAPI_L1_DCM,PAPI_L1_DCA); + PAPI_REPORT_PCT(counters,PAPI_L1_DCM,PAPI_L1_DCA); } else if (RtsFlags.PapiFlags.eventType==PAPI_FLAG_CACHE_L2) { - PAPI_REPORT_PCT(counters,PAPI_L2_DCM,PAPI_L2_DCA); + PAPI_REPORT_PCT(counters,PAPI_L2_DCM,PAPI_L2_DCA); } } @@ -238,7 +240,7 @@ papi_stats_report (void) statsPrintf(" Mutator CPU counters\n"); papi_report_event("CYCLES", mutator_cycles); papi_report(MutatorCounters); - + statsPrintf("\n GC(0) CPU counters\n"); papi_report_event("CYCLES", gc0_cycles); papi_report(GC0Counters); @@ -247,7 +249,7 @@ papi_stats_report (void) papi_report_event("CYCLES", gc1_cycles); papi_report(GC1Counters); } - + void papi_init_eventset (int *event_set) { @@ -310,10 +312,10 @@ papi_add_events(int EventSet) nat i; for(i=0;i<n_papi_events;i++) { if((papi_error=PAPI_add_event(EventSet, - papi_events[i].event_code)) + papi_events[i].event_code)) != PAPI_OK) debugBelch("Failed adding %s to event set with error code %d\n", - papi_events[i].event_name,papi_error); + papi_events[i].event_name,papi_error); } } @@ -392,3 +394,11 @@ papi_thread_stop_gc1_count(int event_set) } #endif /* USE_PAPI */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Papi.h b/rts/Papi.h index 7e58c6fbbe..1aa1b31381 100644 --- a/rts/Papi.h +++ b/rts/Papi.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- * (c) The GHC Team 2006 - * + * * Initialization and use of the PAPI performance monitoring library * * ---------------------------------------------------------------------------*/ @@ -34,3 +34,11 @@ void papi_thread_stop_gc1_count(int event_set); #include "EndPrivate.h" #endif /* PAPI_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/PosixSource.h b/rts/PosixSource.h index da7b69e85d..7803dd2372 100644 --- a/rts/PosixSource.h +++ b/rts/PosixSource.h @@ -20,7 +20,7 @@ #define _XOPEN_SOURCE 500 // FreeBSD takes a different approach to _ISOC99_SOURCE: on FreeBSD it // means "I want *just* C99 things", whereas on GNU libc and Solaris -// it means "I also want C99 things". +// it means "I also want C99 things". // // On both GNU libc and FreeBSD, _ISOC99_SOURCE is implied by // _XOPEN_SOURCE==600, but on Solaris it is an error to omit it. @@ -40,3 +40,11 @@ #endif #endif /* POSIXSOURCE_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Prelude.h b/rts/Prelude.h index 0c54148ba2..adbb5535bf 100644 --- a/rts/Prelude.h +++ b/rts/Prelude.h @@ -144,3 +144,11 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info); #define StablePtr_con_info DLL_IMPORT_DATA_REF(base_GHCziStable_StablePtr_con_info) #endif /* PRELUDE_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 4d7baca824..5f04a6d732 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -151,18 +151,6 @@ stg_casIntArrayzh( gcptr arr, W_ ind, W_ old, W_ new ) } -stg_fetchAddIntArrayzh( gcptr arr, W_ ind, W_ incr ) -/* MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) */ -{ - W_ p, h; - - p = arr + SIZEOF_StgArrWords + WDS(ind); - (h) = ccall atomic_inc(p, incr); - - return(h); -} - - stg_newArrayzh ( W_ n /* words */, gcptr init ) { W_ words, size, p; diff --git a/rts/Printer.c b/rts/Printer.c index b7125d9980..6f37831512 100644 --- a/rts/Printer.c +++ b/rts/Printer.c @@ -1170,3 +1170,11 @@ info_hdr_type(StgClosure *closure, char *res){ strcpy(res,closure_type_names[get_itbl(closure)->type]); } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Printer.h b/rts/Printer.h index 0dae896414..2a35f7a361 100644 --- a/rts/Printer.h +++ b/rts/Printer.h @@ -39,3 +39,11 @@ extern char *what_next_strs[]; #endif /* PRINTER_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c index 9079c2be60..5b7cf30231 100644 --- a/rts/ProfHeap.c +++ b/rts/ProfHeap.c @@ -1148,3 +1148,11 @@ void heapCensus (Time t) #endif } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/ProfHeap.h b/rts/ProfHeap.h index b3bed903b5..4aa3bcd057 100644 --- a/rts/ProfHeap.h +++ b/rts/ProfHeap.h @@ -19,3 +19,11 @@ rtsBool strMatchesSelector (char* str, char* sel); #include "EndPrivate.h" #endif /* PROFHEAP_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Profiling.c b/rts/Profiling.c index 50c9c391e7..41c2aa5f8a 100644 --- a/rts/Profiling.c +++ b/rts/Profiling.c @@ -619,10 +619,8 @@ actualPush_ (CostCentreStack *ccs, CostCentre *cc, CostCentreStack *new_ccs) ccsSetSelected(new_ccs); /* update the memoization table for the parent stack */ - if (ccs != EMPTY_STACK) { - ccs->indexTable = addToIndexTable(ccs->indexTable, new_ccs, cc, - 0/*not a back edge*/); - } + ccs->indexTable = addToIndexTable(ccs->indexTable, new_ccs, cc, + 0/*not a back edge*/); /* return a pointer to the new stack */ return new_ccs; @@ -1147,3 +1145,11 @@ debugCCS( CostCentreStack *ccs ) #endif /* DEBUG */ #endif /* PROFILING */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Profiling.h b/rts/Profiling.h index 8c365220fb..6d5950c62b 100644 --- a/rts/Profiling.h +++ b/rts/Profiling.h @@ -46,3 +46,11 @@ void debugCCS( CostCentreStack *ccs ); #include "EndPrivate.h" #endif /* PROFILING_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Proftimer.c b/rts/Proftimer.c index 6458f6e095..d0e6aa79d5 100644 --- a/rts/Proftimer.c +++ b/rts/Proftimer.c @@ -89,3 +89,11 @@ handleProfTick(void) } } } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Proftimer.h b/rts/Proftimer.h index 4bb063fbbc..b8f2aa80c5 100644 --- a/rts/Proftimer.h +++ b/rts/Proftimer.h @@ -22,3 +22,11 @@ extern rtsBool performHeapProfile; #include "EndPrivate.h" #endif /* PROFTIMER_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c index a5440e40ad..7da3e6452d 100644 --- a/rts/RaiseAsync.c +++ b/rts/RaiseAsync.c @@ -1051,3 +1051,11 @@ done: } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/RaiseAsync.h b/rts/RaiseAsync.h index 1f61b8c72d..d0c9efcbee 100644 --- a/rts/RaiseAsync.h +++ b/rts/RaiseAsync.h @@ -52,6 +52,7 @@ interruptible(StgTSO *t) { switch (t->why_blocked) { case BlockedOnMVar: + case BlockedOnSTM: case BlockedOnMVarRead: case BlockedOnMsgThrowTo: case BlockedOnRead: @@ -74,3 +75,11 @@ interruptible(StgTSO *t) #endif /* RAISEASYNC_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/RetainerProfile.c b/rts/RetainerProfile.c index bfc96247aa..d0e95d8ebb 100644 --- a/rts/RetainerProfile.c +++ b/rts/RetainerProfile.c @@ -2286,3 +2286,11 @@ belongToHeap(StgPtr p) #endif /* DEBUG_RETAINER */ #endif /* PROFILING */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/RetainerProfile.h b/rts/RetainerProfile.h index d92563ffbb..d24f99428c 100644 --- a/rts/RetainerProfile.h +++ b/rts/RetainerProfile.h @@ -51,3 +51,11 @@ extern W_ retainerStackBlocks ( void ); #endif /* PROFILING */ #endif /* RETAINERPROFILE_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/RetainerSet.c b/rts/RetainerSet.c index d93ae4bd16..075dd7560f 100644 --- a/rts/RetainerSet.c +++ b/rts/RetainerSet.c @@ -24,17 +24,17 @@ #define hash(hk) (hk % HASH_TABLE_SIZE) static RetainerSet *hashTable[HASH_TABLE_SIZE]; -static Arena *arena; // arena in which we store retainer sets +static Arena *arena; // arena in which we store retainer sets -static int nextId; // id of next retainer set +static int nextId; // id of next retainer set /* ----------------------------------------------------------------------------- * rs_MANY is a distinguished retainer set, such that * * isMember(e, rs_MANY) = True * - * addElement(e, rs) = rs_MANY, if rs->num >= maxRetainerSetSize - * addElement(e, rs_MANY) = rs_MANY + * addElement(e, rs) = rs_MANY, if rs->num >= maxRetainerSetSize + * addElement(e, rs_MANY) = rs_MANY * * The point of rs_MANY is to keep the total number of retainer sets * from growing too large. @@ -68,7 +68,7 @@ initializeAllRetainerSet(void) arena = newArena(); for (i = 0; i < HASH_TABLE_SIZE; i++) - hashTable[i] = NULL; + hashTable[i] = NULL; nextId = 2; // Initial value must be positive, 2 is MANY. } @@ -86,7 +86,7 @@ refreshAllRetainerSet(void) arena = newArena(); for (i = 0; i < HASH_TABLE_SIZE; i++) - hashTable[i] = NULL; + hashTable[i] = NULL; nextId = 2; #endif /* FIRST_APPROACH */ } @@ -111,7 +111,7 @@ singleton(retainer r) hk = hashKeySingleton(r); for (rs = hashTable[hash(hk)]; rs != NULL; rs = rs->link) - if (rs->num == 1 && rs->element[0] == r) return rs; // found it + if (rs->num == 1 && rs->element[0] == r) return rs; // found it // create it rs = arenaAlloc( arena, sizeofRetainerSet(1) ); @@ -153,13 +153,13 @@ addElement(retainer r, RetainerSet *rs) ASSERT(rs->num <= RtsFlags.ProfFlags.maxRetainerSetSize); if (rs == &rs_MANY || rs->num == RtsFlags.ProfFlags.maxRetainerSetSize) { - return &rs_MANY; + return &rs_MANY; } ASSERT(!isMember(r, rs)); for (nl = 0; nl < rs->num; nl++) - if (r < rs->element[nl]) break; + if (r < rs->element[nl]) break; // Now nl is the index for r into the new set. // Also it denotes the number of retainers less than r in *rs. // Thus, compare the first nl retainers, then r itself, and finally the @@ -167,29 +167,29 @@ addElement(retainer r, RetainerSet *rs) hk = hashKeyAddElement(r, rs); for (nrs = hashTable[hash(hk)]; nrs != NULL; nrs = nrs->link) { - // test *rs and *nrs for equality + // test *rs and *nrs for equality - // check their size - if (rs->num + 1 != nrs->num) continue; + // check their size + if (rs->num + 1 != nrs->num) continue; - // compare the first nl retainers and find the first non-matching one. - for (i = 0; i < nl; i++) - if (rs->element[i] != nrs->element[i]) break; - if (i < nl) continue; + // compare the first nl retainers and find the first non-matching one. + for (i = 0; i < nl; i++) + if (rs->element[i] != nrs->element[i]) break; + if (i < nl) continue; - // compare r itself - if (r != nrs->element[i]) continue; // i == nl + // compare r itself + if (r != nrs->element[i]) continue; // i == nl - // compare the remaining retainers - for (; i < rs->num; i++) - if (rs->element[i] != nrs->element[i + 1]) break; - if (i < rs->num) continue; + // compare the remaining retainers + for (; i < rs->num; i++) + if (rs->element[i] != nrs->element[i + 1]) break; + if (i < rs->num) continue; #ifdef DEBUG_RETAINER - // debugBelch("%p\n", nrs); + // debugBelch("%p\n", nrs); #endif - // The set we are seeking already exists! - return nrs; + // The set we are seeking already exists! + return nrs; } // create a new retainer set @@ -199,11 +199,11 @@ addElement(retainer r, RetainerSet *rs) nrs->link = hashTable[hash(hk)]; nrs->id = nextId++; for (i = 0; i < nl; i++) { // copy the first nl retainers - nrs->element[i] = rs->element[i]; + nrs->element[i] = rs->element[i]; } nrs->element[i] = r; // copy r for (; i < rs->num; i++) { // copy the remaining retainers - nrs->element[i + 1] = rs->element[i]; + nrs->element[i + 1] = rs->element[i]; } hashTable[hash(hk)] = nrs; @@ -225,8 +225,8 @@ traverseAllRetainerSet(void (*f)(RetainerSet *)) (*f)(&rs_MANY); for (i = 0; i < HASH_TABLE_SIZE; i++) - for (rs = hashTable[i]; rs != NULL; rs = rs->link) - (*f)(rs); + for (rs = hashTable[i]; rs != NULL; rs = rs->link) + (*f)(rs); } @@ -281,20 +281,20 @@ printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length) ASSERT(size < max_length); for (j = 0; j < rs->num; j++) { - if (j < rs->num - 1) { - strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), max_length - size); - size = strlen(tmp); - if (size == max_length) - break; - strncpy(tmp + size, ",", max_length - size); - size = strlen(tmp); - if (size == max_length) - break; - } - else { - strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), max_length - size); - // size = strlen(tmp); - } + if (j < rs->num - 1) { + strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), max_length - size); + size = strlen(tmp); + if (size == max_length) + break; + strncpy(tmp + size, ",", max_length - size); + size = strlen(tmp); + if (size == max_length) + break; + } + else { + strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), max_length - size); + // size = strlen(tmp); + } } fprintf(f, tmp); } @@ -327,20 +327,20 @@ printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length) ASSERT(size < max_length); for (j = 0; j < rs->num; j++) { - if (j < rs->num - 1) { - strncpy(tmp + size, rs->element[j]->cc->label, max_length - size); - size = strlen(tmp); - if (size == max_length) - break; - strncpy(tmp + size, ",", max_length - size); - size = strlen(tmp); - if (size == max_length) - break; - } - else { - strncpy(tmp + size, rs->element[j]->cc->label, max_length - size); - // size = strlen(tmp); - } + if (j < rs->num - 1) { + strncpy(tmp + size, rs->element[j]->cc->label, max_length - size); + size = strlen(tmp); + if (size == max_length) + break; + strncpy(tmp + size, ",", max_length - size); + size = strlen(tmp); + if (size == max_length) + break; + } + else { + strncpy(tmp + size, rs->element[j]->cc->label, max_length - size); + // size = strlen(tmp); + } } fputs(tmp, f); } @@ -363,22 +363,22 @@ printRetainerSetShort(FILE *f, retainerSet *rs, nat max_length) ASSERT(size < max_length); for (j = 0; j < rs->num; j++) { - if (j < rs->num - 1) { - strncpy(tmp + size, rs->element[j]->label, - max_length - size); - size = strlen(tmp); - if (size == max_length) - break; - strncpy(tmp + size, ",", max_length - size); - size = strlen(tmp); - if (size == max_length) - break; - } - else { - strncpy(tmp + size, rs->element[j]->label, - max_length - size); - // size = strlen(tmp); - } + if (j < rs->num - 1) { + strncpy(tmp + size, rs->element[j]->label, + max_length - size); + size = strlen(tmp); + if (size == max_length) + break; + strncpy(tmp + size, ",", max_length - size); + size = strlen(tmp); + if (size == max_length) + break; + } + else { + strncpy(tmp + size, rs->element[j]->label, + max_length - size); + // size = strlen(tmp); + } } fprintf(f, tmp); /* @@ -426,7 +426,7 @@ printRetainerSetShort(FILE *f, retainerSet *rs, nat max_length) * Dump the contents of each retainer set into the log file at the end * of the run, so the user can find out for a given retainer set ID * the full contents of that set. - * --------------------------------------------------------------------------- */ + * -------------------------------------------------------------------------- */ #ifdef SECOND_APPROACH void outputAllRetainerSet(FILE *prof_file) @@ -439,51 +439,51 @@ outputAllRetainerSet(FILE *prof_file) // least once during retainer profiling numSet = 0; for (i = 0; i < HASH_TABLE_SIZE; i++) - for (rs = hashTable[i]; rs != NULL; rs = rs->link) { - if (rs->id < 0) - numSet++; - } + for (rs = hashTable[i]; rs != NULL; rs = rs->link) { + if (rs->id < 0) + numSet++; + } if (numSet == 0) // retainer profiling was not done at all. - return; + return; // allocate memory rsArray = stgMallocBytes(numSet * sizeof(RetainerSet *), - "outputAllRetainerSet()"); + "outputAllRetainerSet()"); // prepare for sorting j = 0; for (i = 0; i < HASH_TABLE_SIZE; i++) - for (rs = hashTable[i]; rs != NULL; rs = rs->link) { - if (rs->id < 0) { - rsArray[j] = rs; - j++; - } - } + for (rs = hashTable[i]; rs != NULL; rs = rs->link) { + if (rs->id < 0) { + rsArray[j] = rs; + j++; + } + } ASSERT(j == numSet); // sort rsArray[] according to the id of each retainer set for (i = numSet - 1; i > 0; i--) { - for (j = 0; j <= i - 1; j++) { - // if (-(rsArray[j]->id) < -(rsArray[j + 1]->id)) - if (rsArray[j]->id < rsArray[j + 1]->id) { - tmp = rsArray[j]; - rsArray[j] = rsArray[j + 1]; - rsArray[j + 1] = tmp; - } - } + for (j = 0; j <= i - 1; j++) { + // if (-(rsArray[j]->id) < -(rsArray[j + 1]->id)) + if (rsArray[j]->id < rsArray[j + 1]->id) { + tmp = rsArray[j]; + rsArray[j] = rsArray[j + 1]; + rsArray[j + 1] = tmp; + } + } } fprintf(prof_file, "\nRetainer sets created during profiling:\n"); for (i = 0;i < numSet; i++) { - fprintf(prof_file, "SET %u = {", -(rsArray[i]->id)); - for (j = 0; j < rsArray[i]->num - 1; j++) { - printRetainer(prof_file, rsArray[i]->element[j]); - fprintf(prof_file, ", "); - } - printRetainer(prof_file, rsArray[i]->element[j]); - fprintf(prof_file, "}\n"); + fprintf(prof_file, "SET %u = {", -(rsArray[i]->id)); + for (j = 0; j < rsArray[i]->num - 1; j++) { + printRetainer(prof_file, rsArray[i]->element[j]); + fprintf(prof_file, ", "); + } + printRetainer(prof_file, rsArray[i]->element[j]); + fprintf(prof_file, "}\n"); } stgFree(rsArray); @@ -491,3 +491,11 @@ outputAllRetainerSet(FILE *prof_file) #endif /* SECOND_APPROACH */ #endif /* PROFILING */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/RetainerSet.h b/rts/RetainerSet.h index 5004527d21..5f24d84063 100644 --- a/rts/RetainerSet.h +++ b/rts/RetainerSet.h @@ -20,7 +20,7 @@ Type 'retainer' defines the retainer identity. Invariant: - 1. The retainer identity of a given retainer cannot change during + 1. The retainer identity of a given retainer cannot change during program execution, no matter where it is actually stored. For instance, the memory address of a retainer cannot be used as its retainer identity because its location may change during garbage @@ -56,7 +56,7 @@ typedef CostCentre *retainer; #endif /* - Type 'retainerSet' defines an abstract datatype for sets of retainers. + Type 'retainerSet' defines an abstract datatype for sets of retainers. Invariants: A retainer set stores its elements in increasing order (in element[] array). @@ -75,13 +75,13 @@ typedef struct _RetainerSet { } RetainerSet; /* - Note: + Note: There are two ways of maintaining all retainer sets. The first is simply by freeing all the retainer sets and re-initialize the hash table at each - retainer profiling. The second is by setting the cost field of each - retainer set. The second is preferred to the first if most retainer sets - are likely to be observed again during the next retainer profiling. Note - that in the first approach, we do not free the memory allocated for + retainer profiling. The second is by setting the cost field of each + retainer set. The second is preferred to the first if most retainer sets + are likely to be observed again during the next retainer profiling. Note + that in the first approach, we do not free the memory allocated for retainer sets; we just invalidate all retainer sets. */ #ifdef DEBUG_RETAINER @@ -108,12 +108,12 @@ RetainerSet *singleton(retainer r); extern RetainerSet rs_MANY; // Checks if a given retainer is a memeber of the retainer set. -// +// // Note & (maybe) Todo: // This function needs to be declared as an inline function, so it is declared // as an inline static function here. // This make the interface really bad, but isMember() returns a value, so -// it is not easy either to write it as a macro (due to my lack of C +// it is not easy either to write it as a macro (due to my lack of C // programming experience). Sungwoo // // rtsBool isMember(retainer, retainerSet *); @@ -124,7 +124,7 @@ extern RetainerSet rs_MANY; Note: The efficiency of this function is subject to the typical size of retainer sets. If it is small, linear scan is better. If it - is large in most cases, binary scan is better. + is large in most cases, binary scan is better. The current implementation mixes the two search strategies. */ @@ -169,7 +169,7 @@ void printRetainerSetShort(FILE *, RetainerSet *, nat); #endif // Print the statistics on all the retainer sets. -// store the sum of all costs and the number of all retainer sets. +// store the sum of all costs and the number of all retainer sets. void outputRetainerSet(FILE *, nat *, nat *); #ifdef SECOND_APPROACH @@ -203,3 +203,11 @@ void printRetainer(FILE *, retainer); #endif /* PROFILING */ #endif /* RETAINERSET_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/RtsAPI.c b/rts/RtsAPI.c index f01a0efee8..7062306c74 100644 --- a/rts/RtsAPI.c +++ b/rts/RtsAPI.c @@ -620,3 +620,11 @@ void rts_done (void) freeMyTask(); } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/RtsDllMain.c b/rts/RtsDllMain.c index 06c565588f..6bb3db1bd6 100644 --- a/rts/RtsDllMain.c +++ b/rts/RtsDllMain.c @@ -21,8 +21,8 @@ BOOL WINAPI DllMain ( HINSTANCE hInstance STG_UNUSED , DWORD reason - , LPVOID reserved STG_UNUSED - ) + , LPVOID reserved STG_UNUSED + ) { /* * Note: the DllMain() doesn't call startupHaskell() for you, @@ -31,13 +31,21 @@ DllMain ( HINSTANCE hInstance STG_UNUSED * you pass to the RTS. */ switch (reason) { - + // shutdownHaskelAndExit() is already being called, - // so I don't think we need this. BL 2009/11/17 - + // so I don't think we need this. BL 2009/11/17 + //case DLL_PROCESS_DETACH: shutdownHaskell(); } return TRUE; } #endif + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/RtsDllMain.h b/rts/RtsDllMain.h index d781127079..5147962780 100644 --- a/rts/RtsDllMain.h +++ b/rts/RtsDllMain.h @@ -1,4 +1,3 @@ - #include "Rts.h" #ifdef HAVE_WINDOWS_H @@ -15,3 +14,10 @@ DllMain ( HINSTANCE hInstance ); #endif +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c index af1b2049f6..9c353a1133 100644 --- a/rts/RtsFlags.c +++ b/rts/RtsFlags.c @@ -241,7 +241,8 @@ usage_text[] = { " -? Prints this message and exits; the program is not executed", " --info Print information about the RTS used by this program", "", -" -K<size> Sets the maximum stack size (default 8M) Egs: -K32k -K512k", +" -K<size> Sets the maximum stack size (default: 80% of the heap)", +" Egs: -K32k -K512k -K8M", " -ki<size> Sets the initial thread stack size (default 1k) Egs: -ki4k -ki2m", " -kc<size> Sets the stack chunk size (default 32k)", " -kb<size> Sets the stack chunk buffer size (default 1k)", @@ -1858,3 +1859,11 @@ void freeRtsArgs(void) freeProgArgv(); freeRtsArgv(); } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/RtsFlags.h b/rts/RtsFlags.h index b3627e0e48..0e212b4ca9 100644 --- a/rts/RtsFlags.h +++ b/rts/RtsFlags.h @@ -25,3 +25,11 @@ void freeRtsArgs (void); #include "EndPrivate.h" #endif /* RTSFLAGS_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/RtsMain.c b/rts/RtsMain.c index df637169f8..ea45d6f050 100644 --- a/rts/RtsMain.c +++ b/rts/RtsMain.c @@ -117,3 +117,11 @@ int hs_main (int argc, char *argv[], // program args #endif } # endif /* BATCH_MODE */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/RtsMessages.c b/rts/RtsMessages.c index 6e75abc8a5..83758175e2 100644 --- a/rts/RtsMessages.c +++ b/rts/RtsMessages.c @@ -283,3 +283,11 @@ rtsDebugMsgFn(const char *s, va_list ap) fflush(stderr); } } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/RtsSignals.h b/rts/RtsSignals.h index be21765dd6..a319713dbe 100644 --- a/rts/RtsSignals.h +++ b/rts/RtsSignals.h @@ -65,3 +65,11 @@ void markSignalHandlers (evac_fn evac, void *user); #endif /* RTS_USER_SIGNALS */ #endif /* RTSSIGNALS_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c index 8e7e11dd26..36ac26928d 100644 --- a/rts/RtsStartup.c +++ b/rts/RtsStartup.c @@ -543,3 +543,11 @@ stg_exit(int n) (*exitFn)(n); exit(n); } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/RtsUtils.c b/rts/RtsUtils.c index 185f1e8bdd..811dcf1b4c 100644 --- a/rts/RtsUtils.c +++ b/rts/RtsUtils.c @@ -329,3 +329,11 @@ void checkFPUStack(void) #endif } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/RtsUtils.h b/rts/RtsUtils.h index 5d825a2118..88b0af285c 100644 --- a/rts/RtsUtils.h +++ b/rts/RtsUtils.h @@ -48,3 +48,11 @@ void checkFPUStack(void); #include "EndPrivate.h" #endif /* RTSUTILS_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: @@ -1696,3 +1696,11 @@ void stmWriteTVar(Capability *cap, } /*......................................................................*/ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: @@ -221,3 +221,11 @@ void stmWriteTVar(Capability *cap, #endif /* STM_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Schedule.c b/rts/Schedule.c index adf2b5cb39..ad1cffc1a5 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -1802,6 +1802,10 @@ forkProcess(HsStablePtr *entry ACQUIRE_LOCK(&capabilities[i]->lock); } +#ifdef THREADED_RTS + ACQUIRE_LOCK(&all_tasks_mutex); +#endif + stopTimer(); // See #4074 #if defined(TRACING) @@ -1823,13 +1827,18 @@ forkProcess(HsStablePtr *entry releaseCapability_(capabilities[i],rtsFalse); RELEASE_LOCK(&capabilities[i]->lock); } + +#ifdef THREADED_RTS + RELEASE_LOCK(&all_tasks_mutex); +#endif + boundTaskExiting(task); // just return the pid return pid; } else { // child - + #if defined(THREADED_RTS) initMutex(&sched_mutex); initMutex(&sm_mutex); @@ -1839,6 +1848,8 @@ forkProcess(HsStablePtr *entry for (i=0; i < n_capabilities; i++) { initMutex(&capabilities[i]->lock); } + + initMutex(&all_tasks_mutex); #endif #ifdef TRACING @@ -1926,8 +1937,7 @@ forkProcess(HsStablePtr *entry rts_checkSchedStatus("forkProcess",cap); rts_unlock(cap); - hs_exit(); // clean up and exit - stg_exit(EXIT_SUCCESS); + shutdownHaskellAndExit(EXIT_SUCCESS, 0 /* !fastExit */); } #else /* !FORKPROCESS_PRIMOP_SUPPORTED */ barf("forkProcess#: primop not supported on this platform, sorry!\n"); @@ -2858,3 +2868,11 @@ resurrectThreads (StgTSO *threads) } } } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Schedule.h b/rts/Schedule.h index 015cc1cefc..f788aec9ce 100644 --- a/rts/Schedule.h +++ b/rts/Schedule.h @@ -259,3 +259,11 @@ emptyThreadQueues(Capability *cap) #endif /* SCHEDULE_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Sparks.c b/rts/Sparks.c index 4241656795..d54a1f1aaa 100644 --- a/rts/Sparks.c +++ b/rts/Sparks.c @@ -310,3 +310,11 @@ newSpark (StgRegTable *reg STG_UNUSED, StgClosure *p STG_UNUSED) } #endif /* THREADED_RTS */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Sparks.h b/rts/Sparks.h index e381dd540f..6bc28795d8 100644 --- a/rts/Sparks.h +++ b/rts/Sparks.h @@ -106,3 +106,11 @@ INLINE_HEADER rtsBool fizzledSpark (StgClosure *spark) #include "EndPrivate.h" #endif /* SPARKS_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Stable.c b/rts/Stable.c index 431b7c66c1..229d707a83 100644 --- a/rts/Stable.c +++ b/rts/Stable.c @@ -549,3 +549,11 @@ updateStableTables(rtsBool full) }); } } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Stable.h b/rts/Stable.h index 4786d477f3..0a1cc0dd2f 100644 --- a/rts/Stable.h +++ b/rts/Stable.h @@ -52,3 +52,11 @@ extern Mutex stable_mutex; #include "EndPrivate.h" #endif /* STABLE_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Stats.c b/rts/Stats.c index 48c320c8f7..7acac707ba 100644 --- a/rts/Stats.c +++ b/rts/Stats.c @@ -173,8 +173,8 @@ initStats1 (void) nat i; if (RtsFlags.GcFlags.giveStats >= VERBOSE_GC_STATS) { - statsPrintf(" Alloc Copied Live GC GC TOT TOT Page Flts\n"); - statsPrintf(" bytes bytes bytes user elap user elap\n"); + statsPrintf(" Alloc Copied Live GC GC TOT TOT Page Flts\n"); + statsPrintf(" bytes bytes bytes user elap user elap\n"); } GC_coll_cpu = (Time *)stgMallocBytes( @@ -287,53 +287,12 @@ stat_startGC (Capability *cap, gc_thread *gct) traceEventGcStartAtT(cap, TimeToNS(gct->gc_start_elapsed - start_init_elapsed)); - gct->gc_start_thread_cpu = getThreadCPUTime(); - if (RtsFlags.GcFlags.giveStats != NO_GC_STATS) { gct->gc_start_faults = getPageFaults(); } } -void -stat_gcWorkerThreadStart (gc_thread *gct STG_UNUSED) -{ -#if 0 - /* - * We dont' collect per-thread GC stats any more, but this code - * could be used to do that if we want to in the future: - */ - if (RtsFlags.GcFlags.giveStats != NO_GC_STATS) - { - getProcessTimes(&gct->gc_start_cpu, &gct->gc_start_elapsed); - gct->gc_start_thread_cpu = getThreadCPUTime(); - } -#endif -} - -void -stat_gcWorkerThreadDone (gc_thread *gct STG_UNUSED) -{ -#if 0 - /* - * We dont' collect per-thread GC stats any more, but this code - * could be used to do that if we want to in the future: - */ - Time thread_cpu, elapsed, gc_cpu, gc_elapsed; - - if (RtsFlags.GcFlags.giveStats != NO_GC_STATS) - { - elapsed = getProcessElapsedTime(); - thread_cpu = getThreadCPUTime(); - - gc_cpu = thread_cpu - gct->gc_start_thread_cpu; - gc_elapsed = elapsed - gct->gc_start_elapsed; - - taskDoneGC(gct->cap->running_task, gc_cpu, gc_elapsed); - } -#endif -} - /* ----------------------------------------------------------------------------- * Calculate the total allocated memory since the start of the * program. Also emits events reporting the per-cap allocation @@ -421,7 +380,7 @@ stat_endGC (Capability *cap, gc_thread *gct, statsPrintf("%9" FMT_SizeT " %9" FMT_SizeT " %9" FMT_SizeT, alloc*sizeof(W_), copied*sizeof(W_), live*sizeof(W_)); - statsPrintf(" %5.2f %5.2f %7.2f %7.2f %4" FMT_Word " %4" FMT_Word " (Gen: %2d)\n", + statsPrintf(" %6.3f %6.3f %8.3f %8.3f %4" FMT_Word " %4" FMT_Word " (Gen: %2d)\n", TimeToSecondsDbl(gc_cpu), TimeToSecondsDbl(gc_elapsed), TimeToSecondsDbl(cpu), @@ -645,7 +604,7 @@ stat_exit (void) if (RtsFlags.GcFlags.giveStats >= VERBOSE_GC_STATS) { statsPrintf("%9" FMT_SizeT " %9.9s %9.9s", (W_)alloc*sizeof(W_), "", ""); - statsPrintf(" %5.2f %5.2f\n\n", 0.0, 0.0); + statsPrintf(" %6.3f %6.3f\n\n", 0.0, 0.0); } for (i = 0; i < RtsFlags.GcFlags.generations; i++) { @@ -695,10 +654,10 @@ stat_exit (void) (size_t)(peak_mblocks_allocated * BLOCKS_PER_MBLOCK * BLOCK_SIZE_W - hw_alloc_blocks * BLOCK_SIZE_W) / (1024 * 1024 / sizeof(W_))); /* Print garbage collections in each gen */ - statsPrintf(" Tot time (elapsed) Avg pause Max pause\n"); + statsPrintf(" Tot time (elapsed) Avg pause Max pause\n"); for (g = 0; g < RtsFlags.GcFlags.generations; g++) { gen = &generations[g]; - statsPrintf(" Gen %2d %5d colls, %5d par %5.2fs %5.2fs %3.4fs %3.4fs\n", + statsPrintf(" Gen %2d %5d colls, %5d par %6.3fs %6.3fs %3.4fs %3.4fs\n", gen->no, gen->collections, gen->par_collections, @@ -745,23 +704,23 @@ stat_exit (void) } #endif - statsPrintf(" INIT time %6.2fs (%6.2fs elapsed)\n", + statsPrintf(" INIT time %7.3fs (%7.3fs elapsed)\n", TimeToSecondsDbl(init_cpu), TimeToSecondsDbl(init_elapsed)); - statsPrintf(" MUT time %6.2fs (%6.2fs elapsed)\n", + statsPrintf(" MUT time %7.3fs (%7.3fs elapsed)\n", TimeToSecondsDbl(mut_cpu), TimeToSecondsDbl(mut_elapsed)); - statsPrintf(" GC time %6.2fs (%6.2fs elapsed)\n", + statsPrintf(" GC time %7.3fs (%7.3fs elapsed)\n", TimeToSecondsDbl(gc_cpu), TimeToSecondsDbl(gc_elapsed)); #ifdef PROFILING - statsPrintf(" RP time %6.2fs (%6.2fs elapsed)\n", + statsPrintf(" RP time %7.3fs (%7.3fs elapsed)\n", TimeToSecondsDbl(RP_tot_time), TimeToSecondsDbl(RPe_tot_time)); - statsPrintf(" PROF time %6.2fs (%6.2fs elapsed)\n", + statsPrintf(" PROF time %7.3fs (%7.3fs elapsed)\n", TimeToSecondsDbl(HC_tot_time), TimeToSecondsDbl(HCe_tot_time)); #endif - statsPrintf(" EXIT time %6.2fs (%6.2fs elapsed)\n", + statsPrintf(" EXIT time %7.3fs (%7.3fs elapsed)\n", TimeToSecondsDbl(exit_cpu), TimeToSecondsDbl(exit_elapsed)); - statsPrintf(" Total time %6.2fs (%6.2fs elapsed)\n\n", + statsPrintf(" Total time %7.3fs (%7.3fs elapsed)\n\n", TimeToSecondsDbl(tot_cpu), TimeToSecondsDbl(tot_elapsed)); #ifndef THREADED_RTS statsPrintf(" %%GC time %5.1f%% (%.1f%% elapsed)\n\n", @@ -820,17 +779,17 @@ stat_exit (void) " ,(\"max_bytes_used\", \"%ld\")\n" " ,(\"num_byte_usage_samples\", \"%ld\")\n" " ,(\"peak_megabytes_allocated\", \"%lu\")\n" - " ,(\"init_cpu_seconds\", \"%.2f\")\n" - " ,(\"init_wall_seconds\", \"%.2f\")\n" - " ,(\"mutator_cpu_seconds\", \"%.2f\")\n" - " ,(\"mutator_wall_seconds\", \"%.2f\")\n" - " ,(\"GC_cpu_seconds\", \"%.2f\")\n" - " ,(\"GC_wall_seconds\", \"%.2f\")\n" + " ,(\"init_cpu_seconds\", \"%.3f\")\n" + " ,(\"init_wall_seconds\", \"%.3f\")\n" + " ,(\"mutator_cpu_seconds\", \"%.3f\")\n" + " ,(\"mutator_wall_seconds\", \"%.3f\")\n" + " ,(\"GC_cpu_seconds\", \"%.3f\")\n" + " ,(\"GC_wall_seconds\", \"%.3f\")\n" " ]\n"; } else { fmt1 = "<<ghc: %llu bytes, "; - fmt2 = "%d GCs, %ld/%ld avg/max bytes residency (%ld samples), %luM in use, %.2f INIT (%.2f elapsed), %.2f MUT (%.2f elapsed), %.2f GC (%.2f elapsed) :ghc>>\n"; + fmt2 = "%d GCs, %ld/%ld avg/max bytes residency (%ld samples), %luM in use, %.3f INIT (%.3f elapsed), %.3f MUT (%.3f elapsed), %.3f GC (%.3f elapsed) :ghc>>\n"; } /* print the long long separately to avoid bugginess on mingwin (2001-07-02, mingw-0.5) */ statsPrintf(fmt1, GC_tot_alloc*(StgWord64)sizeof(W_)); @@ -1045,3 +1004,11 @@ statsClose( void ) fclose(sf); } } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Stats.h b/rts/Stats.h index 9839e5cf2a..0bbd7afb4a 100644 --- a/rts/Stats.h +++ b/rts/Stats.h @@ -32,9 +32,6 @@ void stat_endGC (Capability *cap, struct gc_thread_ *_gct, W_ live, W_ copied, W_ slop, nat gen, nat n_gc_threads, W_ par_max_copied, W_ par_tot_copied); -void stat_gcWorkerThreadStart (struct gc_thread_ *_gct); -void stat_gcWorkerThreadDone (struct gc_thread_ *_gct); - #ifdef PROFILING void stat_startRP(void); void stat_endRP(nat, @@ -78,3 +75,11 @@ void statsPrintf( char *s, ... ) #include "EndPrivate.h" #endif /* STATS_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/StgCRun.c b/rts/StgCRun.c index f649dbe9fb..244cdb428b 100644 --- a/rts/StgCRun.c +++ b/rts/StgCRun.c @@ -815,3 +815,11 @@ StgRun(StgFunPtr f, StgRegTable *basereg) { #endif #endif /* !USE_MINIINTERPRETER */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/StgPrimFloat.c b/rts/StgPrimFloat.c index 3b80d6f388..63fe52ec80 100644 --- a/rts/StgPrimFloat.c +++ b/rts/StgPrimFloat.c @@ -200,3 +200,11 @@ __decodeFloat_Int (I_ *man, I_ *exp, StgFloat flt) } } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/StgPrimFloat.h b/rts/StgPrimFloat.h index edd7b472b7..fefe8c9b7a 100644 --- a/rts/StgPrimFloat.h +++ b/rts/StgPrimFloat.h @@ -21,3 +21,11 @@ void __decodeFloat_Int (I_ *man, I_ *exp, StgFloat flt); #include "EndPrivate.h" #endif /* STGPRIMFLOAT_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/StgRun.h b/rts/StgRun.h index 71b92e2d88..0ce72935d6 100644 --- a/rts/StgRun.h +++ b/rts/StgRun.h @@ -3,7 +3,7 @@ * (c) The GHC Team, 1998-2004 * * Tiny assembler 'layer' between the C and STG worlds. - * + * ---------------------------------------------------------------------------- */ #ifndef STGRUN_H @@ -16,3 +16,11 @@ StgWord8 *win32AllocStack(void); #endif #endif /* STGRUN_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Task.c b/rts/Task.c index 12c22c4b02..0421d8b785 100644 --- a/rts/Task.c +++ b/rts/Task.c @@ -39,7 +39,7 @@ static Task * allocTask (void); static Task * newTask (rtsBool); #if defined(THREADED_RTS) -static Mutex all_tasks_mutex; +Mutex all_tasks_mutex; #endif /* ----------------------------------------------------------------------------- @@ -350,6 +350,20 @@ discardTasksExcept (Task *keep) next = task->all_next; if (task != keep) { debugTrace(DEBUG_sched, "discarding task %" FMT_SizeT "", (size_t)TASK_ID(task)); +#if defined(THREADED_RTS) + // It is possible that some of these tasks are currently blocked + // (in the parent process) either on their condition variable + // `cond` or on their mutex `lock`. If they are we may deadlock + // when `freeTask` attempts to call `closeCondition` or + // `closeMutex` (the behaviour of these functions is documented to + // be undefined in the case that there are threads blocked on + // them). To avoid this, we re-initialize both the condition + // variable and the mutex before calling `freeTask` (we do + // precisely the same for all global locks in `forkProcess`). + initCondition(&task->cond); + initMutex(&task->lock); +#endif + // Note that we do not traceTaskDelete here because // we are not really deleting a task. // The OS threads for all these tasks do not exist in @@ -502,3 +516,11 @@ printAllTasks(void) #endif + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Task.h b/rts/Task.h index cf70256326..7019499fee 100644 --- a/rts/Task.h +++ b/rts/Task.h @@ -171,6 +171,11 @@ isBoundTask (Task *task) // extern Task *all_tasks; +// The all_tasks list is protected by the all_tasks_mutex +#if defined(THREADED_RTS) +extern Mutex all_tasks_mutex; +#endif + // Start and stop the task manager. // Requires: sched_mutex. // @@ -324,3 +329,11 @@ serialisableTaskId (Task *task #include "EndPrivate.h" #endif /* TASK_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/ThreadLabels.c b/rts/ThreadLabels.c index 8838042a83..5d891a005e 100644 --- a/rts/ThreadLabels.c +++ b/rts/ThreadLabels.c @@ -59,7 +59,7 @@ removeThreadLabel(StgWord key) if ((old = lookupHashTable(threadLabels,key))) { removeHashTable(threadLabels,key,old); stgFree(old); - } + } } #endif /* DEBUG */ @@ -83,3 +83,10 @@ labelThread(Capability *cap STG_UNUSED, traceThreadLabel(cap, tso, label); } +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/ThreadLabels.h b/rts/ThreadLabels.h index 742e77ae58..ee482312ff 100644 --- a/rts/ThreadLabels.h +++ b/rts/ThreadLabels.h @@ -25,3 +25,11 @@ void labelThread (Capability *cap, #include "EndPrivate.h" #endif /* THREADLABELS_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/ThreadPaused.c b/rts/ThreadPaused.c index 0507880e6a..bf7def4583 100644 --- a/rts/ThreadPaused.c +++ b/rts/ThreadPaused.c @@ -82,7 +82,7 @@ stackSqueeze(Capability *cap, StgTSO *tso, StgPtr bottom) nat adjacent_update_frames; struct stack_gap *gap; - // Stage 1: + // Stage 1: // Traverse the stack upwards, replacing adjacent update frames // with a single update frame and a "stack gap". A stack gap // contains two values: the size of the gap, and the distance @@ -91,7 +91,7 @@ stackSqueeze(Capability *cap, StgTSO *tso, StgPtr bottom) frame = tso->stackobj->sp; ASSERT(frame < bottom); - + adjacent_update_frames = 0; gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame)); @@ -100,7 +100,7 @@ stackSqueeze(Capability *cap, StgTSO *tso, StgPtr bottom) switch (get_ret_itbl((StgClosure *)frame)->i.type) { case UPDATE_FRAME: - { + { if (adjacent_update_frames > 0) { TICK_UPD_SQUEEZED(); } @@ -109,10 +109,10 @@ stackSqueeze(Capability *cap, StgTSO *tso, StgPtr bottom) frame += sizeofW(StgUpdateFrame); continue; } - - default: + + default: // we're not in a gap... check whether this is the end of a gap - // (an update frame can't be the end of a gap). + // (an update frame can't be the end of a gap). if (adjacent_update_frames > 1) { gap = updateAdjacentFrames(cap, tso, (StgUpdateFrame*)(frame - sizeofW(StgUpdateFrame)), @@ -120,9 +120,9 @@ stackSqueeze(Capability *cap, StgTSO *tso, StgPtr bottom) } adjacent_update_frames = 0; - frame += stack_frame_sizeW((StgClosure *)frame); - continue; - } + frame += stack_frame_sizeW((StgClosure *)frame); + continue; + } } if (adjacent_update_frames > 1) { @@ -141,12 +141,12 @@ stackSqueeze(Capability *cap, StgTSO *tso, StgPtr bottom) // | | <- gap_start // | ......... | | // | stack_gap | <- gap | chunk_size - // | ......... | | + // | ......... | | // | ......... | <- gap_end v - // | ********* | - // | ********* | - // | ********* | - // -| ********* | + // | ********* | + // | ********* | + // | ********* | + // -| ********* | // // 'sp' points the the current top-of-stack // 'gap' points to the stack_gap structure inside the gap @@ -155,34 +155,34 @@ stackSqueeze(Capability *cap, StgTSO *tso, StgPtr bottom) // <empty> indicates unused // { - StgWord8 *sp; - StgWord8 *gap_start, *next_gap_start, *gap_end; - nat chunk_size; + StgWord8 *sp; + StgWord8 *gap_start, *next_gap_start, *gap_end; + nat chunk_size; - next_gap_start = (StgWord8*)gap + sizeof(StgUpdateFrame); - sp = next_gap_start; + next_gap_start = (StgWord8*)gap + sizeof(StgUpdateFrame); + sp = next_gap_start; while ((StgPtr)gap > tso->stackobj->sp) { - // we're working in *bytes* now... - gap_start = next_gap_start; - gap_end = gap_start - gap->gap_size * sizeof(W_); + // we're working in *bytes* now... + gap_start = next_gap_start; + gap_end = gap_start - gap->gap_size * sizeof(W_); - gap = gap->next_gap; - next_gap_start = (StgWord8*)gap + sizeof(StgUpdateFrame); + gap = gap->next_gap; + next_gap_start = (StgWord8*)gap + sizeof(StgUpdateFrame); - chunk_size = gap_end - next_gap_start; - sp -= chunk_size; - memmove(sp, next_gap_start, chunk_size); - } + chunk_size = gap_end - next_gap_start; + sp -= chunk_size; + memmove(sp, next_gap_start, chunk_size); + } tso->stackobj->sp = (StgPtr)sp; } -} +} /* ----------------------------------------------------------------------------- * Pausing a thread - * + * * We have to prepare for GC - this means doing lazy black holing * here. We also take the opportunity to do stack squeezing if it's * turned on. @@ -200,7 +200,7 @@ threadPaused(Capability *cap, StgTSO *tso) nat weight = 0; nat weight_pending = 0; rtsBool prev_was_update_frame = rtsFalse; - + // Check to see whether we have threads waiting to raise // exceptions, and we're not blocking exceptions, or are blocked // interruptibly. This is important; if a thread is running with @@ -214,15 +214,15 @@ threadPaused(Capability *cap, StgTSO *tso) // [upd-black-hole] in sm/Scav.c. stack_end = tso->stackobj->stack + tso->stackobj->stack_size; - + frame = (StgClosure *)tso->stackobj->sp; while ((P_)frame < stack_end) { info = get_ret_itbl(frame); - - switch (info->i.type) { - case UPDATE_FRAME: + switch (info->i.type) { + + case UPDATE_FRAME: // If we've already marked this frame, then stop here. if (frame->header.info == (StgInfoTable *)&stg_marked_upd_frame_info) { @@ -234,9 +234,9 @@ threadPaused(Capability *cap, StgTSO *tso) goto end; } - SET_INFO(frame, (StgInfoTable *)&stg_marked_upd_frame_info); + SET_INFO(frame, (StgInfoTable *)&stg_marked_upd_frame_info); - bh = ((StgUpdateFrame *)frame)->updatee; + bh = ((StgUpdateFrame *)frame)->updatee; bh_info = bh->header.info; #ifdef THREADED_RTS @@ -277,29 +277,29 @@ threadPaused(Capability *cap, StgTSO *tso) && ((StgInd*)bh)->indirectee != (StgClosure*)tso) { - debugTrace(DEBUG_squeeze, - "suspending duplicate work: %ld words of stack", + debugTrace(DEBUG_squeeze, + "suspending duplicate work: %ld words of stack", (long)((StgPtr)frame - tso->stackobj->sp)); - // If this closure is already an indirection, then - // suspend the computation up to this point. - // NB. check raiseAsync() to see what happens when - // we're in a loop (#2783). - suspendComputation(cap,tso,(StgUpdateFrame*)frame); + // If this closure is already an indirection, then + // suspend the computation up to this point. + // NB. check raiseAsync() to see what happens when + // we're in a loop (#2783). + suspendComputation(cap,tso,(StgUpdateFrame*)frame); - // Now drop the update frame, and arrange to return - // the value to the frame underneath: + // Now drop the update frame, and arrange to return + // the value to the frame underneath: tso->stackobj->sp = (StgPtr)frame + sizeofW(StgUpdateFrame) - 2; tso->stackobj->sp[1] = (StgWord)bh; ASSERT(bh->header.info != &stg_TSO_info); tso->stackobj->sp[0] = (W_)&stg_enter_info; - // And continue with threadPaused; there might be - // yet more computation to suspend. + // And continue with threadPaused; there might be + // yet more computation to suspend. frame = (StgClosure *)(tso->stackobj->sp + 2); prev_was_update_frame = rtsFalse; continue; - } + } // zero out the slop so that the sanity checker can tell @@ -312,10 +312,10 @@ threadPaused(Capability *cap, StgTSO *tso) // first we turn it into a WHITEHOLE to claim it, and if // successful we write our TSO and then the BLACKHOLE info pointer. cur_bh_info = (const StgInfoTable *) - cas((StgVolatilePtr)&bh->header.info, - (StgWord)bh_info, + cas((StgVolatilePtr)&bh->header.info, + (StgWord)bh_info, (StgWord)&stg_WHITEHOLE_info); - + if (cur_bh_info != bh_info) { bh_info = cur_bh_info; goto retry; @@ -332,44 +332,44 @@ threadPaused(Capability *cap, StgTSO *tso) // We pretend that bh has just been created. LDV_RECORD_CREATE(bh); - - frame = (StgClosure *) ((StgUpdateFrame *)frame + 1); - if (prev_was_update_frame) { - words_to_squeeze += sizeofW(StgUpdateFrame); - weight += weight_pending; - weight_pending = 0; - } - prev_was_update_frame = rtsTrue; - break; - + + frame = (StgClosure *) ((StgUpdateFrame *)frame + 1); + if (prev_was_update_frame) { + words_to_squeeze += sizeofW(StgUpdateFrame); + weight += weight_pending; + weight_pending = 0; + } + prev_was_update_frame = rtsTrue; + break; + case UNDERFLOW_FRAME: case STOP_FRAME: - goto end; - - // normal stack frames; do nothing except advance the pointer - default: - { - nat frame_size = stack_frame_sizeW(frame); - weight_pending += frame_size; - frame = (StgClosure *)((StgPtr)frame + frame_size); - prev_was_update_frame = rtsFalse; - } - } + goto end; + + // normal stack frames; do nothing except advance the pointer + default: + { + nat frame_size = stack_frame_sizeW(frame); + weight_pending += frame_size; + frame = (StgClosure *)((StgPtr)frame + frame_size); + prev_was_update_frame = rtsFalse; + } + } } end: - debugTrace(DEBUG_squeeze, - "words_to_squeeze: %d, weight: %d, squeeze: %s", - words_to_squeeze, weight, + debugTrace(DEBUG_squeeze, + "words_to_squeeze: %d, weight: %d, squeeze: %s", + words_to_squeeze, weight, ((weight <= 8 && words_to_squeeze > 0) || weight < words_to_squeeze) ? "YES" : "NO"); // Should we squeeze or not? Arbitrary heuristic: we squeeze if // the number of words we have to shift down is less than the // number of stack words we squeeze away by doing so. if (RtsFlags.GcFlags.squeezeUpdFrames == rtsTrue && - ((weight <= 8 && words_to_squeeze > 0) || weight < words_to_squeeze)) { + ((weight <= 8 && words_to_squeeze > 0) || weight < words_to_squeeze)) { // threshold above bumped from 5 to 8 as a result of #2797 - stackSqueeze(cap, tso, (StgPtr)frame); + stackSqueeze(cap, tso, (StgPtr)frame); tso->flags |= TSO_SQUEEZED; // This flag tells threadStackOverflow() that the stack was // squeezed, because it may not need to be expanded. @@ -377,3 +377,11 @@ end: tso->flags &= ~TSO_SQUEEZED; } } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/ThreadPaused.h b/rts/ThreadPaused.h index 197b8d3257..16cca35fea 100644 --- a/rts/ThreadPaused.h +++ b/rts/ThreadPaused.h @@ -12,3 +12,11 @@ RTS_PRIVATE void threadPaused ( Capability *cap, StgTSO * ); #endif /* THREADPAUSED_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Threads.c b/rts/Threads.c index af4353fc49..b1912d83f4 100644 --- a/rts/Threads.c +++ b/rts/Threads.c @@ -221,7 +221,7 @@ removeThreadFromDeQueue (Capability *cap, } } } - barf("removeThreadFromMVarQueue: not found"); + barf("removeThreadFromDeQueue: not found"); } /* ---------------------------------------------------------------------------- @@ -880,3 +880,11 @@ printThreadQueue(StgTSO *t) } #endif /* DEBUG */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Threads.h b/rts/Threads.h index 6d26610334..a1ff0803c4 100644 --- a/rts/Threads.h +++ b/rts/Threads.h @@ -52,3 +52,11 @@ void printThreadQueue (StgTSO *t); #include "EndPrivate.h" #endif /* THREADS_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Ticker.h b/rts/Ticker.h index 685a79e5d2..2958211ca1 100644 --- a/rts/Ticker.h +++ b/rts/Ticker.h @@ -21,3 +21,11 @@ void exitTicker (rtsBool wait); #include "EndPrivate.h" #endif /* TICKER_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Ticky.c b/rts/Ticky.c index 4547c0b249..b1581f01f8 100644 --- a/rts/Ticky.c +++ b/rts/Ticky.c @@ -619,3 +619,11 @@ printRegisteredCounterInfo (FILE *tf) } #endif /* TICKY_TICKY */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Ticky.h b/rts/Ticky.h index a32a7a6542..e666a9b2da 100644 --- a/rts/Ticky.h +++ b/rts/Ticky.h @@ -12,3 +12,11 @@ RTS_PRIVATE void PrintTickyInfo(void); #endif /* TICKY_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Timer.c b/rts/Timer.c index b7762f985c..c2c4caa035 100644 --- a/rts/Timer.c +++ b/rts/Timer.c @@ -133,3 +133,11 @@ exitTimer (rtsBool wait) exitTicker(wait); } } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Timer.h b/rts/Timer.h index b03ef0680f..8bd7da4d54 100644 --- a/rts/Timer.h +++ b/rts/Timer.h @@ -13,3 +13,11 @@ RTS_PRIVATE void initTimer (void); RTS_PRIVATE void exitTimer (rtsBool wait); #endif /* TIMER_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Trace.c b/rts/Trace.c index 21901891cb..4671919896 100644 --- a/rts/Trace.c +++ b/rts/Trace.c @@ -805,3 +805,11 @@ void dtraceUserMarkerWrapper(Capability *cap, char *msg) } #endif /* !defined(DEBUG) && !defined(TRACING) && defined(DTRACE) */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Trace.h b/rts/Trace.h index 31aefcb58d..0a207041fa 100644 --- a/rts/Trace.h +++ b/rts/Trace.h @@ -880,3 +880,11 @@ INLINE_HEADER void traceTaskDelete(Task *task STG_UNUSED) #include "EndPrivate.h" #endif /* TRACE_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Updates.h b/rts/Updates.h index 1bd742a746..36280b5b12 100644 --- a/rts/Updates.h +++ b/rts/Updates.h @@ -91,3 +91,11 @@ INLINE_HEADER void updateWithIndirection (Capability *cap, #endif #endif /* UPDATES_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/WSDeque.c b/rts/WSDeque.c index 8efd1bbe48..ef8c22072b 100644 --- a/rts/WSDeque.c +++ b/rts/WSDeque.c @@ -3,7 +3,7 @@ * (c) The GHC Team, 2009 * * Work-stealing Deque data structure - * + * * The implementation uses Double-Ended Queues with lock-free access * (thereby often called "deque") as described in * @@ -18,24 +18,24 @@ * array is accessed with indices modulo array-size. While this bears * the risk of overflow, we assume that (with 64 bit indices), a * program must run very long to reach that point. - * + * * The write end of the queue (position bottom) can only be used with * mutual exclusion, i.e. by exactly one caller at a time. At this * end, new items can be enqueued using pushBottom()/newSpark(), and * removed using popBottom()/reclaimSpark() (the latter implying a cas * synchronisation with potential concurrent readers for the case of * just one element). - * + * * Multiple readers can steal from the read end (position top), and * are synchronised without a lock, based on a cas of the top * position. One reader wins, the others return NULL for a failure. - * + * * Both popWSDeque and stealWSDeque also return NULL when the queue is empty. * * Testing: see testsuite/tests/rts/testwsdeque.c. If * there's anything wrong with the deque implementation, this test * will probably catch it. - * + * * ---------------------------------------------------------------------------*/ #include "PosixSource.h" @@ -56,7 +56,7 @@ static StgWord roundUp2(StgWord val) { StgWord rounded = 1; - + /* StgWord is unsigned anyway, only catch 0 */ if (val == 0) { barf("DeQue,roundUp2: invalid size 0 requested"); @@ -71,11 +71,11 @@ roundUp2(StgWord val) WSDeque * newWSDeque (nat size) { - StgWord realsize; + StgWord realsize; WSDeque *q; - + realsize = roundUp2(size); /* to compute modulo as a bitwise & */ - + q = (WSDeque*) stgMallocBytes(sizeof(WSDeque), /* admin fields */ "newWSDeque"); q->elements = stgMallocBytes(realsize * sizeof(StgClosurePtr), /* dataspace */ @@ -83,11 +83,11 @@ newWSDeque (nat size) q->top=0; q->bottom=0; q->topBound=0; /* read by writer, updated each time top is read */ - + q->size = realsize; /* power of 2 */ q->moduloSize = realsize - 1; /* n % size == n & moduloSize */ - - ASSERT_WSDEQUE_INVARIANTS(q); + + ASSERT_WSDEQUE_INVARIANTS(q); return q; } @@ -103,7 +103,7 @@ freeWSDeque (WSDeque *q) } /* ----------------------------------------------------------------------------- - * + * * popWSDeque: remove an element from the write end of the queue. * Returns the removed spark, and NULL if a race is lost or the pool * empty. @@ -123,9 +123,9 @@ popWSDeque (WSDeque *q) StgWord t, b; long currSize; void * removed; - - ASSERT_WSDEQUE_INVARIANTS(q); - + + ASSERT_WSDEQUE_INVARIANTS(q); + b = q->bottom; // "decrement b as a test, see what happens" @@ -153,7 +153,7 @@ popWSDeque (WSDeque *q) if (currSize > 0) { /* no danger, still elements in buffer after b-- */ // debugBelch("popWSDeque: t=%ld b=%ld = %ld\n", t, b, removed); return removed; - } + } /* otherwise, has someone meanwhile stolen the same (last) element? Check and increment top value to know */ if ( !(CASTOP(&(q->top),t,t+1)) ) { @@ -161,10 +161,10 @@ popWSDeque (WSDeque *q) } q->bottom = t+1; /* anyway, empty now. Adjust bottom consistently. */ q->topBound = t+1; /* ...and cached top value as well */ - - ASSERT_WSDEQUE_INVARIANTS(q); + + ASSERT_WSDEQUE_INVARIANTS(q); ASSERT(q->bottom >= q->top); - + // debugBelch("popWSDeque: t=%ld b=%ld = %ld\n", t, b, removed); return removed; @@ -178,27 +178,27 @@ void * stealWSDeque_ (WSDeque *q) { void * stolen; - StgWord b,t; - + StgWord b,t; + // Can't do this on someone else's spark pool: -// ASSERT_WSDEQUE_INVARIANTS(q); - +// ASSERT_WSDEQUE_INVARIANTS(q); + // NB. these loads must be ordered, otherwise there is a race // between steal and pop. t = q->top; load_load_barrier(); b = q->bottom; - + // NB. b and t are unsigned; we need a signed value for the test // below, because it is possible that t > b during a // concurrent popWSQueue() operation. - if ((long)b - (long)t <= 0 ) { + if ((long)b - (long)t <= 0 ) { return NULL; /* already looks empty, abort */ } - + /* now access array, see pushBottom() */ stolen = q->elements[t & q->moduloSize]; - + /* now decide whether we have won */ if ( !(CASTOP(&(q->top),t,t+1)) ) { /* lost the race, someon else has changed top in the meantime */ @@ -208,8 +208,8 @@ stealWSDeque_ (WSDeque *q) // debugBelch("stealWSDeque_: t=%d b=%d\n", t, b); // Can't do this on someone else's spark pool: -// ASSERT_WSDEQUE_INVARIANTS(q); - +// ASSERT_WSDEQUE_INVARIANTS(q); + return stolen; } @@ -217,11 +217,11 @@ void * stealWSDeque (WSDeque *q) { void *stolen; - - do { + + do { stolen = stealWSDeque_(q); } while (stolen == NULL && !looksEmptyWSDeque(q)); - + return stolen; } @@ -238,17 +238,17 @@ pushWSDeque (WSDeque* q, void * elem) { StgWord t; StgWord b; - StgWord sz = q->moduloSize; - - ASSERT_WSDEQUE_INVARIANTS(q); - + StgWord sz = q->moduloSize; + + ASSERT_WSDEQUE_INVARIANTS(q); + /* we try to avoid reading q->top (accessed by all) and use - q->topBound (accessed only by writer) instead. + q->topBound (accessed only by writer) instead. This is why we do not just call empty(q) here. */ b = q->bottom; t = q->topBound; - if ( (StgInt)b - (StgInt)t >= (StgInt)sz ) { + if ( (StgInt)b - (StgInt)t >= (StgInt)sz ) { /* NB. 1. sz == q->size - 1, thus ">=" 2. signed comparison, it is possible that t > b */ @@ -260,20 +260,20 @@ pushWSDeque (WSDeque* q, void * elem) will in the meantime use the old one and modify only top. This means: we cannot safely free the old space! Can keep it on a free list internally here... - + Potential bug in combination with steal(): if array is replaced, it is unclear which one concurrent steal operations use. Must read the array base address in advance in steal(). */ #if defined(DISCARD_NEW) - ASSERT_WSDEQUE_INVARIANTS(q); + ASSERT_WSDEQUE_INVARIANTS(q); return rtsFalse; // we didn't push anything #else /* could make room by incrementing the top position here. In * this case, should use CASTOP. If this fails, someone else has * removed something, and new room will be available. */ - ASSERT_WSDEQUE_INVARIANTS(q); + ASSERT_WSDEQUE_INVARIANTS(q); #endif } } @@ -289,7 +289,15 @@ pushWSDeque (WSDeque* q, void * elem) */ write_barrier(); q->bottom = b + 1; - - ASSERT_WSDEQUE_INVARIANTS(q); + + ASSERT_WSDEQUE_INVARIANTS(q); return rtsTrue; } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/WSDeque.h b/rts/WSDeque.h index 9c62478113..15e925a24d 100644 --- a/rts/WSDeque.h +++ b/rts/WSDeque.h @@ -3,7 +3,7 @@ * (c) The GHC Team, 2009 * * Work-stealing Deque data structure - * + * * ---------------------------------------------------------------------------*/ #ifndef WSDEQUE_H @@ -11,8 +11,8 @@ typedef struct WSDeque_ { // Size of elements array. Used for modulo calculation: we round up - // to powers of 2 and use the dyadic log (modulo == bitwise &) - StgWord size; + // to powers of 2 and use the dyadic log (modulo == bitwise &) + StgWord size; StgWord moduloSize; /* bitmask for modulo */ // top, index where multiple readers steal() (protected by a cas) @@ -24,7 +24,7 @@ typedef struct WSDeque_ { // both top and bottom are continuously incremented, and used as // an index modulo the current array size. - + // lower bound on the current top value. This is an internal // optimisation to avoid unnecessarily accessing the top field // inside pushBottom @@ -41,7 +41,7 @@ typedef struct WSDeque_ { /* INVARIANTS, in this order: reasonable size, topBound consistent, space pointer, space accessible to us. - + NB. This is safe to use only (a) on a spark pool owned by the current thread, or (b) when there's only one thread running, or no stealing going on (e.g. during GC). @@ -54,7 +54,7 @@ typedef struct WSDeque_ { ASSERT(*((p)->elements - 1 + ((p)->size)) || 1); // No: it is possible that top > bottom when using pop() -// ASSERT((p)->bottom >= (p)->top); +// ASSERT((p)->bottom >= (p)->top); // ASSERT((p)->size > (p)->bottom - (p)->top); /* ----------------------------------------------------------------------------- @@ -124,3 +124,11 @@ discardElements (WSDeque *q) } #endif // WSDEQUE_H + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Weak.c b/rts/Weak.c index 98ac7603b7..5ee38cca70 100644 --- a/rts/Weak.c +++ b/rts/Weak.c @@ -144,3 +144,11 @@ scheduleFinalizers(Capability *cap, StgWeak *list) ); scheduleThread(cap,t); } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/Weak.h b/rts/Weak.h index fbdf18a861..8121099116 100644 --- a/rts/Weak.h +++ b/rts/Weak.h @@ -25,3 +25,11 @@ void markWeakList(void); #endif /* WEAK_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/eventlog/EventLog.c b/rts/eventlog/EventLog.c index 2e0e9bbddc..a5a100e8d4 100644 --- a/rts/eventlog/EventLog.c +++ b/rts/eventlog/EventLog.c @@ -106,9 +106,10 @@ char *EventDesc[] = { [EVENT_TASK_CREATE] = "Task create", [EVENT_TASK_MIGRATE] = "Task migrate", [EVENT_TASK_DELETE] = "Task delete", + [EVENT_HACK_BUG_T9003] = "Empty event for bug #9003", }; -// Event type. +// Event type. typedef struct _EventType { EventTypeNum etNum; // Event Type number. @@ -134,7 +135,7 @@ static StgBool hasRoomForVariableEvent(EventsBuf *eb, nat payload_bytes); static inline void postWord8(EventsBuf *eb, StgWord8 i) { - *(eb->pos++) = i; + *(eb->pos++) = i; } static inline void postWord16(EventsBuf *eb, StgWord16 i) @@ -247,24 +248,25 @@ initEventLogging(void) // We don't have a FMT* symbol for pid_t, so we go via Word64 // to be sure of not losing range. It would be nicer to have a // FMT* symbol or similar, though. - sprintf(event_log_filename, "%s.%" FMT_Word64 ".eventlog", prog, (StgWord64)event_log_pid); + sprintf(event_log_filename, "%s.%" FMT_Word64 ".eventlog", + prog, (StgWord64)event_log_pid); } stgFree(prog); /* Open event log file for writing. */ if ((event_log_file = fopen(event_log_filename, "wb")) == NULL) { sysErrorBelch("initEventLogging: can't open %s", event_log_filename); - stg_exit(EXIT_FAILURE); + stg_exit(EXIT_FAILURE); } - /* + /* * Allocate buffer(s) to store events. * Create buffer large enough for the header begin marker, all event * types, and header end marker to prevent checking if buffer has room * for each of these steps, and remove the need to flush the buffer to * disk during initialization. * - * Use a single buffer to store the header with event types, then flush + * Use a single buffer to store the header with event types, then flush * the buffer so all buffers are empty for writing events. */ #ifdef THREADED_RTS @@ -302,8 +304,9 @@ initEventLogging(void) break; case EVENT_STOP_THREAD: // (cap, thread, status) - eventTypes[t].size = - sizeof(EventThreadID) + sizeof(StgWord16) + sizeof(EventThreadID); + eventTypes[t].size = sizeof(EventThreadID) + + sizeof(StgWord16) + + sizeof(EventThreadID); break; case EVENT_STARTUP: // (cap_count) @@ -402,8 +405,9 @@ initEventLogging(void) break; case EVENT_TASK_CREATE: // (taskId, cap, tid) - eventTypes[t].size = - sizeof(EventTaskId) + sizeof(EventCapNo) + sizeof(EventKernelThreadId); + eventTypes[t].size = sizeof(EventTaskId) + + sizeof(EventCapNo) + + sizeof(EventKernelThreadId); break; case EVENT_TASK_MIGRATE: // (taskId, cap, new_cap) @@ -416,10 +420,14 @@ initEventLogging(void) break; case EVENT_BLOCK_MARKER: - eventTypes[t].size = sizeof(StgWord32) + sizeof(EventTimestamp) + + eventTypes[t].size = sizeof(StgWord32) + sizeof(EventTimestamp) + sizeof(EventCapNo); break; + case EVENT_HACK_BUG_T9003: + eventTypes[t].size = 0; + break; + default: continue; /* ignore deprecated events */ } @@ -430,10 +438,10 @@ initEventLogging(void) // Mark end of event types in the header. postInt32(&eventBuf, EVENT_HET_END); - + // Write in buffer: the header end marker. postInt32(&eventBuf, EVENT_HEADER_END); - + // Prepare event buffer for events (data). postInt32(&eventBuf, EVENT_DATA_BEGIN); @@ -499,10 +507,10 @@ void freeEventLogging(void) { StgWord8 c; - + // Free events buffer. for (c = 0; c < n_capabilities; ++c) { - if (capEventBuf[c].begin != NULL) + if (capEventBuf[c].begin != NULL) stgFree(capEventBuf[c].begin); } if (capEventBuf != NULL) { @@ -513,7 +521,7 @@ freeEventLogging(void) } } -void +void flushEventLog(void) { if (event_log_file != NULL) { @@ -521,7 +529,7 @@ flushEventLog(void) } } -void +void abortEventLogging(void) { freeEventLogging(); @@ -534,9 +542,9 @@ abortEventLogging(void) * If the buffer is full, prints out the buffer and clears it. */ void -postSchedEvent (Capability *cap, - EventTypeNum tag, - StgThreadID thread, +postSchedEvent (Capability *cap, + EventTypeNum tag, + StgThreadID thread, StgWord info1, StgWord info2) { @@ -548,7 +556,7 @@ postSchedEvent (Capability *cap, // Flush event buffer to make room for new event. printAndClearEventBuf(eb); } - + postEventHeader(eb, tag); switch (tag) { @@ -632,7 +640,7 @@ postSparkEvent (Capability *cap, } void -postSparkCountersEvent (Capability *cap, +postSparkCountersEvent (Capability *cap, SparkCounters counters, StgWord remaining) { @@ -644,7 +652,7 @@ postSparkCountersEvent (Capability *cap, // Flush event buffer to make room for new event. printAndClearEventBuf(eb); } - + postEventHeader(eb, EVENT_SPARK_COUNTERS); /* EVENT_SPARK_COUNTERS (crt,dud,ovf,cnv,gcd,fiz,rem) */ postWord64(eb,counters.created); @@ -666,7 +674,7 @@ postCapEvent (EventTypeNum tag, // Flush event buffer to make room for new event. printAndClearEventBuf(&eventBuf); } - + postEventHeader(&eventBuf, tag); switch (tag) { @@ -802,7 +810,7 @@ void postWallClockTime (EventCapsetID capset) StgWord32 nsec; ACQUIRE_LOCK(&eventBufMutex); - + /* The EVENT_WALL_CLOCK_TIME event is intended to allow programs reading the eventlog to match up the event timestamps with wall clock time. The normal event timestamps measure time since the @@ -818,7 +826,7 @@ void postWallClockTime (EventCapsetID capset) the elapsed time vs the wall clock time. So to minimise the difference we just call them very close together. */ - + getUnixEpochTime(&sec, &nsec); /* Get the wall clock time */ ts = time_ns(); /* Get the eventlog timestamp */ @@ -832,7 +840,7 @@ void postWallClockTime (EventCapsetID capset) timestamp we already generated above. */ postEventTypeNum(&eventBuf, EVENT_WALL_CLOCK_TIME); postWord64(&eventBuf, ts); - + /* EVENT_WALL_CLOCK_TIME (capset, unix_epoch_seconds, nanoseconds) */ postCapsetID(&eventBuf, capset); postWord64(&eventBuf, sec); @@ -857,7 +865,7 @@ void postHeapEvent (Capability *cap, // Flush event buffer to make room for new event. printAndClearEventBuf(eb); } - + postEventHeader(eb, tag); switch (tag) { @@ -921,7 +929,7 @@ void postEventGcStats (Capability *cap, // Flush event buffer to make room for new event. printAndClearEventBuf(eb); } - + postEventHeader(eb, EVENT_GC_STATS_GHC); /* EVENT_GC_STATS_GHC (heap_capset, generation, copied_bytes, slop_bytes, frag_bytes, @@ -1064,7 +1072,7 @@ void postCapMsg(Capability *cap, char *msg, va_list ap) void postUserMsg(Capability *cap, char *msg, va_list ap) { postLogMsg(&capEventBuf[cap->no], EVENT_USER_MSG, msg, ap); -} +} void postEventStartup(EventCapNo n_caps) { @@ -1171,7 +1179,7 @@ void printAndClearEventBuf (EventsBuf *ebuf) if (ebuf->begin != NULL && ebuf->pos != ebuf->begin) { numBytes = ebuf->pos - ebuf->begin; - + written = fwrite(ebuf->begin, 1, numBytes, event_log_file); if (written != numBytes) { debugBelch( @@ -1179,7 +1187,7 @@ void printAndClearEventBuf (EventsBuf *ebuf) " doesn't match numBytes=%" FMT_Word64, written, numBytes); return; } - + resetEventsBuf(ebuf); flushCount++; @@ -1226,7 +1234,7 @@ StgBool hasRoomForVariableEvent(EventsBuf *eb, nat payload_bytes) } else { return 1; // Buf has enough space for the event. } -} +} void postEventType(EventsBuf *eb, EventType *et) { @@ -1246,3 +1254,11 @@ void postEventType(EventsBuf *eb, EventType *et) } #endif /* TRACING */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/eventlog/EventLog.h b/rts/eventlog/EventLog.h index 85370e9843..ff5e116d6b 100644 --- a/rts/eventlog/EventLog.h +++ b/rts/eventlog/EventLog.h @@ -170,3 +170,11 @@ INLINE_HEADER void postThreadLabel(Capability *cap STG_UNUSED, #include "EndPrivate.h" #endif /* TRACING_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/ghc.mk b/rts/ghc.mk index 0d2b341a51..c5dc06e0e3 100644 --- a/rts/ghc.mk +++ b/rts/ghc.mk @@ -188,7 +188,7 @@ ifneq "$$(findstring dyn, $1)" "" ifeq "$$(HostOS_CPP)" "mingw32" $$(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 \ + "$$(rts_dist_HC)" -this-package-key rts -shared -dynamic -dynload deploy \ -no-auto-link-packages -Lrts/dist/build -l$$(LIBFFI_NAME) \ `cat rts/dist/libs.depend` $$(rts_$1_OBJS) $$(ALL_RTS_DEF_LIBS) \ $$(rts_dist_$1_GHC_LD_OPTS) \ @@ -209,7 +209,7 @@ LIBFFI_LIBS = endif $$(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 \ + "$$(rts_dist_HC)" -this-package-key rts -shared -dynamic -dynload deploy \ -no-auto-link-packages $$(LIBFFI_LIBS) `cat rts/dist/libs.depend` $$(rts_$1_OBJS) \ $$(rts_dist_$1_GHC_LD_OPTS) \ $$(rts_$1_DTRACE_OBJS) -o $$@ @@ -283,7 +283,7 @@ STANDARD_OPTS += -DCOMPILING_RTS rts_CC_OPTS += $(WARNING_OPTS) rts_CC_OPTS += $(STANDARD_OPTS) -rts_HC_OPTS += $(STANDARD_OPTS) -package-name rts +rts_HC_OPTS += $(STANDARD_OPTS) -this-package-key rts ifneq "$(GhcWithSMP)" "YES" rts_CC_OPTS += -DNOSMP diff --git a/rts/hooks/FlagDefaults.c b/rts/hooks/FlagDefaults.c index ce1666f06d..18cc76c8f9 100644 --- a/rts/hooks/FlagDefaults.c +++ b/rts/hooks/FlagDefaults.c @@ -19,3 +19,11 @@ defaultsHook (void) */ } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/hooks/MallocFail.c b/rts/hooks/MallocFail.c index 6c3a1a0faf..2c63f88472 100644 --- a/rts/hooks/MallocFail.c +++ b/rts/hooks/MallocFail.c @@ -15,3 +15,11 @@ MallocFailHook (W_ request_size /* in bytes */, char *msg) fprintf(stderr, "malloc: failed on request for %" FMT_Word " bytes; message: %s\n", request_size, msg); } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/hooks/OnExit.c b/rts/hooks/OnExit.c index 30764acba2..d99cb83ac3 100644 --- a/rts/hooks/OnExit.c +++ b/rts/hooks/OnExit.c @@ -18,3 +18,11 @@ void OnExitHook (void) { } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/hooks/OutOfHeap.c b/rts/hooks/OutOfHeap.c index ec4697b547..8998b4d176 100644 --- a/rts/hooks/OutOfHeap.c +++ b/rts/hooks/OutOfHeap.c @@ -22,3 +22,11 @@ OutOfHeapHook (W_ request_size, W_ heap_size) /* both sizes in bytes */ } } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/hooks/StackOverflow.c b/rts/hooks/StackOverflow.c index 407293902d..50995b8430 100644 --- a/rts/hooks/StackOverflow.c +++ b/rts/hooks/StackOverflow.c @@ -15,3 +15,11 @@ StackOverflowHook (W_ stack_size) /* in bytes */ fprintf(stderr, "Stack space overflow: current size %" FMT_Word " bytes.\nUse `+RTS -Ksize -RTS' to increase it.\n", stack_size); } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/package.conf.in b/rts/package.conf.in index 8250bc2bb6..82d2870cde 100644 --- a/rts/package.conf.in +++ b/rts/package.conf.in @@ -6,6 +6,7 @@ name: rts version: 1.0 id: builtin_rts +key: rts license: BSD3 maintainer: glasgow-haskell-users@haskell.org exposed: True @@ -16,7 +17,7 @@ hidden-modules: import-dirs: #ifdef INSTALLING -library-dirs: LIB_DIR"/rts-1.0" PAPI_LIB_DIR FFI_LIB_DIR +library-dirs: LIB_DIR"/rts" PAPI_LIB_DIR FFI_LIB_DIR #else /* !INSTALLING */ library-dirs: TOP"/rts/dist/build" PAPI_LIB_DIR FFI_LIB_DIR #endif diff --git a/rts/posix/Clock.h b/rts/posix/Clock.h index 2c71d7a75d..16d9252460 100644 --- a/rts/posix/Clock.h +++ b/rts/posix/Clock.h @@ -33,3 +33,11 @@ #endif #endif /* POSIX_CLOCK_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/posix/GetEnv.c b/rts/posix/GetEnv.c index 4d5c7e248e..de6d5cd989 100644 --- a/rts/posix/GetEnv.c +++ b/rts/posix/GetEnv.c @@ -32,7 +32,7 @@ static char** get_environ(void) { return environ; } void getProgEnvv(int *out_envc, char **out_envv[]) { int envc; char **environ = get_environ(); - + for (envc = 0; environ[envc] != NULL; envc++) {}; *out_envc = envc; @@ -42,3 +42,11 @@ void getProgEnvv(int *out_envc, char **out_envv[]) { void freeProgEnvv(int envc STG_UNUSED, char *envv[] STG_UNUSED) { /* nothing */ } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/posix/GetTime.c b/rts/posix/GetTime.c index 380e22931b..d44fc9a566 100644 --- a/rts/posix/GetTime.c +++ b/rts/posix/GetTime.c @@ -50,7 +50,11 @@ void initializeTimer() Time getProcessCPUTime(void) { -#if !defined(BE_CONSERVATIVE) && defined(HAVE_CLOCK_GETTIME) && defined (_SC_CPUTIME) && defined(CLOCK_PROCESS_CPUTIME_ID) && defined(HAVE_SYSCONF) +#if !defined(BE_CONSERVATIVE) && \ + defined(HAVE_CLOCK_GETTIME) && \ + defined(_SC_CPUTIME) && \ + defined(CLOCK_PROCESS_CPUTIME_ID) && \ + defined(HAVE_SYSCONF) static int checked_sysconf = 0; static int sysconf_result = 0; @@ -129,7 +133,7 @@ Time getProcessCPUTime(void) #if !defined(THREADED_RTS) && USE_PAPI long long usec; if ((usec = PAPI_get_virt_usec()) < 0) { - barf("PAPI_get_virt_usec: %lld", usec); + barf("PAPI_get_virt_usec: %lld", usec); } return USToTime(usec); #else @@ -152,22 +156,22 @@ void getProcessTimes(Time *user, Time *elapsed) if (ClockFreq == 0) { #if defined(HAVE_SYSCONF) - long ticks; - ticks = sysconf(_SC_CLK_TCK); - if ( ticks == -1 ) { - sysErrorBelch("sysconf"); - stg_exit(EXIT_FAILURE); - } - ClockFreq = ticks; -#elif defined(CLK_TCK) /* defined by POSIX */ - ClockFreq = CLK_TCK; + long ticks; + ticks = sysconf(_SC_CLK_TCK); + if ( ticks == -1 ) { + sysErrorBelch("sysconf"); + stg_exit(EXIT_FAILURE); + } + ClockFreq = ticks; +#elif defined(CLK_TCK) /* defined by POSIX */ + ClockFreq = CLK_TCK; #elif defined(HZ) - ClockFreq = HZ; + ClockFreq = HZ; #elif defined(CLOCKS_PER_SEC) - ClockFreq = CLOCKS_PER_SEC; + ClockFreq = CLOCKS_PER_SEC; #else - errorBelch("can't get clock resolution"); - stg_exit(EXIT_FAILURE); + errorBelch("can't get clock resolution"); + stg_exit(EXIT_FAILURE); #endif } @@ -184,15 +188,19 @@ Time getThreadCPUTime(void) #if USE_PAPI long long usec; if ((usec = PAPI_get_virt_usec()) < 0) { - barf("PAPI_get_virt_usec: %lld", usec); + barf("PAPI_get_virt_usec: %lld", usec); } return USToTime(usec); -#elif !defined(BE_CONSERVATIVE) && defined(HAVE_CLOCK_GETTIME) && defined (_SC_THREAD_CPUTIME) && defined(CLOCK_THREAD_CPUTIME_ID) && defined(HAVE_SYSCONF) +#elif !defined(BE_CONSERVATIVE) && \ + defined(HAVE_CLOCK_GETTIME) && \ + defined(_SC_CPUTIME) && \ + defined(CLOCK_PROCESS_CPUTIME_ID) && \ + defined(HAVE_SYSCONF) { static int checked_sysconf = 0; static int sysconf_result = 0; - + if (!checked_sysconf) { sysconf_result = sysconf(_SC_THREAD_CPUTIME); checked_sysconf = 1; @@ -240,3 +248,10 @@ getPageFaults(void) #endif } +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/posix/Itimer.c b/rts/posix/Itimer.c index 4bcc3a1c2e..f8b9f66d4d 100644 --- a/rts/posix/Itimer.c +++ b/rts/posix/Itimer.c @@ -9,10 +9,10 @@ /* * The interval timer is used for profiling and for context switching in the * threaded build. Though POSIX 1003.1b includes a standard interface for - * such things, no one really seems to be implementing them yet. Even + * such things, no one really seems to be implementing them yet. Even * Solaris 2.3 only seems to provide support for @CLOCK_REAL@, whereas we're * keen on getting access to @CLOCK_VIRTUAL@. - * + * * Hence, we use the old-fashioned @setitimer@ that just about everyone seems * to support. So much for standards. */ @@ -202,11 +202,11 @@ startTicker(void) #elif defined(USE_TIMER_CREATE) { struct itimerspec it; - + it.it_value.tv_sec = TimeToSeconds(itimer_interval); it.it_value.tv_nsec = TimeToNS(itimer_interval) % 1000000000; it.it_interval = it.it_value; - + if (timer_settime(timer, 0, &it, NULL) != 0) { sysErrorBelch("timer_settime"); stg_exit(EXIT_FAILURE); @@ -219,7 +219,7 @@ startTicker(void) it.it_value.tv_sec = TimeToSeconds(itimer_interval); it.it_value.tv_usec = TimeToUS(itimer_interval) % 1000000; it.it_interval = it.it_value; - + if (setitimer(ITIMER_REAL, &it, NULL) != 0) { sysErrorBelch("setitimer"); stg_exit(EXIT_FAILURE); @@ -280,3 +280,11 @@ rtsTimerSignal(void) { return ITIMER_SIGNAL; } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/posix/Itimer.h b/rts/posix/Itimer.h index 7996da7c94..3ca2f5b097 100644 --- a/rts/posix/Itimer.h +++ b/rts/posix/Itimer.h @@ -10,3 +10,11 @@ #define ITIMER_H #endif /* ITIMER_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/posix/OSMem.c b/rts/posix/OSMem.c index 69140a914c..eb51e98e72 100644 --- a/rts/posix/OSMem.c +++ b/rts/posix/OSMem.c @@ -81,13 +81,13 @@ my_mmap (void *addr, W_ size) void *ret; #if defined(solaris2_HOST_OS) || defined(irix_HOST_OS) - { + { int fd = open("/dev/zero",O_RDONLY); ret = mmap(addr, size, PROT_READ | PROT_WRITE, MAP_PRIVATE, fd, 0); close(fd); } #elif hpux_HOST_OS - ret = mmap(addr, size, PROT_READ | PROT_WRITE, + ret = mmap(addr, size, PROT_READ | PROT_WRITE, MAP_ANONYMOUS | MAP_PRIVATE, -1, 0); #elif darwin_HOST_OS // Without MAP_FIXED, Apple's mmap ignores addr. @@ -97,21 +97,23 @@ my_mmap (void *addr, W_ size) // This behaviour seems to be conformant with IEEE Std 1003.1-2001. // Let's just use the underlying Mach Microkernel calls directly, // they're much nicer. - + kern_return_t err = 0; ret = addr; if(addr) // try to allocate at address err = vm_allocate(mach_task_self(),(vm_address_t*) &ret, size, FALSE); if(!addr || err) // try to allocate anywhere err = vm_allocate(mach_task_self(),(vm_address_t*) &ret, size, TRUE); - + if(err) { // don't know what the error codes mean exactly, assume it's // not our problem though. - errorBelch("memory allocation failed (requested %" FMT_Word " bytes)", size); + errorBelch("memory allocation failed (requested %" FMT_Word " bytes)", + size); stg_exit(EXIT_FAILURE); } else { - vm_protect(mach_task_self(),(vm_address_t)ret,size,FALSE,VM_PROT_READ|VM_PROT_WRITE); + vm_protect(mach_task_self(), (vm_address_t)ret, size, FALSE, + VM_PROT_READ|VM_PROT_WRITE); } #elif linux_HOST_OS ret = mmap(addr, size, PROT_READ | PROT_WRITE, @@ -135,12 +137,12 @@ my_mmap (void *addr, W_ size) } } #else - ret = mmap(addr, size, PROT_READ | PROT_WRITE, + ret = mmap(addr, size, PROT_READ | PROT_WRITE, MAP_ANON | MAP_PRIVATE, -1, 0); #endif if (ret == (void *)-1) { - if (errno == ENOMEM || + if (errno == ENOMEM || (errno == EINVAL && sizeof(void*)==4 && size >= 0xc0000000)) { // If we request more than 3Gig, then we get EINVAL // instead of ENOMEM (at least on Linux). @@ -167,10 +169,10 @@ gen_map_mblocks (W_ size) // it (unmap the rest). size += MBLOCK_SIZE; ret = my_mmap(0, size); - + // unmap the slop bits around the chunk we allocated slop = (W_)ret & MBLOCK_MASK; - + if (munmap((void*)ret, MBLOCK_SIZE - slop) == -1) { barf("gen_map_mblocks: munmap failed"); } @@ -188,7 +190,7 @@ gen_map_mblocks (W_ size) // you unmap the extra mblock mmap()ed here (or simply // satisfy yourself that the slop introduced isn't worth // salvaging.) - // + // // next time, try after the block we just got. ret += MBLOCK_SIZE - slop; @@ -210,7 +212,9 @@ osGetMBlocks(nat n) if (((W_)ret & MBLOCK_MASK) != 0) { // misaligned block! #if 0 // defined(DEBUG) - errorBelch("warning: getMBlock: misaligned block %p returned when allocating %d megablock(s) at %p", ret, n, next_request); + errorBelch("warning: getMBlock: misaligned block %p returned " + "when allocating %d megablock(s) at %p", + ret, n, next_request); #endif // unmap this block... @@ -289,7 +293,8 @@ StgWord64 getPhysicalMemorySize (void) long ret = sysconf(_SC_PHYS_PAGES); if (ret == -1) { #if defined(DEBUG) - errorBelch("warning: getPhysicalMemorySize: cannot get physical memory size"); + errorBelch("warning: getPhysicalMemorySize: cannot get " + "physical memory size"); #endif return 0; } @@ -308,8 +313,16 @@ void setExecutable (void *p, W_ len, rtsBool exec) StgWord startOfFirstPage = ((StgWord)p ) & mask; StgWord startOfLastPage = ((StgWord)p + len - 1) & mask; StgWord size = startOfLastPage - startOfFirstPage + pageSize; - if (mprotect((void*)startOfFirstPage, (size_t)size, + if (mprotect((void*)startOfFirstPage, (size_t)size, (exec ? PROT_EXEC : 0) | PROT_READ | PROT_WRITE) != 0) { barf("setExecutable: failed to protect 0x%p\n", p); } } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/posix/OSThreads.c b/rts/posix/OSThreads.c index 13a176c9d2..f42b4e964c 100644 --- a/rts/posix/OSThreads.c +++ b/rts/posix/OSThreads.c @@ -3,7 +3,7 @@ * (c) The GHC Team, 2001-2005 * * Accessing OS threads functionality in a (mostly) OS-independent - * manner. + * manner. * * --------------------------------------------------------------------------*/ @@ -18,7 +18,7 @@ #if defined(freebsd_HOST_OS) /* Inclusion of system headers usually requires __BSD_VISIBLE on FreeBSD, * because of some specific types, like u_char, u_int, etc. */ -#define __BSD_VISIBLE 1 +#define __BSD_VISIBLE 1 #endif #include "Rts.h" @@ -175,7 +175,7 @@ newThreadLocalKey (ThreadLocalKey *key) { int r; if ((r = pthread_key_create(key, NULL)) != 0) { - barf("newThreadLocalKey: %s", strerror(r)); + barf("newThreadLocalKey: %s", strerror(r)); } } @@ -194,7 +194,7 @@ setThreadLocalVar (ThreadLocalKey *key, void *value) { int r; if ((r = pthread_setspecific(*key,value)) != 0) { - barf("setThreadLocalVar: %s", strerror(r)); + barf("setThreadLocalVar: %s", strerror(r)); } } @@ -203,7 +203,7 @@ freeThreadLocalKey (ThreadLocalKey *key) { int r; if ((r = pthread_key_delete(*key)) != 0) { - barf("freeThreadLocalKey: %s", strerror(r)); + barf("freeThreadLocalKey: %s", strerror(r)); } } @@ -222,7 +222,7 @@ forkOS_createThread ( HsStablePtr entry ) { pthread_t tid; int result = pthread_create(&tid, NULL, - forkOS_createThreadWrapper, (void*)entry); + forkOS_createThreadWrapper, (void*)entry); if(!result) pthread_detach(tid); return result; @@ -277,33 +277,34 @@ setThreadAffinity (nat n, nat m GNUC3_ATTRIBUTE(__unused__)) thread_affinity_policy_data_t policy; policy.affinity_tag = n; - thread_policy_set(mach_thread_self(), - THREAD_AFFINITY_POLICY, - (thread_policy_t) &policy, - THREAD_AFFINITY_POLICY_COUNT); + thread_policy_set(mach_thread_self(), + THREAD_AFFINITY_POLICY, + (thread_policy_t) &policy, + THREAD_AFFINITY_POLICY_COUNT); } #elif defined(HAVE_SYS_CPUSET_H) /* FreeBSD 7.1+ */ void setThreadAffinity(nat n, nat m) { - nat nproc; - cpuset_t cs; - nat i; + nat nproc; + cpuset_t cs; + nat i; - nproc = getNumberOfProcessors(); - CPU_ZERO(&cs); + nproc = getNumberOfProcessors(); + CPU_ZERO(&cs); - for (i = n; i < nproc; i += m) - CPU_SET(i, &cs); + for (i = n; i < nproc; i += m) + CPU_SET(i, &cs); - cpuset_setaffinity(CPU_LEVEL_WHICH, CPU_WHICH_TID, -1, sizeof(cpuset_t), &cs); + cpuset_setaffinity(CPU_LEVEL_WHICH, CPU_WHICH_TID, + -1, sizeof(cpuset_t), &cs); } #else void -setThreadAffinity (nat n GNUC3_ATTRIBUTE(__unused__), - nat m GNUC3_ATTRIBUTE(__unused__)) +setThreadAffinity (nat n GNUC3_ATTRIBUTE(__unused__), + nat m GNUC3_ATTRIBUTE(__unused__)) { } #endif @@ -340,7 +341,9 @@ KernelThreadId kernelThreadId (void) return pthread_getthreadid_np(); // Check for OS X >= 10.6 (see #7356) -#elif defined(darwin_HOST_OS) && !(defined(__MAC_OS_X_VERSION_MIN_REQUIRED) && __MAC_OS_X_VERSION_MIN_REQUIRED < 1060) +#elif defined(darwin_HOST_OS) && \ + !(defined(__MAC_OS_X_VERSION_MIN_REQUIRED) && \ + __MAC_OS_X_VERSION_MIN_REQUIRED < 1060) uint64_t ktid; pthread_threadid_np(NULL, &ktid); return ktid; @@ -350,3 +353,11 @@ KernelThreadId kernelThreadId (void) return 0; #endif } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/posix/Select.c b/rts/posix/Select.c index a101f03dd5..29a1dd144d 100644 --- a/rts/posix/Select.c +++ b/rts/posix/Select.c @@ -100,17 +100,18 @@ static rtsBool wakeUpSleepingThreads (LowResTime now) rtsBool flag = rtsFalse; while (sleeping_queue != END_TSO_QUEUE) { - tso = sleeping_queue; + tso = sleeping_queue; if (((long)now - (long)tso->block_info.target) < 0) { break; } - sleeping_queue = tso->_link; - tso->why_blocked = NotBlocked; - tso->_link = END_TSO_QUEUE; - IF_DEBUG(scheduler,debugBelch("Waking up sleeping thread %lu\n", (unsigned long)tso->id)); - // MainCapability: this code is !THREADED_RTS - pushOnRunQueue(&MainCapability,tso); - flag = rtsTrue; + sleeping_queue = tso->_link; + tso->why_blocked = NotBlocked; + tso->_link = END_TSO_QUEUE; + IF_DEBUG(scheduler, debugBelch("Waking up sleeping thread %lu\n", + (unsigned long)tso->id)); + // MainCapability: this code is !THREADED_RTS + pushOnRunQueue(&MainCapability,tso); + flag = rtsTrue; } return flag; } @@ -118,7 +119,9 @@ static rtsBool wakeUpSleepingThreads (LowResTime now) static void GNUC3_ATTRIBUTE(__noreturn__) fdOutOfRange (int fd) { - errorBelch("file descriptor %d out of range for select (0--%d).\nRecompile with -threaded to work around this.", fd, (int)FD_SETSIZE); + errorBelch("file descriptor %d out of range for select (0--%d).\n" + "Recompile with -threaded to work around this.", + fd, (int)FD_SETSIZE); stg_exit(EXIT_FAILURE); } @@ -226,12 +229,12 @@ awaitEvent(rtsBool wait) LowResTime now; IF_DEBUG(scheduler, - debugBelch("scheduler: checking for threads blocked on I/O"); - if (wait) { - debugBelch(" (waiting)"); - } - debugBelch("\n"); - ); + debugBelch("scheduler: checking for threads blocked on I/O"); + if (wait) { + debugBelch(" (waiting)"); + } + debugBelch("\n"); + ); /* loop until we've woken up some threads. This loop is needed * because the select timing isn't accurate, we sometimes sleep @@ -242,7 +245,7 @@ awaitEvent(rtsBool wait) now = getLowResTimeOfDay(); if (wakeUpSleepingThreads(now)) { - return; + return; } /* @@ -252,38 +255,38 @@ awaitEvent(rtsBool wait) FD_ZERO(&wfd); for(tso = blocked_queue_hd; tso != END_TSO_QUEUE; tso = next) { - next = tso->_link; + next = tso->_link; /* On FreeBSD FD_SETSIZE is unsigned. Cast it to signed int * in order to switch off the 'comparison between signed and * unsigned error message */ - switch (tso->why_blocked) { - case BlockedOnRead: - { - int fd = tso->block_info.fd; - if ((fd >= (int)FD_SETSIZE) || (fd < 0)) { + switch (tso->why_blocked) { + case BlockedOnRead: + { + int fd = tso->block_info.fd; + if ((fd >= (int)FD_SETSIZE) || (fd < 0)) { fdOutOfRange(fd); - } - maxfd = (fd > maxfd) ? fd : maxfd; - FD_SET(fd, &rfd); - continue; - } - - case BlockedOnWrite: - { - int fd = tso->block_info.fd; - if ((fd >= (int)FD_SETSIZE) || (fd < 0)) { + } + maxfd = (fd > maxfd) ? fd : maxfd; + FD_SET(fd, &rfd); + continue; + } + + case BlockedOnWrite: + { + int fd = tso->block_info.fd; + if ((fd >= (int)FD_SETSIZE) || (fd < 0)) { fdOutOfRange(fd); - } - maxfd = (fd > maxfd) ? fd : maxfd; - FD_SET(fd, &wfd); - continue; - } - - default: - barf("AwaitEvent"); - } + } + maxfd = (fd > maxfd) ? fd : maxfd; + FD_SET(fd, &wfd); + continue; + } + + default: + barf("AwaitEvent"); + } } if (!wait) { @@ -301,46 +304,46 @@ awaitEvent(rtsBool wait) } /* Check for any interesting events */ - + while ((numFound = select(maxfd+1, &rfd, &wfd, NULL, ptv)) < 0) { - if (errno != EINTR) { - if ( errno == EBADF ) { + if (errno != EINTR) { + if ( errno == EBADF ) { seen_bad_fd = rtsTrue; break; - } else { + } else { sysErrorBelch("select"); stg_exit(EXIT_FAILURE); } - } + } - /* We got a signal; could be one of ours. If so, we need - * to start up the signal handler straight away, otherwise - * we could block for a long time before the signal is - * serviced. - */ + /* We got a signal; could be one of ours. If so, we need + * to start up the signal handler straight away, otherwise + * we could block for a long time before the signal is + * serviced. + */ #if defined(RTS_USER_SIGNALS) - if (RtsFlags.MiscFlags.install_signal_handlers && signals_pending()) { - startSignalHandlers(&MainCapability); - return; /* still hold the lock */ - } + if (RtsFlags.MiscFlags.install_signal_handlers && signals_pending()) { + startSignalHandlers(&MainCapability); + return; /* still hold the lock */ + } #endif - /* we were interrupted, return to the scheduler immediately. - */ - if (sched_state >= SCHED_INTERRUPTING) { - return; /* still hold the lock */ - } - - /* check for threads that need waking up - */ + /* we were interrupted, return to the scheduler immediately. + */ + if (sched_state >= SCHED_INTERRUPTING) { + return; /* still hold the lock */ + } + + /* check for threads that need waking up + */ wakeUpSleepingThreads(getLowResTimeOfDay()); - /* If new runnable threads have arrived, stop waiting for - * I/O and run them. - */ - if (!emptyRunQueue(&MainCapability)) { - return; /* still hold the lock */ - } + /* If new runnable threads have arrived, stop waiting for + * I/O and run them. + */ + if (!emptyRunQueue(&MainCapability)) { + return; /* still hold the lock */ + } } /* Step through the waiting queue, unblocking every thread that now has @@ -383,11 +386,16 @@ awaitEvent(rtsBool wait) * Don't let RTS loop on such descriptors, * pass an IOError to blocked threads (Trac #4934) */ - IF_DEBUG(scheduler,debugBelch("Killing blocked thread %lu on bad fd=%i\n", (unsigned long)tso->id, fd)); - throwToSingleThreaded(&MainCapability, tso, (StgClosure *)blockedOnBadFD_closure); + IF_DEBUG(scheduler, + debugBelch("Killing blocked thread %lu on bad fd=%i\n", + (unsigned long)tso->id, fd)); + throwToSingleThreaded(&MainCapability, tso, + (StgClosure *)blockedOnBadFD_closure); break; case RTS_FD_IS_READY: - IF_DEBUG(scheduler,debugBelch("Waking up blocked thread %lu\n", (unsigned long)tso->id)); + IF_DEBUG(scheduler, + debugBelch("Waking up blocked thread %lu\n", + (unsigned long)tso->id)); tso->why_blocked = NotBlocked; tso->_link = END_TSO_QUEUE; pushOnRunQueue(&MainCapability,tso); @@ -400,19 +408,26 @@ awaitEvent(rtsBool wait) prev = tso; break; } - } - - if (prev == NULL) - blocked_queue_hd = blocked_queue_tl = END_TSO_QUEUE; - else { - prev->_link = END_TSO_QUEUE; - blocked_queue_tl = prev; - } + } + + if (prev == NULL) + blocked_queue_hd = blocked_queue_tl = END_TSO_QUEUE; + else { + prev->_link = END_TSO_QUEUE; + blocked_queue_tl = prev; + } } - + } while (wait && sched_state == SCHED_RUNNING - && emptyRunQueue(&MainCapability)); + && emptyRunQueue(&MainCapability)); } #endif /* THREADED_RTS */ +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/posix/Select.h b/rts/posix/Select.h index 50d49d4ba5..b63e45a1ae 100644 --- a/rts/posix/Select.h +++ b/rts/posix/Select.h @@ -15,3 +15,11 @@ typedef StgWord LowResTime; RTS_PRIVATE LowResTime getDelayTarget (HsInt us); #endif /* POSIX_SELECT_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/posix/Signals.c b/rts/posix/Signals.c index f4a8341c6a..d5129f0996 100644 --- a/rts/posix/Signals.c +++ b/rts/posix/Signals.c @@ -6,7 +6,7 @@ * * ---------------------------------------------------------------------------*/ -#include "PosixSource.h" +#include "PosixSource.h" #include "Rts.h" #include "Schedule.h" @@ -49,7 +49,7 @@ /* This curious flag is provided for the benefit of the Haskell binding * to POSIX.1 to control whether or not to include SA_NOCLDSTOP when - * installing a SIGCHLD handler. + * installing a SIGCHLD handler. */ HsInt nocldstop = 0; @@ -108,16 +108,19 @@ more_handlers(int sig) StgInt i; if (sig < nHandlers) - return; + return; if (signal_handlers == NULL) - signal_handlers = (StgInt *)stgMallocBytes((sig + 1) * sizeof(StgInt), "more_handlers"); + signal_handlers = (StgInt *)stgMallocBytes((sig + 1) * sizeof(StgInt), + "more_handlers"); else - signal_handlers = (StgInt *)stgReallocBytes(signal_handlers, (sig + 1) * sizeof(StgInt), "more_handlers"); + signal_handlers = (StgInt *)stgReallocBytes(signal_handlers, + (sig + 1) * sizeof(StgInt), + "more_handlers"); for(i = nHandlers; i <= sig; i++) - // Fill in the new slots with default actions - signal_handlers[i] = STG_SIG_DFL; + // Fill in the new slots with default actions + signal_handlers[i] = STG_SIG_DFL; nHandlers = sig + 1; } @@ -153,11 +156,11 @@ ioManagerWakeup (void) // Wake up the IO Manager thread by sending a byte down its pipe if (io_manager_wakeup_fd >= 0) { #if defined(HAVE_EVENTFD) - StgWord64 n = (StgWord64)IO_MANAGER_WAKEUP; - r = write(io_manager_wakeup_fd, (char *) &n, 8); + StgWord64 n = (StgWord64)IO_MANAGER_WAKEUP; + r = write(io_manager_wakeup_fd, (char *) &n, 8); #else - StgWord8 byte = (StgWord8)IO_MANAGER_WAKEUP; - r = write(io_manager_wakeup_fd, &byte, 1); + StgWord8 byte = (StgWord8)IO_MANAGER_WAKEUP; + r = write(io_manager_wakeup_fd, &byte, 1); #endif if (r == -1) { sysErrorBelch("ioManagerWakeup: write"); } } @@ -170,8 +173,8 @@ ioManagerDie (void) int r; // Ask the IO Manager thread to exit if (io_manager_control_fd >= 0) { - StgWord8 byte = (StgWord8)IO_MANAGER_DIE; - r = write(io_manager_control_fd, &byte, 1); + StgWord8 byte = (StgWord8)IO_MANAGER_DIE; + r = write(io_manager_control_fd, &byte, 1); if (r == -1) { sysErrorBelch("ioManagerDie: write"); } io_manager_control_fd = -1; io_manager_wakeup_fd = -1; @@ -190,9 +193,9 @@ ioManagerStart (void) // Make sure the IO manager thread is running Capability *cap; if (io_manager_control_fd < 0 || io_manager_wakeup_fd < 0) { - cap = rts_lock(); + cap = rts_lock(); ioManagerStartCap(&cap); - rts_unlock(cap); + rts_unlock(cap); } } #endif @@ -227,14 +230,14 @@ generic_handler(int sig USED_IF_THREADS, buf[0] = sig; - if (info == NULL) { - // info may be NULL on Solaris (see #3790) - memset(buf+1, 0, sizeof(siginfo_t)); - } else { - memcpy(buf+1, info, sizeof(siginfo_t)); - } + if (info == NULL) { + // info may be NULL on Solaris (see #3790) + memset(buf+1, 0, sizeof(siginfo_t)); + } else { + memcpy(buf+1, info, sizeof(siginfo_t)); + } - r = write(io_manager_control_fd, buf, sizeof(siginfo_t)+1); + r = write(io_manager_control_fd, buf, sizeof(siginfo_t)+1); if (r == -1 && errno == EAGAIN) { errorBelch("lost signal due to full pipe: %d\n", sig); @@ -255,7 +258,7 @@ generic_handler(int sig USED_IF_THREADS, We need some kind of locking, but with low overhead (i.e. no blocking signals every time around the scheduler). - + Signal Handlers are atomic (i.e. they can't be interrupted), and we can make use of this. We just need to make sure the critical section of the scheduler can't be interrupted - the @@ -264,14 +267,14 @@ generic_handler(int sig USED_IF_THREADS, handlers to run, i.e. the set of pending handlers is non-empty. */ - + /* We use a stack to store the pending signals. We can't dynamically grow this since we can't allocate any memory from within a signal handler. Hence unfortunately we have to bomb out if the buffer overflows. It might be acceptable to carry on in certain - circumstances, depending on the signal. + circumstances, depending on the signal. */ memcpy(next_pending_handler, info, sizeof(siginfo_t)); @@ -280,10 +283,10 @@ generic_handler(int sig USED_IF_THREADS, // stack full? if (next_pending_handler == &pending_handler_buf[N_PENDING_HANDLERS]) { - errorBelch("too many pending signals"); - stg_exit(EXIT_FAILURE); + errorBelch("too many pending signals"); + stg_exit(EXIT_FAILURE); } - + interruptCapability(&MainCapability); #endif /* THREADED_RTS */ @@ -316,7 +319,7 @@ void awaitUserSignals(void) { while (!signals_pending() && sched_state == SCHED_RUNNING) { - pause(); + pause(); } } #endif @@ -340,34 +343,36 @@ stg_sig_install(int sig, int spi, void *mask) // Block the signal until we figure out what to do // Count on this to fail if the signal number is invalid - if (sig < 0 || sigemptyset(&signals) || - sigaddset(&signals, sig) || sigprocmask(SIG_BLOCK, &signals, &osignals)) { + if (sig < 0 || + sigemptyset(&signals) || + sigaddset(&signals, sig) || + sigprocmask(SIG_BLOCK, &signals, &osignals)) { RELEASE_LOCK(&sig_mutex); return STG_SIG_ERR; } - + more_handlers(sig); previous_spi = signal_handlers[sig]; action.sa_flags = 0; - + switch(spi) { case STG_SIG_IGN: action.sa_handler = SIG_IGN; - break; + break; case STG_SIG_DFL: action.sa_handler = SIG_DFL; - break; + break; case STG_SIG_RST: action.sa_flags |= SA_RESETHAND; /* fall through */ case STG_SIG_HAN: - action.sa_sigaction = generic_handler; + action.sa_sigaction = generic_handler; action.sa_flags |= SA_SIGINFO; - break; + break; default: barf("stg_sig_install: bad spi"); @@ -376,7 +381,7 @@ stg_sig_install(int sig, int spi, void *mask) if (mask != NULL) action.sa_mask = *(sigset_t *)mask; else - sigemptyset(&action.sa_mask); + sigemptyset(&action.sa_mask); action.sa_flags |= sig == SIGCHLD && nocldstop ? SA_NOCLDSTOP : 0; @@ -392,14 +397,14 @@ stg_sig_install(int sig, int spi, void *mask) switch(spi) { case STG_SIG_RST: case STG_SIG_HAN: - sigaddset(&userSignals, sig); + sigaddset(&userSignals, sig); if (previous_spi != STG_SIG_HAN && previous_spi != STG_SIG_RST) { n_haskell_handlers++; } - break; + break; default: - sigdelset(&userSignals, sig); + sigdelset(&userSignals, sig); if (previous_spi == STG_SIG_HAN || previous_spi == STG_SIG_RST) { n_haskell_handlers--; } @@ -429,7 +434,7 @@ startSignalHandlers(Capability *cap) int sig; blockUserSignals(); - + while (next_pending_handler != pending_handler_buf) { next_pending_handler--; @@ -439,18 +444,18 @@ startSignalHandlers(Capability *cap) continue; // handler has been changed. } - info = stgMallocBytes(sizeof(siginfo_t), "startSignalHandlers"); + info = stgMallocBytes(sizeof(siginfo_t), "startSignalHandlers"); // freed by runHandler memcpy(info, next_pending_handler, sizeof(siginfo_t)); - scheduleThread (cap, - createIOThread(cap, - RtsFlags.GcFlags.initialStkSize, - rts_apply(cap, - rts_apply(cap, - &base_GHCziConcziSignal_runHandlers_closure, - rts_mkPtr(cap, info)), - rts_mkInt(cap, info->si_signo)))); + scheduleThread(cap, + createIOThread(cap, + RtsFlags.GcFlags.initialStkSize, + rts_apply(cap, + rts_apply(cap, + &base_GHCziConcziSignal_runHandlers_closure, + rts_mkPtr(cap, info)), + rts_mkInt(cap, info->si_signo)))); } unblockUserSignals(); @@ -468,10 +473,10 @@ markSignalHandlers (evac_fn evac STG_UNUSED, void *user STG_UNUSED) } #else /* !RTS_USER_SIGNALS */ -StgInt +StgInt stg_sig_install(StgInt sig STG_UNUSED, - StgInt spi STG_UNUSED, - void* mask STG_UNUSED) + StgInt spi STG_UNUSED, + void* mask STG_UNUSED) { //barf("User signals not supported"); return STG_SIG_DFL; @@ -493,9 +498,9 @@ shutdown_handler(int sig STG_UNUSED) // extreme prejudice. So the first ^C tries to exit the program // cleanly, and the second one just kills it. if (sched_state >= SCHED_INTERRUPTING) { - stg_exit(EXIT_INTERRUPTED); + stg_exit(EXIT_INTERRUPTED); } else { - interruptStgRts(); + interruptStgRts(); } } @@ -604,11 +609,11 @@ initDefaultHandlers(void) sigemptyset(&action.sa_mask); action.sa_flags = 0; if (sigaction(SIGINT, &action, &oact) != 0) { - sysErrorBelch("warning: failed to install SIGINT handler"); + sysErrorBelch("warning: failed to install SIGINT handler"); } #if defined(HAVE_SIGINTERRUPT) - siginterrupt(SIGINT, 1); // isn't this the default? --SDM + siginterrupt(SIGINT, 1); // isn't this the default? --SDM #endif // install the SIGFPE handler @@ -626,7 +631,7 @@ initDefaultHandlers(void) sigemptyset(&action.sa_mask); action.sa_flags = 0; if (sigaction(SIGFPE, &action, &oact) != 0) { - sysErrorBelch("warning: failed to install SIGFPE handler"); + sysErrorBelch("warning: failed to install SIGFPE handler"); } #endif @@ -641,7 +646,7 @@ initDefaultHandlers(void) sigemptyset(&action.sa_mask); action.sa_flags = 0; if (sigaction(SIGPIPE, &action, &oact) != 0) { - sysErrorBelch("warning: failed to install SIGPIPE handler"); + sysErrorBelch("warning: failed to install SIGPIPE handler"); } set_sigtstp_action(rtsTrue); @@ -658,14 +663,22 @@ resetDefaultHandlers(void) // restore SIGINT if (sigaction(SIGINT, &action, NULL) != 0) { - sysErrorBelch("warning: failed to uninstall SIGINT handler"); + sysErrorBelch("warning: failed to uninstall SIGINT handler"); } // restore SIGPIPE if (sigaction(SIGPIPE, &action, NULL) != 0) { - sysErrorBelch("warning: failed to uninstall SIGPIPE handler"); + sysErrorBelch("warning: failed to uninstall SIGPIPE handler"); } set_sigtstp_action(rtsFalse); } #endif /* RTS_USER_SIGNALS */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/posix/Signals.h b/rts/posix/Signals.h index 387d688912..9500fceeb4 100644 --- a/rts/posix/Signals.h +++ b/rts/posix/Signals.h @@ -32,3 +32,10 @@ extern StgInt *signal_handlers; #endif /* POSIX_SIGNALS_H */ +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/posix/TTY.c b/rts/posix/TTY.c index d39ef37b86..009ebd6592 100644 --- a/rts/posix/TTY.c +++ b/rts/posix/TTY.c @@ -27,8 +27,9 @@ static void *saved_termios[3] = {NULL,NULL,NULL}; void* __hscore_get_saved_termios(int fd) { - return (0 <= fd && fd < (int)(sizeof(saved_termios) / sizeof(*saved_termios))) ? - saved_termios[fd] : NULL; + return (0 <= fd && + fd < (int)(sizeof(saved_termios) / sizeof(*saved_termios))) ? + saved_termios[fd] : NULL; } void @@ -47,19 +48,28 @@ resetTerminalSettings (void) // if we changed them. See System.Posix.Internals.tcSetAttr for // more details, including the reason we termporarily disable // SIGTTOU here. - { - int fd; - sigset_t sigset, old_sigset; - sigemptyset(&sigset); - sigaddset(&sigset, SIGTTOU); - sigprocmask(SIG_BLOCK, &sigset, &old_sigset); - for (fd = 0; fd <= 2; fd++) { - struct termios* ts = (struct termios*)__hscore_get_saved_termios(fd); - if (ts != NULL) { - tcsetattr(fd,TCSANOW,ts); - } - } - sigprocmask(SIG_SETMASK, &old_sigset, NULL); + { + int fd; + sigset_t sigset, old_sigset; + sigemptyset(&sigset); + sigaddset(&sigset, SIGTTOU); + sigprocmask(SIG_BLOCK, &sigset, &old_sigset); + for (fd = 0; fd <= 2; fd++) { + struct termios* ts = + (struct termios*)__hscore_get_saved_termios(fd); + if (ts != NULL) { + tcsetattr(fd,TCSANOW,ts); + } + } + sigprocmask(SIG_SETMASK, &old_sigset, NULL); } #endif } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/posix/TTY.h b/rts/posix/TTY.h index 7b8e16bb92..fe3e55b579 100644 --- a/rts/posix/TTY.h +++ b/rts/posix/TTY.h @@ -12,3 +12,11 @@ RTS_PRIVATE void resetTerminalSettings (void); #endif /* POSIX_TTY_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/BlockAlloc.c b/rts/sm/BlockAlloc.c index f06855e63a..55310fdf9f 100644 --- a/rts/sm/BlockAlloc.c +++ b/rts/sm/BlockAlloc.c @@ -894,3 +894,11 @@ reportUnmarkedBlocks (void) } #endif + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/BlockAlloc.h b/rts/sm/BlockAlloc.h index aebb71a913..42b064fed8 100644 --- a/rts/sm/BlockAlloc.h +++ b/rts/sm/BlockAlloc.h @@ -32,3 +32,11 @@ extern W_ hw_alloc_blocks; // high-water allocated blocks #include "EndPrivate.h" #endif /* BLOCK_ALLOC_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c index b07a886eab..e430d97002 100644 --- a/rts/sm/Compact.c +++ b/rts/sm/Compact.c @@ -1024,3 +1024,11 @@ compact(StgClosure *static_objects) gen->n_old_blocks = blocks; } } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/Compact.h b/rts/sm/Compact.h index 1ec915f49a..306138415a 100644 --- a/rts/sm/Compact.h +++ b/rts/sm/Compact.h @@ -51,3 +51,11 @@ void compact (StgClosure *static_objects); #include "EndPrivate.h" #endif /* SM_COMPACT_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c index 4a550cdde5..e90d3e0857 100644 --- a/rts/sm/Evac.c +++ b/rts/sm/Evac.c @@ -1108,3 +1108,11 @@ bale_out: unchain_thunk_selectors(prev_thunk_selector, *q); return; } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/Evac.h b/rts/sm/Evac.h index 62d54eb7b9..26d0c9eddb 100644 --- a/rts/sm/Evac.h +++ b/rts/sm/Evac.h @@ -41,3 +41,11 @@ extern W_ thunk_selector_depth; #endif /* SM_EVAC_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/GC.c b/rts/sm/GC.c index 61432eabde..97463746a2 100644 --- a/rts/sm/GC.c +++ b/rts/sm/GC.c @@ -1041,8 +1041,6 @@ gcWorkerThread (Capability *cap) SET_GCT(gc_threads[cap->no]); gct->id = osThreadId(); - stat_gcWorkerThreadStart(gct); - // Wait until we're told to wake up RELEASE_SPIN_LOCK(&gct->mut_spin); // yieldThread(); @@ -1100,9 +1098,6 @@ gcWorkerThread (Capability *cap) ACQUIRE_SPIN_LOCK(&gct->mut_spin); debugTrace(DEBUG_gc, "GC thread %d on my way...", gct->thread_index); - // record the time spent doing GC in the Task structure - stat_gcWorkerThreadDone(gct); - SET_GCT(saved_gct); } @@ -1775,3 +1770,11 @@ static void gcCAFs(void) debugTrace(DEBUG_gccafs, "%d CAFs live", i); } #endif + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/GC.h b/rts/sm/GC.h index 571aa07110..0f0b94e784 100644 --- a/rts/sm/GC.h +++ b/rts/sm/GC.h @@ -64,3 +64,11 @@ void releaseGCThreads (Capability *cap); #include "EndPrivate.h" #endif /* SM_GC_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/GCAux.c b/rts/sm/GCAux.c index 10df9dd84b..145ff630d2 100644 --- a/rts/sm/GCAux.c +++ b/rts/sm/GCAux.c @@ -146,3 +146,11 @@ markCAFs (evac_fn evac, void *user) evac(user, &c->indirectee); } } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/GCTDecl.h b/rts/sm/GCTDecl.h index 5602cb8771..74b788012c 100644 --- a/rts/sm/GCTDecl.h +++ b/rts/sm/GCTDecl.h @@ -144,3 +144,11 @@ extern __thread gc_thread* gct; #include "EndPrivate.h" #endif // SM_GCTDECL_H + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/GCThread.h b/rts/sm/GCThread.h index 12ef999a9b..8ed8afe055 100644 --- a/rts/sm/GCThread.h +++ b/rts/sm/GCThread.h @@ -77,7 +77,7 @@ ------------------------------------------------------------------------- */ typedef struct gen_workspace_ { - generation * gen; // the gen for this workspace + generation * gen; // the gen for this workspace struct gc_thread_ * my_gct; // the gc_thread that contains this workspace // where objects to be scavenged go @@ -184,7 +184,6 @@ typedef struct gc_thread_ { Time gc_start_cpu; // process CPU time Time gc_start_elapsed; // process elapsed time - Time gc_start_thread_cpu; // thread CPU time W_ gc_start_faults; // ------------------- @@ -211,3 +210,11 @@ extern ThreadLocalKey gctKey; #endif // SM_GCTHREAD_H + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/GCUtils.c b/rts/sm/GCUtils.c index 11345e92c8..078da12d94 100644 --- a/rts/sm/GCUtils.c +++ b/rts/sm/GCUtils.c @@ -343,3 +343,11 @@ printMutableList(bdescr *bd) debugBelch("\n"); } #endif /* DEBUG */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/GCUtils.h b/rts/sm/GCUtils.h index 1d217adbdd..de5aefca6a 100644 --- a/rts/sm/GCUtils.h +++ b/rts/sm/GCUtils.h @@ -66,3 +66,11 @@ recordMutableGen_GC (StgClosure *p, nat gen_no) #include "EndPrivate.h" #endif /* SM_GCUTILS_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/MBlock.c b/rts/sm/MBlock.c index 6bc4049959..20b301552c 100644 --- a/rts/sm/MBlock.c +++ b/rts/sm/MBlock.c @@ -286,3 +286,11 @@ initMBlocks(void) memset(mblock_cache,0xff,sizeof(mblock_cache)); #endif } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/MarkStack.h b/rts/sm/MarkStack.h index f978a32563..081a189bc6 100644 --- a/rts/sm/MarkStack.h +++ b/rts/sm/MarkStack.h @@ -69,3 +69,11 @@ mark_stack_empty(void) #include "EndPrivate.h" #endif /* SM_MARKSTACK_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/MarkWeak.c b/rts/sm/MarkWeak.c index 0324f3b4b9..b8ec4532b4 100644 --- a/rts/sm/MarkWeak.c +++ b/rts/sm/MarkWeak.c @@ -416,3 +416,11 @@ markWeakPtrList ( void ) } } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/MarkWeak.h b/rts/sm/MarkWeak.h index bd0231d74c..ee94eebba6 100644 --- a/rts/sm/MarkWeak.h +++ b/rts/sm/MarkWeak.h @@ -28,3 +28,11 @@ void markWeakPtrList ( void ); #include "EndPrivate.h" #endif /* SM_MARKWEAK_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/OSMem.h b/rts/sm/OSMem.h index db704fc78b..e5c97eccea 100644 --- a/rts/sm/OSMem.h +++ b/rts/sm/OSMem.h @@ -23,3 +23,11 @@ void setExecutable (void *p, W_ len, rtsBool exec); #include "EndPrivate.h" #endif /* SM_OSMEM_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c index c653331164..07230afd4a 100644 --- a/rts/sm/Sanity.c +++ b/rts/sm/Sanity.c @@ -931,3 +931,11 @@ memInventory (rtsBool show) #endif /* DEBUG */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/Sanity.h b/rts/sm/Sanity.h index f302bc22b1..9a2d2697da 100644 --- a/rts/sm/Sanity.h +++ b/rts/sm/Sanity.h @@ -44,3 +44,11 @@ void checkBQ (StgTSO *bqe, StgClosure *closure); #endif /* DEBUG */ #endif /* SANITY_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c index b9f8f1259b..abebb3ca96 100644 --- a/rts/sm/Scav.c +++ b/rts/sm/Scav.c @@ -2070,3 +2070,11 @@ loop: if (work_to_do) goto loop; } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/Scav.h b/rts/sm/Scav.h index 725d27ccf1..c755f39a8e 100644 --- a/rts/sm/Scav.h +++ b/rts/sm/Scav.h @@ -30,3 +30,11 @@ void scavenge_capability_mut_Lists1 (Capability *cap); #endif /* SM_SCAV_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c index 86bd1c2bb3..5d0cbacec8 100644 --- a/rts/sm/Storage.c +++ b/rts/sm/Storage.c @@ -686,7 +686,15 @@ StgPtr allocate (Capability *cap, W_ n) CCS_ALLOC(cap->r.rCCCS,n); if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) { - W_ req_blocks = (W_)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE; + // The largest number of words such that + // the computation of req_blocks will not overflow. + W_ max_words = (HS_WORD_MAX & ~(BLOCK_SIZE-1)) / sizeof(W_); + W_ req_blocks; + + if (n > max_words) + req_blocks = HS_WORD_MAX; // signal overflow below + else + req_blocks = (W_)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE; // Attempting to allocate an object larger than maxHeapSize // should definitely be disallowed. (bug #1791) @@ -1344,3 +1352,11 @@ _bdescr (StgPtr p) } #endif + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/Storage.h b/rts/sm/Storage.h index e433c2b8fe..c1a92aca35 100644 --- a/rts/sm/Storage.h +++ b/rts/sm/Storage.h @@ -141,3 +141,11 @@ extern StgIndStatic * revertible_caf_list; #include "EndPrivate.h" #endif /* SM_STORAGE_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/Sweep.c b/rts/sm/Sweep.c index c927f300d7..842ede243e 100644 --- a/rts/sm/Sweep.c +++ b/rts/sm/Sweep.c @@ -84,3 +84,11 @@ sweep(generation *gen) ASSERT(countBlocks(gen->old_blocks) == gen->n_old_blocks); } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/sm/Sweep.h b/rts/sm/Sweep.h index b590faa803..29b29f3638 100644 --- a/rts/sm/Sweep.h +++ b/rts/sm/Sweep.h @@ -17,3 +17,11 @@ RTS_PRIVATE void sweep(generation *gen); #endif /* SM_SWEEP_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/win32/AsyncIO.c b/rts/win32/AsyncIO.c index 9f45317d38..412f31b43e 100644 --- a/rts/win32/AsyncIO.c +++ b/rts/win32/AsyncIO.c @@ -19,7 +19,7 @@ /* * Overview: * - * Haskell code issue asynchronous I/O requests via the + * Haskell code issue asynchronous I/O requests via the * async{Read,Write,DoOp}# primops. These cause addIORequest() * to be invoked, which forwards the request to the underlying * asynchronous I/O subsystem. Each request is tagged with a unique @@ -30,7 +30,7 @@ * it. Upon completion of an I/O request, the async I/O handling * code makes a back-call to signal its completion; the local * onIOComplete() routine. It adds the IO request ID (along with - * its result data) to a queue of completed requests before returning. + * its result data) to a queue of completed requests before returning. * * The queue of completed IO request is read by the thread operating * the RTS scheduler. It de-queues the CH threads corresponding @@ -57,62 +57,66 @@ static int issued_reqs; static void onIOComplete(unsigned int reqID, - int fd STG_UNUSED, - int len, - void* buf STG_UNUSED, - int errCode) + int fd STG_UNUSED, + int len, + void* buf STG_UNUSED, + int errCode) { DWORD dwRes; /* Deposit result of request in queue/table..when there's room. */ dwRes = WaitForSingleObject(completed_table_sema, INFINITE); switch (dwRes) { case WAIT_OBJECT_0: - break; + break; default: - /* Not likely */ - fprintf(stderr, "onIOComplete: failed to grab table semaphore, dropping request 0x%x\n", reqID); - fflush(stderr); - return; + /* Not likely */ + fprintf(stderr, + "onIOComplete: failed to grab table semaphore, " + "dropping request 0x%x\n", reqID); + fflush(stderr); + return; } EnterCriticalSection(&queue_lock); if (completed_hw == MAX_REQUESTS) { - /* Shouldn't happen */ - fprintf(stderr, "onIOComplete: ERROR -- Request table overflow (%d); dropping.\n", reqID); - fflush(stderr); + /* Shouldn't happen */ + fprintf(stderr, "onIOComplete: ERROR -- Request table overflow (%d); " + "dropping.\n", reqID); + fflush(stderr); } else { #if 0 - fprintf(stderr, "onCompl: %d %d %d %d %d\n", - reqID, len, errCode, issued_reqs, completed_hw); - fflush(stderr); + fprintf(stderr, "onCompl: %d %d %d %d %d\n", + reqID, len, errCode, issued_reqs, completed_hw); + fflush(stderr); #endif - completedTable[completed_hw].reqID = reqID; - completedTable[completed_hw].len = len; - completedTable[completed_hw].errCode = errCode; - completed_hw++; - issued_reqs--; - if (completed_hw == 1) { - /* The event is used to wake up the scheduler thread should it - * be blocked waiting for requests to complete. The event resets once - * that thread has cleared out the request queue/table. - */ - SetEvent(completed_req_event); - } + completedTable[completed_hw].reqID = reqID; + completedTable[completed_hw].len = len; + completedTable[completed_hw].errCode = errCode; + completed_hw++; + issued_reqs--; + if (completed_hw == 1) { + /* The event is used to wake up the scheduler thread should it + * be blocked waiting for requests to complete. The event resets + * once that thread has cleared out the request queue/table. + */ + SetEvent(completed_req_event); + } } LeaveCriticalSection(&queue_lock); } unsigned int addIORequest(int fd, - int forWriting, - int isSock, - int len, - char* buf) + int forWriting, + int isSock, + int len, + char* buf) { EnterCriticalSection(&queue_lock); issued_reqs++; LeaveCriticalSection(&queue_lock); #if 0 - fprintf(stderr, "addIOReq: %d %d %d\n", fd, forWriting, len); fflush(stderr); + fprintf(stderr, "addIOReq: %d %d %d\n", fd, forWriting, len); + fflush(stderr); #endif return AddIORequest(fd,forWriting,isSock,len,buf,onIOComplete); } @@ -146,30 +150,34 @@ int startupAsyncIO() { if (!StartIOManager()) { - return 0; + return 0; } InitializeCriticalSection(&queue_lock); /* Create a pair of events: * - * - completed_req_event -- signals the deposit of request result; manual reset. - * - abandon_req_wait -- external OS thread tells current RTS/Scheduler - * thread to abandon wait for IO request completion. - * Auto reset. + * - completed_req_event -- signals the deposit of request result; + * manual reset. + * - abandon_req_wait -- external OS thread tells current + * RTS/Scheduler thread to abandon wait + * for IO request completion. + * Auto reset. */ completed_req_event = CreateEvent (NULL, TRUE, FALSE, NULL); abandon_req_wait = CreateEvent (NULL, FALSE, FALSE, NULL); wait_handles[0] = completed_req_event; wait_handles[1] = abandon_req_wait; completed_hw = 0; - if ( !(completed_table_sema = CreateSemaphore (NULL, MAX_REQUESTS, MAX_REQUESTS, NULL)) ) { - DWORD rc = GetLastError(); - fprintf(stderr, "startupAsyncIO: CreateSemaphore failed 0x%x\n", (int)rc); - fflush(stderr); + if ( !(completed_table_sema = CreateSemaphore(NULL, MAX_REQUESTS, + MAX_REQUESTS, NULL)) ) { + DWORD rc = GetLastError(); + fprintf(stderr, "startupAsyncIO: CreateSemaphore failed 0x%x\n", + (int)rc); + fflush(stderr); } return ( completed_req_event != INVALID_HANDLE_VALUE && - abandon_req_wait != INVALID_HANDLE_VALUE && - completed_table_sema != NULL ); + abandon_req_wait != INVALID_HANDLE_VALUE && + completed_table_sema != NULL ); } void @@ -178,15 +186,15 @@ shutdownAsyncIO(rtsBool wait_threads) ShutdownIOManager(wait_threads); if (completed_req_event != INVALID_HANDLE_VALUE) { CloseHandle(completed_req_event); - completed_req_event = INVALID_HANDLE_VALUE; + completed_req_event = INVALID_HANDLE_VALUE; } if (abandon_req_wait != INVALID_HANDLE_VALUE) { CloseHandle(abandon_req_wait); - abandon_req_wait = INVALID_HANDLE_VALUE; + abandon_req_wait = INVALID_HANDLE_VALUE; } if (completed_table_sema != NULL) { CloseHandle(completed_table_sema); - completed_table_sema = NULL; + completed_table_sema = NULL; } DeleteCriticalSection(&queue_lock); } @@ -196,15 +204,15 @@ shutdownAsyncIO(rtsBool wait_threads) * * Check for the completion of external IO work requests. Worker * threads signal completion of IO requests by depositing them - * in a table (completedTable). awaitRequests() matches up - * requests in that table with threads on the blocked_queue, + * in a table (completedTable). awaitRequests() matches up + * requests in that table with threads on the blocked_queue, * making the threads whose IO requests have completed runnable * again. - * + * * awaitRequests() is called by the scheduler periodically _or_ if * it is out of work, and need to wait for the completion of IO - * requests to make further progress. In the latter scenario, - * awaitRequests() will simply block waiting for worker threads + * requests to make further progress. In the latter scenario, + * awaitRequests() will simply block waiting for worker threads * to complete if the 'completedTable' is empty. */ int @@ -215,120 +223,128 @@ awaitRequests(rtsBool wait) start: #if 0 - fprintf(stderr, "awaitRequests(): %d %d %d\n", issued_reqs, completed_hw, wait); + fprintf(stderr, "awaitRequests(): %d %d %d\n", + issued_reqs, completed_hw, wait); fflush(stderr); #endif EnterCriticalSection(&queue_lock); - /* Nothing immediately available & we won't wait */ + // Nothing immediately available & we won't wait if ((!wait && completed_hw == 0) #if 0 - // If we just return when wait==rtsFalse, we'll go into a busy - // wait loop, so I disabled this condition --SDM 18/12/2003 - (issued_reqs == 0 && completed_hw == 0) + // If we just return when wait==rtsFalse, we'll go into a busy + // wait loop, so I disabled this condition --SDM 18/12/2003 + (issued_reqs == 0 && completed_hw == 0) #endif - ) { - LeaveCriticalSection(&queue_lock); - return 0; + ) { + LeaveCriticalSection(&queue_lock); + return 0; } if (completed_hw == 0) { - /* empty table, drop lock and wait */ - LeaveCriticalSection(&queue_lock); - if ( wait && sched_state == SCHED_RUNNING ) { - DWORD dwRes = WaitForMultipleObjects(2, wait_handles, FALSE, INFINITE); - switch (dwRes) { - case WAIT_OBJECT_0: - /* a request was completed */ - break; - case WAIT_OBJECT_0 + 1: - case WAIT_TIMEOUT: - /* timeout (unlikely) or told to abandon waiting */ - return 0; - case WAIT_FAILED: { - DWORD dw = GetLastError(); - fprintf(stderr, "awaitRequests: wait failed -- error code: %lu\n", dw); fflush(stderr); - return 0; - } - default: - fprintf(stderr, "awaitRequests: unexpected wait return code %lu\n", dwRes); fflush(stderr); - return 0; - } - } else { - return 0; - } - goto start; + // empty table, drop lock and wait + LeaveCriticalSection(&queue_lock); + if ( wait && sched_state == SCHED_RUNNING ) { + DWORD dwRes = WaitForMultipleObjects(2, wait_handles, + FALSE, INFINITE); + switch (dwRes) { + case WAIT_OBJECT_0: + // a request was completed + break; + case WAIT_OBJECT_0 + 1: + case WAIT_TIMEOUT: + // timeout (unlikely) or told to abandon waiting + return 0; + case WAIT_FAILED: { + DWORD dw = GetLastError(); + fprintf(stderr, "awaitRequests: wait failed -- " + "error code: %lu\n", dw); fflush(stderr); + return 0; + } + default: + fprintf(stderr, "awaitRequests: unexpected wait return " + "code %lu\n", dwRes); fflush(stderr); + return 0; + } + } else { + return 0; + } + goto start; } else { - int i; - StgTSO *tso, *prev; - - for (i=0; i < completed_hw; i++) { - /* For each of the completed requests, match up their Ids - * with those of the threads on the blocked_queue. If the - * thread that made the IO request has been subsequently - * killed (and removed from blocked_queue), no match will - * be found for that request Id. - * - * i.e., killing a Haskell thread doesn't attempt to cancel - * the IO request it is blocked on. - * - */ - unsigned int rID = completedTable[i].reqID; - - prev = NULL; - for(tso = blocked_queue_hd ; tso != END_TSO_QUEUE; tso = tso->_link) { - + int i; + StgTSO *tso, *prev; + + for (i=0; i < completed_hw; i++) { + /* For each of the completed requests, match up their Ids + * with those of the threads on the blocked_queue. If the + * thread that made the IO request has been subsequently + * killed (and removed from blocked_queue), no match will + * be found for that request Id. + * + * i.e., killing a Haskell thread doesn't attempt to cancel + * the IO request it is blocked on. + * + */ + unsigned int rID = completedTable[i].reqID; + + prev = NULL; + for(tso = blocked_queue_hd; tso != END_TSO_QUEUE; + tso = tso->_link) { + switch(tso->why_blocked) { - case BlockedOnRead: - case BlockedOnWrite: - case BlockedOnDoProc: - if (tso->block_info.async_result->reqID == rID) { - /* Found the thread blocked waiting on request; stodgily fill - * in its result block. - */ - tso->block_info.async_result->len = completedTable[i].len; - tso->block_info.async_result->errCode = completedTable[i].errCode; - - /* Drop the matched TSO from blocked_queue */ - if (prev) { - setTSOLink(&MainCapability, prev, tso->_link); - } else { - blocked_queue_hd = tso->_link; - } - if (blocked_queue_tl == tso) { - blocked_queue_tl = prev ? prev : END_TSO_QUEUE; - } - - /* Terminates the run queue + this inner for-loop. */ - tso->_link = END_TSO_QUEUE; - tso->why_blocked = NotBlocked; + case BlockedOnRead: + case BlockedOnWrite: + case BlockedOnDoProc: + if (tso->block_info.async_result->reqID == rID) { + // Found the thread blocked waiting on request; + // stodgily fill + // in its result block. + tso->block_info.async_result->len = + completedTable[i].len; + tso->block_info.async_result->errCode = + completedTable[i].errCode; + + // Drop the matched TSO from blocked_queue + if (prev) { + setTSOLink(&MainCapability, prev, tso->_link); + } else { + blocked_queue_hd = tso->_link; + } + if (blocked_queue_tl == tso) { + blocked_queue_tl = prev ? prev : END_TSO_QUEUE; + } + + // Terminates the run queue + this inner for-loop. + tso->_link = END_TSO_QUEUE; + tso->why_blocked = NotBlocked; // save the StgAsyncIOResult in the // stg_block_async_info stack frame, because // the block_info field will be overwritten by // pushOnRunQueue(). tso->stackobj->sp[1] = (W_)tso->block_info.async_result; - pushOnRunQueue(&MainCapability, tso); - break; - } - break; - default: - if (tso->why_blocked != NotBlocked) { - barf("awaitRequests: odd thread state"); - } - break; - } + pushOnRunQueue(&MainCapability, tso); + break; + } + break; + default: + if (tso->why_blocked != NotBlocked) { + barf("awaitRequests: odd thread state"); + } + break; + } prev = tso; - } - /* Signal that there's completed table slots available */ - if ( !ReleaseSemaphore(completed_table_sema, 1, NULL) ) { - DWORD dw = GetLastError(); - fprintf(stderr, "awaitRequests: failed to signal semaphore (error code=0x%x)\n", (int)dw); - fflush(stderr); - } - } - completed_hw = 0; - ResetEvent(completed_req_event); - LeaveCriticalSection(&queue_lock); - return 1; + } + /* Signal that there's completed table slots available */ + if ( !ReleaseSemaphore(completed_table_sema, 1, NULL) ) { + DWORD dw = GetLastError(); + fprintf(stderr, "awaitRequests: failed to signal semaphore " + "(error code=0x%x)\n", (int)dw); + fflush(stderr); + } + } + completed_hw = 0; + ResetEvent(completed_req_event); + LeaveCriticalSection(&queue_lock); + return 1; } #endif /* !THREADED_RTS */ } @@ -365,3 +381,11 @@ resetAbandonRequestWait( void ) } #endif /* !defined(THREADED_RTS) */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/win32/AsyncIO.h b/rts/win32/AsyncIO.h index 8d99c0acde..ee3178d078 100644 --- a/rts/win32/AsyncIO.h +++ b/rts/win32/AsyncIO.h @@ -10,10 +10,10 @@ extern unsigned int addIORequest(int fd, - int forWriting, - int isSock, - int len, - char* buf); + int forWriting, + int isSock, + int len, + char* buf); extern unsigned int addDelayRequest(int usecs); extern unsigned int addDoProcRequest(void* proc, void* param); extern int startupAsyncIO(void); @@ -25,3 +25,11 @@ extern void abandonRequestWait(void); extern void resetAbandonRequestWait(void); #endif /* WIN32_ASYNCHIO_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/win32/AwaitEvent.c b/rts/win32/AwaitEvent.c index af9c658e02..eb254d981d 100644 --- a/rts/win32/AwaitEvent.c +++ b/rts/win32/AwaitEvent.c @@ -8,7 +8,7 @@ * If the Scheduler is otherwise out of work, it'll block * herein waiting for external events to occur. * - * This file mirrors the select()-based functionality + * This file mirrors the select()-based functionality * for POSIX / Unix platforms in rts/Select.c, but for * Win32. * @@ -50,8 +50,16 @@ awaitEvent(rtsBool wait) // - the run-queue is now non- empty } while (wait - && sched_state == SCHED_RUNNING - && emptyRunQueue(&MainCapability) + && sched_state == SCHED_RUNNING + && emptyRunQueue(&MainCapability) ); } #endif + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/win32/ConsoleHandler.c b/rts/win32/ConsoleHandler.c index 19057a3d8d..c72a11230f 100644 --- a/rts/win32/ConsoleHandler.c +++ b/rts/win32/ConsoleHandler.c @@ -40,11 +40,11 @@ initUserSignals(void) #if !defined (THREADED_RTS) stg_pending_events = 0; if (hConsoleEvent == INVALID_HANDLE_VALUE) { - hConsoleEvent = - CreateEvent ( NULL, /* default security attributes */ - TRUE, /* manual-reset event */ - FALSE, /* initially non-signalled */ - NULL); /* no name */ + hConsoleEvent = + CreateEvent ( NULL, /* default security attributes */ + TRUE, /* manual-reset event */ + FALSE, /* initially non-signalled */ + NULL); /* no name */ } #endif return; @@ -75,31 +75,31 @@ finiUserSignals(void) * To repeat Signals.c remark -- user code may choose to override the * default handler. Which is fine, assuming they put back the default * handler when/if they de-install the custom handler. - * + * */ static BOOL WINAPI shutdown_handler(DWORD dwCtrlType) { switch (dwCtrlType) { - + case CTRL_CLOSE_EVENT: - /* see generic_handler() comment re: this event */ - return FALSE; + /* see generic_handler() comment re: this event */ + return FALSE; case CTRL_C_EVENT: case CTRL_BREAK_EVENT: - // If we're already trying to interrupt the RTS, terminate with - // extreme prejudice. So the first ^C tries to exit the program - // cleanly, and the second one just kills it. - if (sched_state >= SCHED_INTERRUPTING) { - stg_exit(EXIT_INTERRUPTED); - } else { - interruptStgRts(); - } - return TRUE; - - /* shutdown + logoff events are not handled here. */ + // If we're already trying to interrupt the RTS, terminate with + // extreme prejudice. So the first ^C tries to exit the program + // cleanly, and the second one just kills it. + if (sched_state >= SCHED_INTERRUPTING) { + stg_exit(EXIT_INTERRUPTED); + } else { + interruptStgRts(); + } + return TRUE; + + /* shutdown + logoff events are not handled here. */ default: - return FALSE; + return FALSE; } } @@ -113,14 +113,14 @@ static BOOL WINAPI shutdown_handler(DWORD dwCtrlType) void initDefaultHandlers(void) { if ( !SetConsoleCtrlHandler(shutdown_handler, TRUE) ) { - errorBelch("warning: failed to install default console handler"); + errorBelch("warning: failed to install default console handler"); } } void resetDefaultHandlers(void) { if ( !SetConsoleCtrlHandler(shutdown_handler, FALSE) ) { - errorBelch("warning: failed to uninstall default console handler"); + errorBelch("warning: failed to uninstall default console handler"); } } @@ -130,7 +130,7 @@ void resetDefaultHandlers(void) * Temporarily block the delivery of further console events. Needed to * avoid race conditions when GCing the stack of outstanding handlers or * when emptying the stack by running the handlers. - * + * */ void blockUserSignals(void) @@ -174,24 +174,24 @@ void startSignalHandlers(Capability *cap) StgStablePtr handler; if (console_handler < 0) { - return; + return; } blockUserSignals(); ACQUIRE_LOCK(&sched_mutex); - + handler = deRefStablePtr((StgStablePtr)console_handler); while (stg_pending_events > 0) { - stg_pending_events--; - scheduleThread(cap, - createIOThread(cap, - RtsFlags.GcFlags.initialStkSize, - rts_apply(cap, - (StgClosure *)handler, - rts_mkInt(cap, - stg_pending_buf[stg_pending_events])))); + stg_pending_events--; + scheduleThread(cap, + createIOThread(cap, + RtsFlags.GcFlags.initialStkSize, + rts_apply(cap, + (StgClosure *)handler, + rts_mkInt(cap, + stg_pending_buf[stg_pending_events])))); } - + RELEASE_LOCK(&sched_mutex); unblockUserSignals(); } @@ -210,39 +210,39 @@ void markSignalHandlers (evac_fn evac STG_UNUSED, void *user STG_UNUSED) } -/* +/* * Function: generic_handler() * - * Local function which handles incoming console event (done in a sep OS thread), - * recording the event in stg_pending_events. + * Local function which handles incoming console event (done in a separate + * OS thread), recording the event in stg_pending_events. */ static BOOL WINAPI generic_handler(DWORD dwCtrlType) { /* Ultra-simple -- up the counter + signal a switch. */ switch(dwCtrlType) { case CTRL_CLOSE_EVENT: - /* Don't support the delivery of this event; if we - * indicate that we've handled it here and the Haskell handler - * doesn't take proper action (e.g., terminate the OS process), - * the user of the app will be unable to kill/close it. Not - * good, so disable the delivery for now. - */ - return FALSE; + /* Don't support the delivery of this event; if we + * indicate that we've handled it here and the Haskell handler + * doesn't take proper action (e.g., terminate the OS process), + * the user of the app will be unable to kill/close it. Not + * good, so disable the delivery for now. + */ + return FALSE; default: - if (!deliver_event) return TRUE; + if (!deliver_event) return TRUE; #if defined(THREADED_RTS) sendIOManagerEvent((StgWord8) ((dwCtrlType<<1) | 1)); #else - if ( stg_pending_events < N_PENDING_EVENTS ) { - stg_pending_buf[stg_pending_events] = dwCtrlType; - stg_pending_events++; - } + if ( stg_pending_events < N_PENDING_EVENTS ) { + stg_pending_buf[stg_pending_events] = dwCtrlType; + stg_pending_events++; + } // we need to wake up awaitEvent() abandonRequestWait(); #endif - return TRUE; + return TRUE; } } @@ -259,42 +259,43 @@ rts_InstallConsoleEvent(int action, StgStablePtr *handler) switch (action) { case STG_SIG_IGN: - console_handler = STG_SIG_IGN; - if ( !SetConsoleCtrlHandler(NULL, TRUE) ) { - errorBelch("warning: unable to ignore console events"); - } - break; + console_handler = STG_SIG_IGN; + if ( !SetConsoleCtrlHandler(NULL, TRUE) ) { + errorBelch("warning: unable to ignore console events"); + } + break; case STG_SIG_DFL: - console_handler = STG_SIG_IGN; - if ( !SetConsoleCtrlHandler(NULL, FALSE) ) { - errorBelch("warning: unable to restore default console event handling"); - } - break; + console_handler = STG_SIG_IGN; + if ( !SetConsoleCtrlHandler(NULL, FALSE) ) { + errorBelch("warning: unable to restore default console event " + "handling"); + } + break; case STG_SIG_HAN: #ifdef THREADED_RTS // handler is stored in an MVar in the threaded RTS - console_handler = STG_SIG_HAN; + console_handler = STG_SIG_HAN; #else - console_handler = (StgInt)*handler; + console_handler = (StgInt)*handler; #endif - if (previous_hdlr < 0 || previous_hdlr == STG_SIG_HAN) { - /* Only install generic_handler() once */ - if ( !SetConsoleCtrlHandler(generic_handler, TRUE) ) { - errorBelch("warning: unable to install console event handler"); - } - } - break; + if (previous_hdlr < 0 || previous_hdlr == STG_SIG_HAN) { + /* Only install generic_handler() once */ + if ( !SetConsoleCtrlHandler(generic_handler, TRUE) ) { + errorBelch("warning: unable to install console event handler"); + } + } + break; } - - if (previous_hdlr == STG_SIG_DFL || - previous_hdlr == STG_SIG_IGN || + + if (previous_hdlr == STG_SIG_DFL || + previous_hdlr == STG_SIG_IGN || previous_hdlr == STG_SIG_HAN) { - return previous_hdlr; + return previous_hdlr; } else { - if (handler != NULL) { + if (handler != NULL) { *handler = (StgStablePtr)previous_hdlr; } - return STG_SIG_HAN; + return STG_SIG_HAN; } } @@ -302,18 +303,18 @@ rts_InstallConsoleEvent(int action, StgStablePtr *handler) * Function: rts_HandledConsoleEvent() * * Signal that a Haskell console event handler has completed its run. - * The explicit notification that a Haskell handler has completed is + * The explicit notification that a Haskell handler has completed is * required to better handle the delivery of Ctrl-C/Break events whilst - * an async worker thread is handling a read request on stdin. The + * an async worker thread is handling a read request on stdin. The * Win32 console implementation will abort such a read request when Ctrl-C - * is delivered. That leaves the worker thread in a bind: should it - * abandon the request (the Haskell thread reading from stdin has been - * thrown an exception to signal the delivery of Ctrl-C & hence have + * is delivered. That leaves the worker thread in a bind: should it + * abandon the request (the Haskell thread reading from stdin has been + * thrown an exception to signal the delivery of Ctrl-C & hence have * aborted the I/O request) or simply ignore the aborted read and retry? * (the Haskell thread reading from stdin isn't concerned with the * delivery and handling of Ctrl-C.) With both scenarios being * possible, the worker thread needs to be told -- that is, did the - * console event handler cause the IO request to be abandoned? + * console event handler cause the IO request to be abandoned? * */ void @@ -321,11 +322,11 @@ rts_ConsoleHandlerDone (int ev USED_IF_NOT_THREADS) { #if !defined(THREADED_RTS) if ( (DWORD)ev == CTRL_BREAK_EVENT || - (DWORD)ev == CTRL_C_EVENT ) { - /* only these two cause stdin system calls to abort.. */ - SetEvent(hConsoleEvent); /* event is manual-reset */ - Sleep(0); /* yield */ - ResetEvent(hConsoleEvent); /* turn it back off again */ + (DWORD)ev == CTRL_C_EVENT ) { + /* only these two cause stdin system calls to abort.. */ + SetEvent(hConsoleEvent); /* event is manual-reset */ + Sleep(0); /* yield */ + ResetEvent(hConsoleEvent); /* turn it back off again */ // SDM: yeuch, this can't possibly work reliably. // I'm not having it in THREADED_RTS. } @@ -348,3 +349,11 @@ rts_waitConsoleHandlerCompletion() return (WaitForSingleObject(hConsoleEvent, INFINITE) == WAIT_OBJECT_0); } #endif + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/win32/ConsoleHandler.h b/rts/win32/ConsoleHandler.h index 0d09a67b94..f9bb6568c3 100644 --- a/rts/win32/ConsoleHandler.h +++ b/rts/win32/ConsoleHandler.h @@ -62,3 +62,11 @@ extern int rts_waitConsoleHandlerCompletion(void); #endif /* THREADED_RTS */ #endif /* Win32_CONSOLEHANDLER_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/win32/GetEnv.c b/rts/win32/GetEnv.c index c4720961d3..7bcfe4a12b 100644 --- a/rts/win32/GetEnv.c +++ b/rts/win32/GetEnv.c @@ -18,7 +18,7 @@ * Var1=Value1\0 * Var2=Value2\0 * ... - * VarN=ValueN\0\0 + * VarN=ValueN\0\0 * But because everyone else (ie POSIX) uses a vector of strings, we convert * to that format. Fortunately this is just a matter of making an array of * offsets into the environment block. @@ -60,3 +60,11 @@ void freeProgEnvv(int envc, char *envv[]) { FreeEnvironmentStringsA(envv[envc]); stgFree(envv); } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/win32/GetTime.c b/rts/win32/GetTime.c index bfab43a9cc..0af0306b54 100644 --- a/rts/win32/GetTime.c +++ b/rts/win32/GetTime.c @@ -25,7 +25,7 @@ fileTimeToRtsTime(FILETIME ft) t = NSToTime(t * 100); /* FILETIMES are in units of 100ns */ return t; -} +} void getProcessTimes(Time *user, Time *elapsed) @@ -40,8 +40,8 @@ getProcessCPUTime(void) FILETIME creationTime, exitTime, userTime, kernelTime = {0,0}; if (!GetProcessTimes(GetCurrentProcess(), &creationTime, - &exitTime, &kernelTime, &userTime)) { - return 0; + &exitTime, &kernelTime, &userTime)) { + return 0; } return fileTimeToRtsTime(userTime); @@ -106,8 +106,8 @@ getThreadCPUTime(void) FILETIME creationTime, exitTime, userTime, kernelTime = {0,0}; if (!GetThreadTimes(GetCurrentThread(), &creationTime, - &exitTime, &kernelTime, &userTime)) { - return 0; + &exitTime, &kernelTime, &userTime)) { + return 0; } return fileTimeToRtsTime(userTime); @@ -136,16 +136,16 @@ getUnixEpochTime(StgWord64 *sec, StgWord32 *nsec) ULARGE_INTEGER struct which is a handy union type */ unixtime.LowPart = filetime.dwLowDateTime; unixtime.HighPart = filetime.dwHighDateTime; - + /* We have to do an epoch conversion, since FILETIME uses 1601 while we want unix epoch of 1970. In case you were wondering, there were 11,644,473,600 seconds between 1601 and 1970, then multiply by 10^7 for units of 100 nanoseconds. */ unixtime.QuadPart = unixtime.QuadPart - 116444736000000000ull; - + /* For the seconds part we use integer division by 10^7 */ *sec = unixtime.QuadPart / 10000000ull; - + /* The remainder from integer division by 10^7 gives us the sub-second component in units of 100 nanoseconds. So for nanoseconds we just multiply by 100. @@ -160,3 +160,11 @@ getPageFaults(void) that's stored in the registry. */ return 0; } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/win32/IOManager.c b/rts/win32/IOManager.c index 0091f23b3c..2427687136 100644 --- a/rts/win32/IOManager.c +++ b/rts/win32/IOManager.c @@ -60,130 +60,150 @@ IOWorkerProc(PVOID param) hWaits[0] = (HANDLE)iom->hExitEvent; hWaits[1] = GetWorkQueueHandle(pq); - + while (1) { - /* The error code is communicated back on completion of request; reset. */ - errCode = 0; - - EnterCriticalSection(&iom->manLock); - /* Signal that the worker is idle. - * - * 'workersIdle' is used when determining whether or not to - * increase the worker thread pool when adding a new request. - * (see addIORequest().) - */ - iom->workersIdle++; - LeaveCriticalSection(&iom->manLock); - - /* - * A possible future refinement is to make long-term idle threads - * wake up and decide to shut down should the number of idle threads - * be above some threshold. - * - */ - rc = WaitForMultipleObjects( 2, hWaits, FALSE, INFINITE ); - - if (rc == WAIT_OBJECT_0) { - // we received the exit event - EnterCriticalSection(&iom->manLock); - ioMan->numWorkers--; - LeaveCriticalSection(&iom->manLock); - return 0; - } - - EnterCriticalSection(&iom->manLock); - /* Signal that the thread is 'non-idle' and about to consume - * a work item. - */ - iom->workersIdle--; - iom->queueSize--; - LeaveCriticalSection(&iom->manLock); - - if ( rc == (WAIT_OBJECT_0 + 1) ) { - /* work item available, fetch it. */ - if (FetchWork(pq,(void**)&work)) { - work->abandonOp = 0; - RegisterWorkItem(iom,work); - if ( work->workKind & WORKER_READ ) { - if ( work->workKind & WORKER_FOR_SOCKET ) { - len = recv(work->workData.ioData.fd, - work->workData.ioData.buf, - work->workData.ioData.len, - 0); - if (len == SOCKET_ERROR) { - errCode = WSAGetLastError(); - } - } else { - while (1) { - /* Do the read(), with extra-special handling for Ctrl+C */ - len = read(work->workData.ioData.fd, - work->workData.ioData.buf, - work->workData.ioData.len); - if ( len == 0 && work->workData.ioData.len != 0 ) { - /* Given the following scenario: - * - a console handler has been registered that handles Ctrl+C - * events. - * - we've not tweaked the 'console mode' settings to turn on - * ENABLE_PROCESSED_INPUT. - * - we're blocked waiting on input from standard input. - * - the user hits Ctrl+C. - * - * The OS will invoke the console handler (in a separate OS thread), - * and the above read() (i.e., under the hood, a ReadFile() op) returns - * 0, with the error set to ERROR_OPERATION_ABORTED. We don't - * want to percolate this error condition back to the Haskell user. - * Do this by waiting for the completion of the Haskell console handler. - * If upon completion of the console handler routine, the Haskell thread - * that issued the request is found to have been thrown an exception, - * the worker abandons the request (since that's what the Haskell thread - * has done.) If the Haskell thread hasn't been interrupted, the worker - * retries the read request as if nothing happened. - */ - if ( (GetLastError()) == ERROR_OPERATION_ABORTED ) { - /* For now, only abort when dealing with the standard input handle. - * i.e., for all others, an error is raised. - */ - HANDLE h = (HANDLE)GetStdHandle(STD_INPUT_HANDLE); - if ( _get_osfhandle(work->workData.ioData.fd) == (intptr_t)h ) { - if (rts_waitConsoleHandlerCompletion()) { - /* If the Scheduler has set work->abandonOp, the Haskell thread has - * been thrown an exception (=> the worker must abandon this request.) - * We test for this below before invoking the on-completion routine. - */ - if (work->abandonOp) { - break; - } else { - continue; - } - } - } else { - break; /* Treat it like an error */ - } - } else { - break; - } - } else { - break; - } - } - if (len == -1) { errCode = errno; } - } - complData = work->workData.ioData.buf; - fd = work->workData.ioData.fd; - } else if ( work->workKind & WORKER_WRITE ) { - if ( work->workKind & WORKER_FOR_SOCKET ) { - len = send(work->workData.ioData.fd, - work->workData.ioData.buf, - work->workData.ioData.len, - 0); - if (len == SOCKET_ERROR) { - errCode = WSAGetLastError(); - } - } else { - len = write(work->workData.ioData.fd, - work->workData.ioData.buf, - work->workData.ioData.len); - if (len == -1) { + // The error code is communicated back on completion of request; reset. + errCode = 0; + + EnterCriticalSection(&iom->manLock); + /* Signal that the worker is idle. + * + * 'workersIdle' is used when determining whether or not to + * increase the worker thread pool when adding a new request. + * (see addIORequest().) + */ + iom->workersIdle++; + LeaveCriticalSection(&iom->manLock); + + /* + * A possible future refinement is to make long-term idle threads + * wake up and decide to shut down should the number of idle threads + * be above some threshold. + * + */ + rc = WaitForMultipleObjects( 2, hWaits, FALSE, INFINITE ); + + if (rc == WAIT_OBJECT_0) { + // we received the exit event + EnterCriticalSection(&iom->manLock); + ioMan->numWorkers--; + LeaveCriticalSection(&iom->manLock); + return 0; + } + + EnterCriticalSection(&iom->manLock); + /* Signal that the thread is 'non-idle' and about to consume + * a work item. + */ + iom->workersIdle--; + iom->queueSize--; + LeaveCriticalSection(&iom->manLock); + + if ( rc == (WAIT_OBJECT_0 + 1) ) { + /* work item available, fetch it. */ + if (FetchWork(pq,(void**)&work)) { + work->abandonOp = 0; + RegisterWorkItem(iom,work); + if ( work->workKind & WORKER_READ ) { + if ( work->workKind & WORKER_FOR_SOCKET ) { + len = recv(work->workData.ioData.fd, + work->workData.ioData.buf, + work->workData.ioData.len, + 0); + if (len == SOCKET_ERROR) { + errCode = WSAGetLastError(); + } + } else { + while (1) { + // Do the read(), with extra-special handling for Ctrl+C + len = read(work->workData.ioData.fd, + work->workData.ioData.buf, + work->workData.ioData.len); + if ( len == 0 && work->workData.ioData.len != 0 ) { + /* Given the following scenario: + * - a console handler has been registered + * that handles Ctrl+C events. + * - we've not tweaked the 'console mode' + * settings to turn on + * ENABLE_PROCESSED_INPUT. + * - we're blocked waiting on input from + standard input. + * - the user hits Ctrl+C. + * + * The OS will invoke the console handler + * (in a separate OS thread), and the + * above read() (i.e., under the hood, a + * ReadFile() op) returns 0, with the + * error set to + * ERROR_OPERATION_ABORTED. We don't want + * to percolate this error condition back + * to the Haskell user. Do this by + * waiting for the completion of the + * Haskell console handler. If upon + * completion of the console handler + * routine, the Haskell thread that issued + * the request is found to have been + * thrown an exception, the worker + * abandons the request (since that's what + * the Haskell thread has done.) If the + * Haskell thread hasn't been interrupted, + * the worker retries the read request as + * if nothing happened. + */ + if ( (GetLastError()) == ERROR_OPERATION_ABORTED ) { + /* For now, only abort when dealing + * with the standard input handle. + * i.e., for all others, an error is + * raised. + */ + HANDLE h = + (HANDLE)GetStdHandle(STD_INPUT_HANDLE); + int iofd = work->workData.ioData.fd; + if ( _get_osfhandle(iofd) == (intptr_t)h ) { + if (rts_waitConsoleHandlerCompletion()) { + /* If the Scheduler has set + * work->abandonOp, the + * Haskell thread has been + * thrown an exception (=> the + * worker must abandon this + * request.) We test for this + * below before invoking the + * on-completion routine. + */ + if (work->abandonOp) { + break; + } else { + continue; + } + } + } else { + break; /* Treat it like an error */ + } + } else { + break; + } + } else { + break; + } + } + if (len == -1) { errCode = errno; } + } + complData = work->workData.ioData.buf; + fd = work->workData.ioData.fd; + } else if ( work->workKind & WORKER_WRITE ) { + if ( work->workKind & WORKER_FOR_SOCKET ) { + len = send(work->workData.ioData.fd, + work->workData.ioData.buf, + work->workData.ioData.len, + 0); + if (len == SOCKET_ERROR) { + errCode = WSAGetLastError(); + } + } else { + len = write(work->workData.ioData.fd, + work->workData.ioData.buf, + work->workData.ioData.len); + if (len == -1) { errCode = errno; // write() gets errno wrong for // ERROR_NO_DATA, we have to fix it here: @@ -192,13 +212,13 @@ IOWorkerProc(PVOID param) errCode = EPIPE; } } - } - complData = work->workData.ioData.buf; - fd = work->workData.ioData.fd; - } else if ( work->workKind & WORKER_DELAY ) { - /* Approximate implementation of threadDelay; - * - * Note: Sleep() is in milliseconds, not micros. + } + complData = work->workData.ioData.buf; + fd = work->workData.ioData.fd; + } else if ( work->workKind & WORKER_DELAY ) { + /* Approximate implementation of threadDelay; + * + * Note: Sleep() is in milliseconds, not micros. * * MSDN says of Sleep: * If dwMilliseconds is greater than one tick @@ -210,66 +230,70 @@ IOWorkerProc(PVOID param) * * test ThreadDelay001 fails if we get this wrong. */ - Sleep(((work->workData.delayData.usecs + 999) / 1000) + iom->sleepResolution - 1); - len = work->workData.delayData.usecs; - complData = NULL; - fd = 0; - errCode = 0; - } else if ( work->workKind & WORKER_DO_PROC ) { - /* perform operation/proc on behalf of Haskell thread. */ - if (work->workData.procData.proc) { - /* The procedure is assumed to encode result + success/failure - * via its param. - */ - errCode=work->workData.procData.proc(work->workData.procData.param); - } else { - errCode=1; - } - complData = work->workData.procData.param; - } else { - fprintf(stderr, "unknown work request type (%d) , ignoring.\n", work->workKind); - fflush(stderr); - continue; - } - if (!work->abandonOp) { - work->onCompletion(work->requestID, - fd, - len, - complData, - errCode); - } - /* Free the WorkItem */ - DeregisterWorkItem(iom,work); - free(work); - } else { - fprintf(stderr, "unable to fetch work; fatal.\n"); fflush(stderr); - EnterCriticalSection(&iom->manLock); - ioMan->numWorkers--; - LeaveCriticalSection(&iom->manLock); - return 1; - } - } else { - fprintf(stderr, "waiting failed (%lu); fatal.\n", rc); fflush(stderr); - EnterCriticalSection(&iom->manLock); - ioMan->numWorkers--; - LeaveCriticalSection(&iom->manLock); - return 1; - } + Sleep(((work->workData.delayData.usecs + 999) / 1000) + + iom->sleepResolution - 1); + len = work->workData.delayData.usecs; + complData = NULL; + fd = 0; + errCode = 0; + } else if ( work->workKind & WORKER_DO_PROC ) { + // perform operation/proc on behalf of Haskell thread. + if (work->workData.procData.proc) { + // The procedure is assumed to encode result + + // success/failure via its param. + void* param = work->workData.procData.param; + errCode=work->workData.procData.proc(param); + } else { + errCode=1; + } + complData = work->workData.procData.param; + } else { + fprintf(stderr, "unknown work request type (%d), " + "ignoring.\n", work->workKind); + fflush(stderr); + continue; + } + if (!work->abandonOp) { + work->onCompletion(work->requestID, + fd, + len, + complData, + errCode); + } + // Free the WorkItem + DeregisterWorkItem(iom,work); + free(work); + } else { + fprintf(stderr, "unable to fetch work; fatal.\n"); + fflush(stderr); + EnterCriticalSection(&iom->manLock); + ioMan->numWorkers--; + LeaveCriticalSection(&iom->manLock); + return 1; + } + } else { + fprintf(stderr, "waiting failed (%lu); fatal.\n", rc); + fflush(stderr); + EnterCriticalSection(&iom->manLock); + ioMan->numWorkers--; + LeaveCriticalSection(&iom->manLock); + return 1; + } } return 0; } -static +static BOOL NewIOWorkerThread(IOManagerState* iom) { unsigned threadId; return ( 0 != _beginthreadex(NULL, - 0, - IOWorkerProc, - (LPVOID)iom, - 0, - &threadId) ); + 0, + IOWorkerProc, + (LPVOID)iom, + 0, + &threadId) ); } BOOL @@ -292,21 +316,21 @@ StartIOManager(void) } wq = NewWorkQueue(); - if ( !wq ) return FALSE; - + if ( !wq ) return FALSE; + ioMan = (IOManagerState*)malloc(sizeof(IOManagerState)); - + if (!ioMan) { - FreeWorkQueue(wq); - return FALSE; + FreeWorkQueue(wq); + return FALSE; } /* A manual-reset event */ hExit = CreateEvent ( NULL, TRUE, FALSE, NULL ); if ( !hExit ) { - FreeWorkQueue(wq); - free(ioMan); - return FALSE; + FreeWorkQueue(wq); + free(ioMan); + return FALSE; } ioMan->hExitEvent = hExit; @@ -319,7 +343,7 @@ StartIOManager(void) InitializeCriticalSection(&ioMan->active_work_lock); ioMan->active_work_items = NULL; ioMan->sleepResolution = sleepResolution; - + return TRUE; } @@ -334,63 +358,65 @@ StartIOManager(void) static int depositWorkItem( unsigned int reqID, - WorkItem* wItem ) + WorkItem* wItem ) { EnterCriticalSection(&ioMan->manLock); #if 0 - fprintf(stderr, "depositWorkItem: %d/%d\n", ioMan->workersIdle, ioMan->numWorkers); + fprintf(stderr, "depositWorkItem: %d/%d\n", + ioMan->workersIdle, ioMan->numWorkers); fflush(stderr); #endif /* A new worker thread is created when there are fewer idle threads * than non-consumed queue requests. This ensures that requests will * be dealt with in a timely manner. * - * [Long explanation of why the previous thread pool policy lead to + * [Long explanation of why the previous thread pool policy lead to * trouble] * * Previously, the thread pool was augmented iff no idle worker threads * were available. That strategy runs the risk of repeatedly adding to * the request queue without expanding the thread pool to handle this - * sudden spike in queued requests. - * [How? Assume workersIdle is 1, and addIORequest() is called. No new + * sudden spike in queued requests. + * [How? Assume workersIdle is 1, and addIORequest() is called. No new * thread is created and the request is simply queued. If addIORequest() * is called again _before the OS schedules a worker thread to pull the - * request off the queue_, workersIdle is still 1 and another request is + * request off the queue_, workersIdle is still 1 and another request is * simply added to the queue. Once the worker thread is run, only one * request is de-queued, leaving the 2nd request in the queue] - * - * Assuming none of the queued requests take an inordinate amount of to - * complete, the request queue would eventually be drained. But if that's - * not the case, the later requests will end up languishing in the queue - * indefinitely. The non-timely handling of requests may cause CH applications - * to misbehave / hang; bad. + * + * Assuming none of the queued requests take an inordinate amount + * of to complete, the request queue would eventually be + * drained. But if that's not the case, the later requests will + * end up languishing in the queue indefinitely. The non-timely + * handling of requests may cause CH applications to misbehave / + * hang; bad. * */ ioMan->queueSize++; if ( (ioMan->workersIdle < ioMan->queueSize) ) { - /* see if giving up our quantum ferrets out some idle threads. - */ - LeaveCriticalSection(&ioMan->manLock); - Sleep(0); - EnterCriticalSection(&ioMan->manLock); - if ( (ioMan->workersIdle < ioMan->queueSize) ) { - /* No, go ahead and create another. */ - ioMan->numWorkers++; - if (!NewIOWorkerThread(ioMan)) { - ioMan->numWorkers--; - } - } + /* see if giving up our quantum ferrets out some idle threads. + */ + LeaveCriticalSection(&ioMan->manLock); + Sleep(0); + EnterCriticalSection(&ioMan->manLock); + if ( (ioMan->workersIdle < ioMan->queueSize) ) { + /* No, go ahead and create another. */ + ioMan->numWorkers++; + if (!NewIOWorkerThread(ioMan)) { + ioMan->numWorkers--; + } + } } LeaveCriticalSection(&ioMan->manLock); - + if (SubmitWork(ioMan->workQueue,wItem)) { - /* Note: the work item has potentially been consumed by a worker thread - * (and freed) at this point, so we cannot use wItem's requestID. - */ - return reqID; + /* Note: the work item has potentially been consumed by a worker thread + * (and freed) at this point, so we cannot use wItem's requestID. + */ + return reqID; } else { - return 0; + return 0; } } @@ -399,23 +425,23 @@ depositWorkItem( unsigned int reqID, * * Conduit to underlying WorkQueue's SubmitWork(); adds IO * request to work queue, deciding whether or not to augment - * the thread pool in the process. + * the thread pool in the process. */ int AddIORequest ( int fd, - BOOL forWriting, - BOOL isSocket, - int len, - char* buffer, - CompletionProc onCompletion) + BOOL forWriting, + BOOL isSocket, + int len, + char* buffer, + CompletionProc onCompletion) { WorkItem* wItem = (WorkItem*)malloc(sizeof(WorkItem)); unsigned int reqID = ioMan->requestID++; if (!ioMan || !wItem) return 0; - + /* Fill in the blanks */ - wItem->workKind = ( isSocket ? WORKER_FOR_SOCKET : 0 ) | - ( forWriting ? WORKER_WRITE : WORKER_READ ); + wItem->workKind = ( isSocket ? WORKER_FOR_SOCKET : 0 ) | + ( forWriting ? WORKER_WRITE : WORKER_READ ); wItem->workData.ioData.fd = fd; wItem->workData.ioData.len = len; wItem->workData.ioData.buf = buffer; @@ -423,9 +449,9 @@ AddIORequest ( int fd, wItem->onCompletion = onCompletion; wItem->requestID = reqID; - + return depositWorkItem(reqID, wItem); -} +} /* * Function: AddDelayRequest() @@ -435,12 +461,12 @@ AddIORequest ( int fd, */ BOOL AddDelayRequest ( unsigned int usecs, - CompletionProc onCompletion) + CompletionProc onCompletion) { WorkItem* wItem = (WorkItem*)malloc(sizeof(WorkItem)); unsigned int reqID = ioMan->requestID++; if (!ioMan || !wItem) return FALSE; - + /* Fill in the blanks */ wItem->workKind = WORKER_DELAY; wItem->workData.delayData.usecs = usecs; @@ -458,13 +484,13 @@ AddDelayRequest ( unsigned int usecs, */ BOOL AddProcRequest ( void* proc, - void* param, - CompletionProc onCompletion) + void* param, + CompletionProc onCompletion) { WorkItem* wItem = (WorkItem*)malloc(sizeof(WorkItem)); unsigned int reqID = ioMan->requestID++; if (!ioMan || !wItem) return FALSE; - + /* Fill in the blanks */ wItem->workKind = WORKER_DO_PROC; wItem->workData.procData.proc = proc; @@ -483,7 +509,7 @@ void ShutdownIOManager ( rtsBool wait_threads ) MMRESULT mmresult; SetEvent(ioMan->hExitEvent); - + if (wait_threads) { /* Wait for all worker threads to die. */ for (;;) { @@ -510,10 +536,10 @@ void ShutdownIOManager ( rtsBool wait_threads ) } /* Keep track of WorkItems currently being serviced. */ -static +static void -RegisterWorkItem(IOManagerState* ioMan, - WorkItem* wi) +RegisterWorkItem(IOManagerState* ioMan, + WorkItem* wi) { EnterCriticalSection(&ioMan->active_work_lock); wi->link = ioMan->active_work_items; @@ -521,26 +547,27 @@ RegisterWorkItem(IOManagerState* ioMan, LeaveCriticalSection(&ioMan->active_work_lock); } -static +static void -DeregisterWorkItem(IOManagerState* ioMan, - WorkItem* wi) +DeregisterWorkItem(IOManagerState* ioMan, + WorkItem* wi) { WorkItem *ptr, *prev; - + EnterCriticalSection(&ioMan->active_work_lock); for(prev=NULL,ptr=ioMan->active_work_items;ptr;prev=ptr,ptr=ptr->link) { - if (wi->requestID == ptr->requestID) { - if (prev==NULL) { - ioMan->active_work_items = ptr->link; - } else { - prev->link = ptr->link; - } - LeaveCriticalSection(&ioMan->active_work_lock); - return; - } + if (wi->requestID == ptr->requestID) { + if (prev==NULL) { + ioMan->active_work_items = ptr->link; + } else { + prev->link = ptr->link; + } + LeaveCriticalSection(&ioMan->active_work_lock); + return; + } } - fprintf(stderr, "DeregisterWorkItem: unable to locate work item %d\n", wi->requestID); + fprintf(stderr, "DeregisterWorkItem: unable to locate work item %d\n", + wi->requestID); LeaveCriticalSection(&ioMan->active_work_lock); } @@ -562,11 +589,11 @@ abandonWorkRequest ( int reqID ) WorkItem *ptr; EnterCriticalSection(&ioMan->active_work_lock); for(ptr=ioMan->active_work_items;ptr;ptr=ptr->link) { - if (ptr->requestID == (unsigned int)reqID ) { - ptr->abandonOp = 1; - LeaveCriticalSection(&ioMan->active_work_lock); - return; - } + if (ptr->requestID == (unsigned int)reqID ) { + ptr->abandonOp = 1; + LeaveCriticalSection(&ioMan->active_work_lock); + return; + } } /* Note: if the request ID isn't present, the worker will have * finished sometime since awaitRequests() last drained the completed @@ -576,3 +603,11 @@ abandonWorkRequest ( int reqID ) } #endif + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/win32/IOManager.h b/rts/win32/IOManager.h index 866e950f4a..4ef5c9659b 100644 --- a/rts/win32/IOManager.h +++ b/rts/win32/IOManager.h @@ -13,7 +13,7 @@ /* The IOManager subsystem provides a non-blocking view of I/O operations. It lets one (or more) OS thread(s) - issue multiple I/O requests, which the IOManager then + issue multiple I/O requests, which the IOManager then handles independently of/concurrent to the thread(s) that issued the request. Upon completion, the issuing thread can inspect the result of the I/O operation & @@ -29,30 +29,30 @@ * */ typedef void (*CompletionProc)(unsigned int requestID, - int fd, - int len, - void* buf, - int errCode); + int fd, + int len, + void* buf, + int errCode); -/* +/* * Asynchronous procedure calls executed by a worker thread - * take a generic state argument pointer and return an int by - * default. + * take a generic state argument pointer and return an int by + * default. */ typedef int (*DoProcProc)(void *param); typedef union workData { struct { - int fd; - int len; - char *buf; + int fd; + int len; + char *buf; } ioData; - struct { - int usecs; + struct { + int usecs; } delayData; - struct { - DoProcProc proc; - void* param; + struct { + DoProcProc proc; + void* param; } procData; } WorkData; @@ -78,8 +78,8 @@ extern CompletionProc onComplete; #define WORKER_DO_PROC 16 /* - * Starting up and shutting down. - */ + * Starting up and shutting down. + */ extern BOOL StartIOManager ( void ); extern void ShutdownIOManager ( rtsBool wait_threads ); @@ -89,19 +89,27 @@ extern void ShutdownIOManager ( rtsBool wait_threads ); * will invoke upon completion. */ extern int AddDelayRequest ( unsigned int usecs, - CompletionProc onCompletion); + CompletionProc onCompletion); extern int AddIORequest ( int fd, - BOOL forWriting, - BOOL isSocket, - int len, - char* buffer, - CompletionProc onCompletion); + BOOL forWriting, + BOOL isSocket, + int len, + char* buffer, + CompletionProc onCompletion); extern int AddProcRequest ( void* proc, - void* data, - CompletionProc onCompletion); + void* data, + CompletionProc onCompletion); extern void abandonWorkRequest ( int reqID ); #endif /* WIN32_IOMANAGER_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/win32/OSMem.c b/rts/win32/OSMem.c index 082b8dec7f..0ee8d48d95 100644 --- a/rts/win32/OSMem.c +++ b/rts/win32/OSMem.c @@ -17,14 +17,14 @@ #endif typedef struct alloc_rec_ { - char* base; /* non-aligned base address, directly from VirtualAlloc */ - W_ size; /* Size in bytes */ + char* base; // non-aligned base address, directly from VirtualAlloc + W_ size; // Size in bytes struct alloc_rec_* next; } alloc_rec; typedef struct block_rec_ { - char* base; /* base address, non-MBLOCK-aligned */ - W_ size; /* size in bytes */ + char* base; // base address, non-MBLOCK-aligned + W_ size; // size in bytes struct block_rec_* next; } block_rec; @@ -89,19 +89,20 @@ insertFree(char* alloc_base, W_ alloc_size) { for( ; it!=0 && it->base<alloc_base; prev=it, it=it->next) {} if(it!=0 && alloc_base+alloc_size == it->base) { - if(prev->base + prev->size == alloc_base) { /* Merge it, alloc, prev */ + if(prev->base + prev->size == alloc_base) { /* Merge it, alloc, prev */ prev->size += alloc_size + it->size; prev->next = it->next; stgFree(it); - } else { /* Merge it, alloc */ + } else { /* Merge it, alloc */ it->base = alloc_base; it->size += alloc_size; } - } else if(prev->base + prev->size == alloc_base) { /* Merge alloc, prev */ + } else if(prev->base + prev->size == alloc_base) { /* Merge alloc, prev */ prev->size += alloc_size; - } else { /* Merge none */ + } else { /* Merge none */ block_rec* rec; - rec = (block_rec*)stgMallocBytes(sizeof(block_rec),"getMBlocks: insertFree"); + rec = (block_rec*)stgMallocBytes(sizeof(block_rec), + "getMBlocks: insertFree"); rec->base=alloc_base; rec->size=alloc_size; rec->next = it; @@ -139,7 +140,8 @@ findFreeBlocks(nat n) { char* need_base; block_rec* next; int new_size; - need_base = (char*)(((W_)it->base) & ((W_)~MBLOCK_MASK)) + MBLOCK_SIZE; + need_base = + (char*)(((W_)it->base) & ((W_)~MBLOCK_MASK)) + MBLOCK_SIZE; next = (block_rec*)stgMallocBytes( sizeof(block_rec) , "getMBlocks: findFreeBlocks: splitting"); @@ -305,7 +307,9 @@ void osReleaseFreeMemory(void) if (fb->base != a->base) { block_rec *new_fb; - new_fb = (block_rec *)stgMallocBytes(sizeof(block_rec),"osReleaseFreeMemory"); + new_fb = + (block_rec *)stgMallocBytes(sizeof(block_rec), + "osReleaseFreeMemory"); new_fb->base = fb->base; new_fb->size = a->base - fb->base; new_fb->next = fb; @@ -317,7 +321,8 @@ void osReleaseFreeMemory(void) /* Now we can free the alloc */ prev_a->next = a->next; if(!VirtualFree((void *)a->base, 0, MEM_RELEASE)) { - sysErrorBelch("freeAllMBlocks: VirtualFree MEM_RELEASE failed"); + sysErrorBelch("freeAllMBlocks: VirtualFree MEM_RELEASE " + "failed"); stg_exit(EXIT_FAILURE); } stgFree(a); @@ -389,7 +394,8 @@ StgWord64 getPhysicalMemorySize (void) status.dwLength = sizeof(status); if (!GlobalMemoryStatusEx(&status)) { #if defined(DEBUG) - errorBelch("warning: getPhysicalMemorySize: cannot get physical memory size"); + errorBelch("warning: getPhysicalMemorySize: cannot get physical " + "memory size"); #endif return 0; } @@ -405,8 +411,16 @@ void setExecutable (void *p, W_ len, rtsBool exec) exec ? PAGE_EXECUTE_READWRITE : PAGE_READWRITE, &dwOldProtect) == 0) { - sysErrorBelch("setExecutable: failed to protect 0x%p; old protection: %lu\n", - p, (unsigned long)dwOldProtect); + sysErrorBelch("setExecutable: failed to protect 0x%p; old protection: " + "%lu\n", p, (unsigned long)dwOldProtect); stg_exit(EXIT_FAILURE); } } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/win32/OSThreads.c b/rts/win32/OSThreads.c index 7183313ef4..9f434d696f 100644 --- a/rts/win32/OSThreads.c +++ b/rts/win32/OSThreads.c @@ -291,7 +291,8 @@ interruptOSThread (OSThreadId id) sysErrorBelch("interruptOSThread: OpenThread"); stg_exit(EXIT_FAILURE); } - pCSIO = (PCSIO) GetProcAddress(GetModuleHandle(TEXT("Kernel32.dll")), "CancelSynchronousIo"); + pCSIO = (PCSIO) GetProcAddress(GetModuleHandle(TEXT("Kernel32.dll")), + "CancelSynchronousIo"); if ( NULL != pCSIO ) { pCSIO(hdl); } else { @@ -320,3 +321,11 @@ KernelThreadId kernelThreadId (void) DWORD tid = GetCurrentThreadId(); return tid; } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/win32/ThrIOManager.c b/rts/win32/ThrIOManager.c index c4974016c1..05741789cf 100644 --- a/rts/win32/ThrIOManager.c +++ b/rts/win32/ThrIOManager.c @@ -2,7 +2,7 @@ * * (c) The GHC Team, 1998-2006 * - * The IO manager thread in THREADED_RTS. + * The IO manager thread in THREADED_RTS. * See also libraries/base/GHC/Conc.lhs. * * ---------------------------------------------------------------------------*/ @@ -66,7 +66,7 @@ getIOManagerEvent (void) HsWord32 readIOManagerEvent (void) { - // This function must exist even in non-THREADED_RTS, + // This function must exist even in non-THREADED_RTS, // see getIOManagerEvent() above. #if defined(THREADED_RTS) HsWord32 res; @@ -112,14 +112,14 @@ sendIOManagerEvent (HsWord32 event) if (!SetEvent(io_manager_event)) { sysErrorBelch("sendIOManagerEvent"); stg_exit(EXIT_FAILURE); - } + } event_buf[next_event++] = (StgWord32)event; } } RELEASE_LOCK(&event_buf_mutex); #endif -} +} void ioManagerWakeup (void) @@ -151,9 +151,17 @@ ioManagerStart (void) // Make sure the IO manager thread is running Capability *cap; if (io_manager_event == INVALID_HANDLE_VALUE) { - cap = rts_lock(); - rts_evalIO(&cap,ensureIOManagerIsRunning_closure,NULL); - rts_unlock(cap); + cap = rts_lock(); + rts_evalIO(&cap, ensureIOManagerIsRunning_closure, NULL); + rts_unlock(cap); } } #endif + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/win32/Ticker.c b/rts/win32/Ticker.c index 89902e568d..72f941a816 100644 --- a/rts/win32/Ticker.c +++ b/rts/win32/Ticker.c @@ -79,3 +79,11 @@ exitTicker (rtsBool wait) timer_queue = NULL; } } + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/win32/WorkQueue.c b/rts/win32/WorkQueue.c index b676072c96..b7793df322 100644 --- a/rts/win32/WorkQueue.c +++ b/rts/win32/WorkQueue.c @@ -1,6 +1,6 @@ /* * A fixed-size queue; MT-friendly. - * + * * (c) sof, 2002-2003. */ #include "WorkQueue.h" @@ -18,9 +18,9 @@ newSemaphore(int initCount, int max) { Semaphore s; s = CreateSemaphore ( NULL, /* LPSECURITY_ATTRIBUTES (default) */ - initCount, /* LONG lInitialCount */ - max, /* LONG lMaxCount */ - NULL); /* LPCTSTR (anonymous / no object name) */ + initCount, /* LONG lInitialCount */ + max, /* LONG lMaxCount */ + NULL); /* LPCTSTR (anonymous / no object name) */ if ( NULL == s) { queue_error_rc("newSemaphore", GetLastError()); return NULL; @@ -33,24 +33,24 @@ newSemaphore(int initCount, int max) * * The queue constructor - semaphores are initialised to match * max number of queue entries. - * + * */ WorkQueue* NewWorkQueue() { WorkQueue* wq = (WorkQueue*)malloc(sizeof(WorkQueue)); - + if (!wq) { queue_error("NewWorkQueue", "malloc() failed"); return wq; } - + memset(wq, 0, sizeof *wq); - + InitializeCriticalSection(&wq->queueLock); wq->workAvailable = newSemaphore(0, WORKQUEUE_SIZE); wq->roomAvailable = newSemaphore(WORKQUEUE_SIZE, WORKQUEUE_SIZE); - + /* Fail if we were unable to create any of the sync objects. */ if ( NULL == wq->workAvailable || NULL == wq->roomAvailable ) { @@ -75,7 +75,7 @@ FreeWorkQueue ( WorkQueue* pq ) /* Close the semaphores; any threads blocked waiting * on either will as a result be woken up. - */ + */ if ( pq->workAvailable ) { CloseHandle(pq->workAvailable); } @@ -91,7 +91,7 @@ HANDLE GetWorkQueueHandle ( WorkQueue* pq ) { if (!pq) return NULL; - + return pq->workAvailable; } @@ -114,14 +114,15 @@ GetWork ( WorkQueue* pq, void** ppw ) queue_error("GetWork", "NULL WorkItem object"); return FALSE; } - + /* Block waiting for work item to become available */ - if ( (rc = WaitForSingleObject( pq->workAvailable, INFINITE)) != WAIT_OBJECT_0 ) { - queue_error_rc("GetWork.WaitForSingleObject(workAvailable)", - ( (WAIT_FAILED == rc) ? GetLastError() : rc)); + if ( (rc = WaitForSingleObject( pq->workAvailable, INFINITE)) + != WAIT_OBJECT_0 ) { + queue_error_rc("GetWork.WaitForSingleObject(workAvailable)", + ( (WAIT_FAILED == rc) ? GetLastError() : rc)); return FALSE; } - + return FetchWork(pq,ppw); } @@ -144,7 +145,7 @@ FetchWork ( WorkQueue* pq, void** ppw ) queue_error("FetchWork", "NULL WorkItem object"); return FALSE; } - + EnterCriticalSection(&pq->queueLock); *ppw = pq->items[pq->head]; /* For sanity's sake, zero out the pointer. */ @@ -179,15 +180,16 @@ SubmitWork ( WorkQueue* pq, void* pw ) queue_error("SubmitWork", "NULL WorkItem object"); return FALSE; } - + /* Block waiting for work item to become available */ - if ( (rc = WaitForSingleObject( pq->roomAvailable, INFINITE)) != WAIT_OBJECT_0 ) { - queue_error_rc("SubmitWork.WaitForSingleObject(workAvailable)", - ( (WAIT_FAILED == rc) ? GetLastError() : rc)); + if ( (rc = WaitForSingleObject( pq->roomAvailable, INFINITE)) + != WAIT_OBJECT_0 ) { + queue_error_rc("SubmitWork.WaitForSingleObject(workAvailable)", + ( (WAIT_FAILED == rc) ? GetLastError() : rc)); return FALSE; } - + EnterCriticalSection(&pq->queueLock); pq->items[pq->tail] = pw; pq->tail = (pq->tail + 1) % WORKQUEUE_SIZE; @@ -205,20 +207,27 @@ SubmitWork ( WorkQueue* pq, void* pw ) static void queue_error_rc( char* loc, - DWORD err) + DWORD err) { fprintf(stderr, "%s failed: return code = 0x%lx\n", loc, err); fflush(stderr); return; } - + static void queue_error( char* loc, - char* reason) + char* reason) { fprintf(stderr, "%s failed: %s\n", loc, reason); fflush(stderr); return; } +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/win32/WorkQueue.h b/rts/win32/WorkQueue.h index 3ed2385ec9..3875915c2e 100644 --- a/rts/win32/WorkQueue.h +++ b/rts/win32/WorkQueue.h @@ -1,7 +1,7 @@ /* WorkQueue.h * * A fixed-size queue; MT-friendly. - * + * * (c) sof, 2002-2003 * */ @@ -36,3 +36,11 @@ extern BOOL FetchWork ( WorkQueue* pq, void** ppw ); extern int SubmitWork ( WorkQueue* pq, void* pw ); #endif /* WIN32_WORKQUEUE_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/win32/seh_excn.c b/rts/win32/seh_excn.c index da5f64d812..4934a7def0 100644 --- a/rts/win32/seh_excn.c +++ b/rts/win32/seh_excn.c @@ -43,3 +43,11 @@ catchDivZero(struct _EXCEPTION_RECORD* rec, #endif #endif + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rts/win32/seh_excn.h b/rts/win32/seh_excn.h index 8829e840b7..90a0ddcda0 100644 --- a/rts/win32/seh_excn.h +++ b/rts/win32/seh_excn.h @@ -90,3 +90,11 @@ catchDivZero(struct _EXCEPTION_RECORD*, #endif /* WIN32_SEH_EXCN_H */ + +// Local Variables: +// mode: C +// fill-column: 80 +// indent-tabs-mode: nil +// c-basic-offset: 4 +// buffer-file-coding-system: utf-8-unix +// End: diff --git a/rules/build-package-way.mk b/rules/build-package-way.mk index 294e43274a..3efe501451 100644 --- a/rules/build-package-way.mk +++ b/rules/build-package-way.mk @@ -23,13 +23,13 @@ $(call hs-objs,$1,$2,$3) # The .a/.so library file, indexed by two different sets of vars: # the first is indexed by the dir, distdir and way # the second is indexed by the package id, distdir and way -$1_$2_$3_LIB_NAME = libHS$$($1_PACKAGE)-$$($1_$2_VERSION)$$($3_libsuf) +$1_$2_$3_LIB_NAME = libHS$$($1_$2_PACKAGE_KEY)$$($3_libsuf) $1_$2_$3_LIB = $1/$2/build/$$($1_$2_$3_LIB_NAME) -$$($1_PACKAGE)-$$($1_$2_VERSION)_$2_$3_LIB = $$($1_$2_$3_LIB) +$$($1_$2_PACKAGE_KEY)_$2_$3_LIB = $$($1_$2_$3_LIB) ifeq "$$(HostOS_CPP)" "mingw32" ifneq "$$($1_$2_dll0_HS_OBJS)" "" -$1_$2_$3_LIB0_ROOT = HS$$($1_PACKAGE)-$$($1_$2_VERSION)-0$$($3_libsuf) +$1_$2_$3_LIB0_ROOT = HS$$($1_$2_PACKAGE_KEY)-0$$($3_libsuf) $1_$2_$3_LIB0_NAME = lib$$($1_$2_$3_LIB0_ROOT) $1_$2_$3_LIB0 = $1/$2/build/$$($1_$2_$3_LIB0_NAME) endif @@ -42,14 +42,16 @@ endif # Really we should use a consistent scheme for distdirs, but in the # meantime we work around it by defining ghc-<ver>_dist-install_way_LIB: ifeq "$$($1_PACKAGE) $2" "ghc stage2" -$$($1_PACKAGE)-$$($1_$2_VERSION)_dist-install_$3_LIB = $$($1_$2_$3_LIB) +$$($1_$2_PACKAGE_KEY)_dist-install_$3_LIB = $$($1_$2_$3_LIB) endif # All the .a/.so library file dependencies for this library. # # The $(subst stage2,dist-install,..) is needed due to Note # [inconsistent distdirs]. -$1_$2_$3_DEPS_LIBS=$$(foreach dep,$$($1_$2_DEPS),$$($$(dep)_$(subst stage2,dist-install,$2)_$3_LIB)) +# +# NB: Use DEP_KEYS, since DEPS only contains package IDs +$1_$2_$3_DEPS_LIBS=$$(foreach dep,$$($1_$2_DEP_KEYS),$$($$(dep)_$(subst stage2,dist-install,$2)_$3_LIB)) $1_$2_$3_NON_HS_OBJS = $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) $$($1_$2_EXTRA_OBJS) $1_$2_$3_ALL_OBJS = $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_NON_HS_OBJS) @@ -134,7 +136,7 @@ ifeq "$$(DYNAMIC_GHC_PROGRAMS)" "YES" $1_$2_GHCI_LIB = $$($1_$2_dyn_LIB) else ifeq "$3" "v" -$1_$2_GHCI_LIB = $1/$2/build/HS$$($1_PACKAGE)-$$($1_$2_VERSION).$$($3_osuf) +$1_$2_GHCI_LIB = $1/$2/build/HS$$($1_$2_PACKAGE_KEY).$$($3_osuf) ifeq "$$($1_$2_BUILD_GHCI_LIB)" "YES" # Don't put bootstrapping packages in the bindist ifneq "$4" "0" diff --git a/rules/build-prog.mk b/rules/build-prog.mk index 399369ecfb..f93b99d5f8 100644 --- a/rules/build-prog.mk +++ b/rules/build-prog.mk @@ -240,7 +240,7 @@ $1/$2/build/tmp/$$($1_$2_PROG)-wrapper.c: driver/utils/dynwrapper.c | $$$$(dir $ 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)' >> $$@)) + $$(foreach p,$$($1_$2_TRANSITIVE_DEP_KEYS),$$(call make-command,echo ' TEXT("/../lib/$$p")$$(comma)' >> $$@)) echo ' TEXT("/../lib/"),' >> $$@ echo ' NULL};' >> $$@ echo 'LPTSTR progDll = TEXT("../lib/$$($1_$2_PROG).dll");' >> $$@ @@ -286,7 +286,7 @@ endif ifeq "$(findstring clean,$(MAKECMDGOALS))" "" ifeq "$$($1_$2_INSTALL_INPLACE)" "YES" $$($1_$2_INPLACE) : $1/$2/build/tmp/$$($1_$2_PROG_INPLACE) | $$$$(dir $$$$@)/. - "$$(CP)" -p $$< $$@ + $$(INSTALL) -m 755 $$< $$@ endif endif diff --git a/rules/distdir-way-opts.mk b/rules/distdir-way-opts.mk index 93bc60b6b1..898485c0ca 100644 --- a/rules/distdir-way-opts.mk +++ b/rules/distdir-way-opts.mk @@ -81,6 +81,18 @@ define distdir-way-opts # args: $1 = dir, $2 = distdir, $3 = way, $4 = stage # $1_$2_$3_MOST_HC_OPTS is also passed to C compilations when we use # GHC as the C compiler. +# ToDo: It would be more accurate to version test this against what version of +# GHC we're using to see if it understands package-key +ifeq "$4" "0" +$1_$2_$4_DEP_OPTS = \ + $$(foreach pkg,$$($1_$2_DEPS),-package $$(pkg)) +$4_THIS_PACKAGE_KEY = -package-name +else +$1_$2_$4_DEP_OPTS = \ + $$(foreach pkg,$$($1_$2_DEP_KEYS),-package-key $$(pkg)) +$4_THIS_PACKAGE_KEY = -this-package-key +endif + $1_$2_$3_MOST_HC_OPTS = \ $$(WAY_$3_HC_OPTS) \ $$(CONF_HC_OPTS) \ @@ -88,7 +100,7 @@ $1_$2_$3_MOST_HC_OPTS = \ $$($1_HC_OPTS) \ $$($1_$2_HC_PKGCONF) \ $$(if $$($1_$2_PROG),, \ - $$(if $$($1_PACKAGE),-package-name $$($1_PACKAGE)-$$($1_$2_VERSION))) \ + $$(if $$($1_PACKAGE),$$($4_THIS_PACKAGE_KEY) $$($1_$2_PACKAGE_KEY))) \ $$(if $$($1_PACKAGE),-hide-all-packages) \ -i $$(if $$($1_$2_HS_SRC_DIRS),$$(foreach dir,$$($1_$2_HS_SRC_DIRS),-i$1/$$(dir)),-i$1) \ -i$1/$2/build -i$1/$2/build/autogen \ @@ -98,7 +110,7 @@ $1_$2_$3_MOST_HC_OPTS = \ $$(foreach inc,$$($1_$2_INCLUDE),-\#include "$$(inc)") \ $$(foreach opt,$$($1_$2_CPP_OPTS),-optP$$(opt)) \ $$(if $$($1_PACKAGE),-optP-include -optP$1/$2/build/autogen/cabal_macros.h) \ - $$(foreach pkg,$$($1_$2_DEPS),-package $$(pkg)) \ + $$($1_$2_$4_DEP_OPTS) \ $$($1_$2_HC_OPTS) \ $$(CONF_HC_OPTS_STAGE$4) \ $$($1_$2_MORE_HC_OPTS) \ @@ -170,11 +182,11 @@ ifneq "$4" "0" 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') -optl-Wl,-zorigin + $$(foreach d,$$($1_$2_TRANSITIVE_DEP_KEYS),-optl-Wl$$(comma)-rpath -optl-Wl$$(comma)'$$$$ORIGIN/../$$d') -optl-Wl,-zorigin else ifeq "$$(TargetOS_CPP)" "darwin" $1_$2_$3_GHC_LD_OPTS += \ -fno-use-rpaths \ - $$(foreach d,$$($1_$2_TRANSITIVE_DEPS),-optl-Wl$$(comma)-rpath -optl-Wl$$(comma)'@loader_path/../$$d') + $$(foreach d,$$($1_$2_TRANSITIVE_DEP_KEYS),-optl-Wl$$(comma)-rpath -optl-Wl$$(comma)'@loader_path/../$$d') endif endif endif diff --git a/settings.in b/settings.in index 9f9654c689..1bcb4aebc9 100644 --- a/settings.in +++ b/settings.in @@ -2,6 +2,8 @@ ("C compiler command", "@SettingsCCompilerCommand@"), ("C compiler flags", "@SettingsCCompilerFlags@"), ("C compiler link flags", "@SettingsCCompilerLinkFlags@"), + ("Haskell CPP command","@SettingsHaskellCPPCommand@"), + ("Haskell CPP flags","@SettingsHaskellCPPFlags@"), ("ld command", "@SettingsLdCommand@"), ("ld flags", "@SettingsLdFlags@"), ("ld supports compact unwind", "@LdHasNoCompactUnwind@"), diff --git a/testsuite/.gitignore b/testsuite/.gitignore index f25ca25097..d160143978 100644 --- a/testsuite/.gitignore +++ b/testsuite/.gitignore @@ -22,13 +22,16 @@ Thumbs.db *.o *.o-boot *.pyc -*.normalised *.eventlog *.comp.std* -.hpc +.hpc/ +.hpc.*/ *.genscript +*.stderr.normalised +*.stderr-ghc.normalised +*.stdout.normalised *.interp.stdout *.interp.stderr *.run.stdout @@ -37,18 +40,20 @@ Thumbs.db *.hp tests/**/*.ps *.stats +Setup +dist +tmp.d *.dyn_o *.dyn_hi *.dyn_hi-boot *o -*.hi *.dll *.dylib *.so -*.hpc.* *bindisttest_install___dir_bin_ghc.mk *bindisttest_install___dir_bin_ghc.exe.mk +mk/ghcconfig_*_inplace_bin_ghc-stage1.mk mk/ghcconfig_*_inplace_bin_ghc-stage2.mk mk/ghcconfig_*_inplace_bin_ghc-stage2.exe.mk *.imports @@ -56,1354 +61,1451 @@ mk/ghcconfig_*_inplace_bin_ghc-stage2.exe.mk # ----------------------------------------------------------------------------- # specific generated files +/mk/ghc-config +/tests/annotations/should_compile/th/build_make +/tests/annotations/should_run/Config.hs +/tests/annotations/should_run/annrun01 +/tests/array/should_run/arr001 +/tests/array/should_run/arr002 +/tests/array/should_run/arr003 +/tests/array/should_run/arr004 +/tests/array/should_run/arr005 +/tests/array/should_run/arr006 +/tests/array/should_run/arr007 +/tests/array/should_run/arr008 +/tests/array/should_run/arr009 +/tests/array/should_run/arr010 +/tests/array/should_run/arr011 +/tests/array/should_run/arr012 +/tests/array/should_run/arr013 +/tests/array/should_run/arr014 +/tests/array/should_run/arr015 +/tests/array/should_run/arr016 +/tests/array/should_run/arr017 +/tests/array/should_run/arr018 +/tests/array/should_run/arr019 +/tests/array/should_run/arr020 +/tests/arrows/should_run/T3822 +/tests/arrows/should_run/arrowrun001 +/tests/arrows/should_run/arrowrun002 +/tests/arrows/should_run/arrowrun003 +/tests/arrows/should_run/arrowrun004 +/tests/boxy/T2193 +/tests/cabal/1750.hs +/tests/cabal/1750.out +/tests/cabal/T1750.hs +/tests/cabal/T1750.out +/tests/cabal/cabal01/dist/ +/tests/cabal/cabal01/install/ +/tests/cabal/cabal01/local.db/ +/tests/cabal/cabal01/setup +/tests/cabal/cabal03/Setup +/tests/cabal/cabal03/p/dist/ +/tests/cabal/cabal03/q/dist/ +/tests/cabal/cabal03/tmp.d/ +/tests/cabal/cabal04/Setup +/tests/cabal/cabal04/dist/ +/tests/cabal/cabal04/err +/tests/cabal/cabal05/p-0.1.0.0/ +/tests/cabal/cabal05/q-0.1.0.0/ +/tests/cabal/cabal05/r-0.1.0.0/ +/tests/cabal/cabal06/inst-*/ +/tests/cabal/cabal06/tmp* +/tests/cabal/local01.package.conf/ +/tests/cabal/local03.package.conf/ +/tests/cabal/local04.package.conf/ +/tests/cabal/local05a.package.conf/ +/tests/cabal/local05b.package.conf/ +/tests/cabal/local06.package.conf/ +/tests/cabal/local07.package.conf/ +/tests/cabal/local1750.package.conf/ +/tests/cabal/localT1750.package.conf/ +/tests/cabal/localshadow1.package.conf/ +/tests/cabal/localshadow2.package.conf/ +/tests/cabal/package.conf.*/ +/tests/cabal/recache_reexport_db/package.cache +/tests/cabal/shadow.hs +/tests/cabal/shadow1.out +/tests/cabal/shadow2.out +/tests/cabal/shadow3.out +/tests/callarity/perf/T3924 +/tests/callarity/should_run/StrictLet +/tests/callarity/unittest/CallArity1 +/tests/codeGen/should_compile/2578 +/tests/codeGen/should_compile/T2578 +/tests/codeGen/should_gen_asm/memcpy-unroll-conprop.s +/tests/codeGen/should_gen_asm/memcpy-unroll.s +/tests/codeGen/should_gen_asm/memcpy.s +/tests/codeGen/should_gen_asm/memset-unroll.s +/tests/codeGen/should_run/1852 +/tests/codeGen/should_run/1861 +/tests/codeGen/should_run/2080 +/tests/codeGen/should_run/2838 +/tests/codeGen/should_run/3207 +/tests/codeGen/should_run/3561 +/tests/codeGen/should_run/3677 +/tests/codeGen/should_run/4441 +/tests/codeGen/should_run/5129 +/tests/codeGen/should_run/5149 +/tests/codeGen/should_run/5626 +/tests/codeGen/should_run/5747 +/tests/codeGen/should_run/5785 +/tests/codeGen/should_run/6146 +/tests/codeGen/should_run/CopySmallArray +/tests/codeGen/should_run/CopySmallArrayStressTest +/tests/codeGen/should_run/SizeOfSmallArray +/tests/codeGen/should_run/StaticArraySize +/tests/codeGen/should_run/StaticByteArraySize +/tests/codeGen/should_run/T1852 +/tests/codeGen/should_run/T1861 +/tests/codeGen/should_run/T2080 +/tests/codeGen/should_run/T2838 +/tests/codeGen/should_run/T3207 +/tests/codeGen/should_run/T3561 +/tests/codeGen/should_run/T3677 +/tests/codeGen/should_run/T4441 +/tests/codeGen/should_run/T5129 +/tests/codeGen/should_run/T5149 +/tests/codeGen/should_run/T5626 +/tests/codeGen/should_run/T5747 +/tests/codeGen/should_run/T5785 +/tests/codeGen/should_run/T5900 +/tests/codeGen/should_run/T6084 +/tests/codeGen/should_run/T6146 +/tests/codeGen/should_run/T7163 +/tests/codeGen/should_run/T7319 +/tests/codeGen/should_run/T7361 +/tests/codeGen/should_run/T7600 +/tests/codeGen/should_run/T7953 +/tests/codeGen/should_run/T8103 +/tests/codeGen/should_run/T8256 +/tests/codeGen/should_run/T9001 +/tests/codeGen/should_run/Word2Float64 +/tests/codeGen/should_run/cgrun001 +/tests/codeGen/should_run/cgrun002 +/tests/codeGen/should_run/cgrun003 +/tests/codeGen/should_run/cgrun004 +/tests/codeGen/should_run/cgrun005 +/tests/codeGen/should_run/cgrun006 +/tests/codeGen/should_run/cgrun007 +/tests/codeGen/should_run/cgrun008 +/tests/codeGen/should_run/cgrun009 +/tests/codeGen/should_run/cgrun010 +/tests/codeGen/should_run/cgrun011 +/tests/codeGen/should_run/cgrun012 +/tests/codeGen/should_run/cgrun013 +/tests/codeGen/should_run/cgrun014 +/tests/codeGen/should_run/cgrun015 +/tests/codeGen/should_run/cgrun016 +/tests/codeGen/should_run/cgrun017 +/tests/codeGen/should_run/cgrun018 +/tests/codeGen/should_run/cgrun019 +/tests/codeGen/should_run/cgrun020 +/tests/codeGen/should_run/cgrun021 +/tests/codeGen/should_run/cgrun022 +/tests/codeGen/should_run/cgrun024 +/tests/codeGen/should_run/cgrun026 +/tests/codeGen/should_run/cgrun027 +/tests/codeGen/should_run/cgrun028 +/tests/codeGen/should_run/cgrun031 +/tests/codeGen/should_run/cgrun032 +/tests/codeGen/should_run/cgrun033 +/tests/codeGen/should_run/cgrun034 +/tests/codeGen/should_run/cgrun035 +/tests/codeGen/should_run/cgrun036 +/tests/codeGen/should_run/cgrun037 +/tests/codeGen/should_run/cgrun038 +/tests/codeGen/should_run/cgrun039 +/tests/codeGen/should_run/cgrun040 +/tests/codeGen/should_run/cgrun043 +/tests/codeGen/should_run/cgrun044 +/tests/codeGen/should_run/cgrun045 +/tests/codeGen/should_run/cgrun046 +/tests/codeGen/should_run/cgrun047 +/tests/codeGen/should_run/cgrun048 +/tests/codeGen/should_run/cgrun049 +/tests/codeGen/should_run/cgrun050 +/tests/codeGen/should_run/cgrun051 +/tests/codeGen/should_run/cgrun052 +/tests/codeGen/should_run/cgrun053 +/tests/codeGen/should_run/cgrun054 +/tests/codeGen/should_run/cgrun055 +/tests/codeGen/should_run/cgrun056 +/tests/codeGen/should_run/cgrun057 +/tests/codeGen/should_run/cgrun058 +/tests/codeGen/should_run/cgrun059 +/tests/codeGen/should_run/cgrun060 +/tests/codeGen/should_run/cgrun061 +/tests/codeGen/should_run/cgrun062 +/tests/codeGen/should_run/cgrun063 +/tests/codeGen/should_run/cgrun064 +/tests/codeGen/should_run/cgrun065 +/tests/codeGen/should_run/cgrun066 +/tests/codeGen/should_run/cgrun067 +/tests/codeGen/should_run/cgrun068 +/tests/codeGen/should_run/cgrun069 +/tests/codeGen/should_run/cgrun070 +/tests/codeGen/should_run/cgrun071 +/tests/codeGen/should_run/cgrun072 +/tests/codeGen/should_run/setByteArray +/tests/concurrent/T2317/T2317 +/tests/concurrent/prog001/concprog001 +/tests/concurrent/prog002/concprog002 +/tests/concurrent/prog002/concprog002.aux +/tests/concurrent/prog002/concprog002.hp +/tests/concurrent/prog002/concprog002.ps +/tests/concurrent/prog003/concprog003 +/tests/concurrent/should_run/1980 +/tests/concurrent/should_run/2910 +/tests/concurrent/should_run/2910a +/tests/concurrent/should_run/3279 +/tests/concurrent/should_run/3429 +/tests/concurrent/should_run/367 +/tests/concurrent/should_run/367_letnoescape +/tests/concurrent/should_run/4030 +/tests/concurrent/should_run/4811 +/tests/concurrent/should_run/4813 +/tests/concurrent/should_run/5238 +/tests/concurrent/should_run/5421 +/tests/concurrent/should_run/5558 +/tests/concurrent/should_run/5611 +/tests/concurrent/should_run/5866 +/tests/concurrent/should_run/T1980 +/tests/concurrent/should_run/T2910 +/tests/concurrent/should_run/T2910a +/tests/concurrent/should_run/T3279 +/tests/concurrent/should_run/T3429 +/tests/concurrent/should_run/T367 +/tests/concurrent/should_run/T367_letnoescape +/tests/concurrent/should_run/T4030 +/tests/concurrent/should_run/T4811 +/tests/concurrent/should_run/T4813 +/tests/concurrent/should_run/T5238 +/tests/concurrent/should_run/T5421 +/tests/concurrent/should_run/T5558 +/tests/concurrent/should_run/T5611 +/tests/concurrent/should_run/T5866 +/tests/concurrent/should_run/T7970 +/tests/concurrent/should_run/AtomicPrimops +/tests/concurrent/should_run/allowinterrupt001 +/tests/concurrent/should_run/async001 +/tests/concurrent/should_run/compareAndSwap +/tests/concurrent/should_run/conc001 +/tests/concurrent/should_run/conc002 +/tests/concurrent/should_run/conc003 +/tests/concurrent/should_run/conc004 +/tests/concurrent/should_run/conc006 +/tests/concurrent/should_run/conc007 +/tests/concurrent/should_run/conc008 +/tests/concurrent/should_run/conc009 +/tests/concurrent/should_run/conc010 +/tests/concurrent/should_run/conc012 +/tests/concurrent/should_run/conc013 +/tests/concurrent/should_run/conc014 +/tests/concurrent/should_run/conc015 +/tests/concurrent/should_run/conc015a +/tests/concurrent/should_run/conc016 +/tests/concurrent/should_run/conc017 +/tests/concurrent/should_run/conc017a +/tests/concurrent/should_run/conc018 +/tests/concurrent/should_run/conc019 +/tests/concurrent/should_run/conc020 +/tests/concurrent/should_run/conc021 +/tests/concurrent/should_run/conc022 +/tests/concurrent/should_run/conc023 +/tests/concurrent/should_run/conc024 +/tests/concurrent/should_run/conc025 +/tests/concurrent/should_run/conc026 +/tests/concurrent/should_run/conc027 +/tests/concurrent/should_run/conc028 +/tests/concurrent/should_run/conc029 +/tests/concurrent/should_run/conc030 +/tests/concurrent/should_run/conc031 +/tests/concurrent/should_run/conc032 +/tests/concurrent/should_run/conc033 +/tests/concurrent/should_run/conc034 +/tests/concurrent/should_run/conc035 +/tests/concurrent/should_run/conc036 +/tests/concurrent/should_run/conc037 +/tests/concurrent/should_run/conc038 +/tests/concurrent/should_run/conc039 +/tests/concurrent/should_run/conc040 +/tests/concurrent/should_run/conc041 +/tests/concurrent/should_run/conc042 +/tests/concurrent/should_run/conc043 +/tests/concurrent/should_run/conc044 +/tests/concurrent/should_run/conc045 +/tests/concurrent/should_run/conc051 +/tests/concurrent/should_run/conc058 +/tests/concurrent/should_run/conc059 +/tests/concurrent/should_run/conc064 +/tests/concurrent/should_run/conc065 +/tests/concurrent/should_run/conc066 +/tests/concurrent/should_run/conc067 +/tests/concurrent/should_run/conc068 +/tests/concurrent/should_run/conc069 +/tests/concurrent/should_run/conc069a +/tests/concurrent/should_run/conc070 +/tests/concurrent/should_run/conc071 +/tests/concurrent/should_run/conc072 +/tests/concurrent/should_run/conc073 +/tests/concurrent/should_run/foreignInterruptible +/tests/concurrent/should_run/mask001 +/tests/concurrent/should_run/mask002 +/tests/concurrent/should_run/numsparks001 +/tests/concurrent/should_run/readMVar1 +/tests/concurrent/should_run/readMVar2 +/tests/concurrent/should_run/readMVar3 +/tests/concurrent/should_run/setnumcapabilities001 +/tests/concurrent/should_run/throwto001 +/tests/concurrent/should_run/throwto002 +/tests/concurrent/should_run/throwto003 +/tests/concurrent/should_run/tryReadMVar1 +/tests/concurrent/should_run/tryReadMVar2 +/tests/concurrent/should_run/threadstatus-9333 +/tests/cpranal/should_run/CPRRepeat +/tests/deSugar/should_run/DsLambdaCase +/tests/deSugar/should_run/DsMultiWayIf +/tests/deSugar/should_run/T246 +/tests/deSugar/should_run/T3126 +/tests/deSugar/should_run/T3382 +/tests/deSugar/should_run/T5742 +/tests/deSugar/should_run/T8952 +/tests/deSugar/should_run/dsrun001 +/tests/deSugar/should_run/dsrun002 +/tests/deSugar/should_run/dsrun003 +/tests/deSugar/should_run/dsrun004 +/tests/deSugar/should_run/dsrun005 +/tests/deSugar/should_run/dsrun006 +/tests/deSugar/should_run/dsrun007 +/tests/deSugar/should_run/dsrun008 +/tests/deSugar/should_run/dsrun009 +/tests/deSugar/should_run/dsrun010 +/tests/deSugar/should_run/dsrun011 +/tests/deSugar/should_run/dsrun012 +/tests/deSugar/should_run/dsrun013 +/tests/deSugar/should_run/dsrun014 +/tests/deSugar/should_run/dsrun015 +/tests/deSugar/should_run/dsrun016 +/tests/deSugar/should_run/dsrun017 +/tests/deSugar/should_run/dsrun018 +/tests/deSugar/should_run/dsrun019 +/tests/deSugar/should_run/dsrun020 +/tests/deSugar/should_run/dsrun021 +/tests/deSugar/should_run/dsrun022 +/tests/deSugar/should_run/dsrun023 +/tests/deSugar/should_run/mc01 +/tests/deSugar/should_run/mc02 +/tests/deSugar/should_run/mc03 +/tests/deSugar/should_run/mc04 +/tests/deSugar/should_run/mc05 +/tests/deSugar/should_run/mc06 +/tests/deSugar/should_run/mc07 +/tests/deSugar/should_run/mc08 +/tests/deriving/should_run/T2529 +/tests/deriving/should_run/T4136 +/tests/deriving/should_run/T4528a +/tests/deriving/should_run/T5041 +/tests/deriving/should_run/T5628 +/tests/deriving/should_run/T5712 +/tests/deriving/should_run/T7931 +/tests/deriving/should_run/T8280 +/tests/deriving/should_run/drvrun-foldable1 +/tests/deriving/should_run/drvrun-functor1 +/tests/deriving/should_run/drvrun001 +/tests/deriving/should_run/drvrun002 +/tests/deriving/should_run/drvrun003 +/tests/deriving/should_run/drvrun004 +/tests/deriving/should_run/drvrun005 +/tests/deriving/should_run/drvrun006 +/tests/deriving/should_run/drvrun007 +/tests/deriving/should_run/drvrun008 +/tests/deriving/should_run/drvrun009 +/tests/deriving/should_run/drvrun010 +/tests/deriving/should_run/drvrun011 +/tests/deriving/should_run/drvrun012 +/tests/deriving/should_run/drvrun013 +/tests/deriving/should_run/drvrun014 +/tests/deriving/should_run/drvrun015 +/tests/deriving/should_run/drvrun016 +/tests/deriving/should_run/drvrun017 +/tests/deriving/should_run/drvrun018 +/tests/deriving/should_run/drvrun019 +/tests/deriving/should_run/drvrun020 +/tests/deriving/should_run/drvrun021 +/tests/dph/classes/dph-classes-copy-fast +/tests/dph/classes/dph-classes-fast +/tests/dph/classes/dph-classes-vseg-fast +/tests/dph/diophantine/dph-diophantine-copy-fast +/tests/dph/diophantine/dph-diophantine-copy-opt /tests/dph/diophantine/dph-diophantine-fast /tests/dph/diophantine/dph-diophantine-opt +/tests/dph/dotp/dph-dotp-copy-fast +/tests/dph/dotp/dph-dotp-copy-opt /tests/dph/dotp/dph-dotp-fast +/tests/dph/dotp/dph-dotp-opt +/tests/dph/dotp/dph-dotp-vseg-fast +/tests/dph/dotp/dph-dotp-vseg-opt +/tests/dph/nbody/dph-nbody-copy-fast +/tests/dph/nbody/dph-nbody-copy-opt +/tests/dph/nbody/dph-nbody-vseg-fast +/tests/dph/nbody/dph-nbody-vseg-opt +/tests/dph/primespj/dph-primespj-copy-fast +/tests/dph/primespj/dph-primespj-copy-opt /tests/dph/primespj/dph-primespj-fast +/tests/dph/primespj/dph-primespj-opt +/tests/dph/quickhull/dph-quickhull-copy-fast +/tests/dph/quickhull/dph-quickhull-copy-opt /tests/dph/quickhull/dph-quickhull-fast +/tests/dph/quickhull/dph-quickhull-opt +/tests/dph/quickhull/dph-quickhull-vseg-fast +/tests/dph/quickhull/dph-quickhull-vseg-opt /tests/dph/smvm/dph-smvm +/tests/dph/smvm/dph-smvm-copy +/tests/dph/smvm/dph-smvm-vseg /tests/dph/sumnats/dph-sumnats +/tests/dph/sumnats/dph-sumnats-copy +/tests/dph/sumnats/dph-sumnats-vseg +/tests/dph/words/dph-words-copy-fast +/tests/dph/words/dph-words-copy-opt /tests/dph/words/dph-words-fast +/tests/dph/words/dph-words-opt +/tests/dph/words/dph-words-vseg-fast +/tests/dph/words/dph-words-vseg-opt +/tests/driver/1959/E.hs +/tests/driver/1959/prog +/tests/driver/3674_pre +/tests/driver/437/Test +/tests/driver/437/Test2 +/tests/driver/5313 +/tests/driver/A012.ooo +/tests/driver/A013.xhi +/tests/driver/A061a.s +/tests/driver/A061b.s +/tests/driver/A064.hspp +/tests/driver/A065.hspp +/tests/driver/A066.tmp +/tests/driver/A067.tmp +/tests/driver/A070.s +/tests/driver/A071.tmp +/tests/driver/B022/C.ooo +/tests/driver/B023/C.xhi +/tests/driver/B024a/ +/tests/driver/B062d/ +/tests/driver/B062e/ +/tests/driver/F018a.obj.018 +/tests/driver/F018a_stub.obj.018 +/tests/driver/Hello062a.hs +/tests/driver/Hello062b.hs +/tests/driver/Hello062c.hs +/tests/driver/T1959/E.hs +/tests/driver/T1959/prog +/tests/driver/T3007/A/Setup +/tests/driver/T3007/A/dist/ +/tests/driver/T3007/B/Setup +/tests/driver/T3007/B/dist/ +/tests/driver/T3007/package.conf +/tests/driver/T3389 +/tests/driver/T3674_pre +/tests/driver/T437/Test +/tests/driver/T437/Test2 +/tests/driver/T4437 +/tests/driver/T5147/B.hs +/tests/driver/T5198dump/ +/tests/driver/T5313 +/tests/driver/T5584/A.hi-boot +/tests/driver/T5584_out/ +/tests/driver/T703 +/tests/driver/T706.hs +/tests/driver/T7060dump/ +/tests/driver/T7373/package.conf +/tests/driver/T7373/pkg/Setup +/tests/driver/T7373/pkg/dist/ +/tests/driver/T7835/Test +/tests/driver/T8526/A.inc +/tests/driver/T8602/t8602.sh +/tests/driver/Test.081b +/tests/driver/Test.081b.hs +/tests/driver/Test_081a +/tests/driver/Test_081a.hs +/tests/driver/depend200 +/tests/driver/dynHelloWorld +/tests/driver/dynamicToo/A001.dyn_hi +/tests/driver/dynamicToo/A001.dyn_o +/tests/driver/dynamicToo/A002.dyn_hi +/tests/driver/dynamicToo/A002.dyn_o +/tests/driver/dynamicToo/A003.dyn_hi +/tests/driver/dynamicToo/A003.dyn_o +/tests/driver/dynamicToo/B001.dyn_hi +/tests/driver/dynamicToo/B001.dyn_o +/tests/driver/dynamicToo/B002.dyn_hi +/tests/driver/dynamicToo/B002.dyn_o +/tests/driver/dynamicToo/C001.dyn_hi +/tests/driver/dynamicToo/C001.dyn_o +/tests/driver/dynamicToo/C002.dyn_hi +/tests/driver/dynamicToo/C002.dyn_o +/tests/driver/dynamicToo/d001 +/tests/driver/dynamicToo/dynamicToo004/Setup +/tests/driver/dynamicToo/dynamicToo004/local.package.conf/ +/tests/driver/dynamicToo/dynamicToo004/pkg1/dist/ +/tests/driver/dynamicToo/dynamicToo004/pkg1dyn/dist/ +/tests/driver/dynamicToo/dynamicToo004/pkg2/dist/ +/tests/driver/dynamicToo/dynamicToo004/progstatic +/tests/driver/dynamicToo/s001 +/tests/driver/dynamic_flags_001/C +/tests/driver/hello062a +/tests/driver/hello062b +/tests/driver/hello062c +/tests/driver/hello062d +/tests/driver/hello062e +/tests/driver/objc/objc-hi +/tests/driver/objc/objcpp-hi +/tests/driver/out019/ +/tests/driver/recomp001/B.hs +/tests/driver/recomp001/C +/tests/driver/recomp003/Data/ +/tests/driver/recomp003/err +/tests/driver/recomp004/MainX +/tests/driver/recomp004/MainX.hs +/tests/driver/recomp004/c.c +/tests/driver/recomp005/C.hs +/tests/driver/recomp006/B.hs +/tests/driver/recomp006/err +/tests/driver/recomp006/out +/tests/driver/recomp007/Setup +/tests/driver/recomp007/a1/dist/ +/tests/driver/recomp007/a2/dist/ +/tests/driver/recomp007/b/dist/ +/tests/driver/recomp007/local.package.conf/ +/tests/driver/recomp008/A.hs +/tests/driver/recomp008/prog /tests/driver/recomp009/Main /tests/driver/recomp009/Sub.hs +/tests/driver/recomp010/Main +/tests/driver/recomp010/X.hs +/tests/driver/recomp011/A.hsinc +/tests/driver/recomp011/B.hsinc +/tests/driver/recomp011/Main +/tests/driver/recomp012/Foo.hs +/tests/driver/recomp012/Main +/tests/driver/recomp012/Main.hs +/tests/driver/recomp012/MyBool.hs +/tests/driver/rtsOpts +/tests/driver/rtsopts002 +/tests/driver/spacesInArgs +/tests/driver/stub017/ +/tests/driver/stub028/ +/tests/driver/stub035/ +/tests/driver/stub045/ +/tests/driver/withRtsOpts +/tests/driver/withRtsOpts.out +/tests/dynlibs/T3807-load +/tests/dynlibs/T3807test.so +/tests/dynlibs/T5373A +/tests/dynlibs/T5373B +/tests/dynlibs/T5373C +/tests/dynlibs/T5373D +/tests/ext-core/T7239.hcr +/tests/ffi/should_run/1288 +/tests/ffi/should_run/1679 +/tests/ffi/should_run/2276 +/tests/ffi/should_run/2469 +/tests/ffi/should_run/2594 +/tests/ffi/should_run/2917a +/tests/ffi/should_run/4038 +/tests/ffi/should_run/4221 +/tests/ffi/should_run/5402 +/tests/ffi/should_run/5594 +/tests/ffi/should_run/7170 +/tests/ffi/should_run/Capi_Ctype_001 +/tests/ffi/should_run/Capi_Ctype_001.hs +/tests/ffi/should_run/Capi_Ctype_002 +/tests/ffi/should_run/Capi_Ctype_A_001.hs +/tests/ffi/should_run/Capi_Ctype_A_002.hs +/tests/ffi/should_run/T1288 +/tests/ffi/should_run/T1679 +/tests/ffi/should_run/T2276 +/tests/ffi/should_run/T2469 +/tests/ffi/should_run/T2594 +/tests/ffi/should_run/T2917a +/tests/ffi/should_run/T4012 +/tests/ffi/should_run/T4038 +/tests/ffi/should_run/T4221 +/tests/ffi/should_run/T5402 +/tests/ffi/should_run/T5594 +/tests/ffi/should_run/T7170 +/tests/ffi/should_run/T8083 +/tests/ffi/should_run/capi_value +/tests/ffi/should_run/fed001 +/tests/ffi/should_run/ffi001 +/tests/ffi/should_run/ffi002 +/tests/ffi/should_run/ffi003 +/tests/ffi/should_run/ffi005 +/tests/ffi/should_run/ffi006 +/tests/ffi/should_run/ffi007 +/tests/ffi/should_run/ffi008 +/tests/ffi/should_run/ffi009 +/tests/ffi/should_run/ffi010 +/tests/ffi/should_run/ffi011 +/tests/ffi/should_run/ffi013 +/tests/ffi/should_run/ffi014 +/tests/ffi/should_run/ffi015 +/tests/ffi/should_run/ffi016 +/tests/ffi/should_run/ffi017 +/tests/ffi/should_run/ffi018 +/tests/ffi/should_run/ffi019 +/tests/ffi/should_run/ffi020 +/tests/ffi/should_run/ffi021 +/tests/ffi/should_run/ffi022 +/tests/ffi/should_run/ffi_parsing_001 +/tests/ffi/should_run/fptr01 +/tests/ffi/should_run/fptr02 +/tests/ffi/should_run/fptrfail01 +/tests/gadt/CasePrune +/tests/gadt/Session +/tests/gadt/T9380 +/tests/gadt/gadt2 +/tests/gadt/gadt23 +/tests/gadt/gadt4 +/tests/gadt/gadt5 +/tests/gadt/records +/tests/gadt/tc +/tests/gadt/type-rep +/tests/gadt/ubx-records +/tests/gadt/while +/tests/generics/GEq/GEq1 +/tests/generics/GEq/GEq2 +/tests/generics/GFunctor/GFunctor1 +/tests/generics/GMap/GMap1 +/tests/generics/GShow/GShow1 +/tests/generics/GenNewtype +/tests/generics/Uniplate/GUniplate1 +/tests/ghc-api/T4891/T4891 +/tests/ghc-api/T6145 +/tests/ghc-api/T7478/A +/tests/ghc-api/T7478/T7478 +/tests/ghc-api/T8628 +/tests/ghc-api/T8639_api +/tests/ghc-api/apirecomp001/myghc +/tests/ghc-api/dynCompileExpr/dynCompileExpr +/tests/ghc-api/ghcApi +/tests/ghci.debugger/scripts/break022/A.hs +/tests/ghci.debugger/scripts/break023/A.hs +/tests/ghci/linking/dir001/ +/tests/ghci/linking/dir002/ +/tests/ghci/linking/dir004/ +/tests/ghci/linking/dir005/ +/tests/ghci/linking/dir006/ +/tests/ghci/prog001/C.hs +/tests/ghci/prog001/D.hs +/tests/ghci/prog002/A.hs +/tests/ghci/prog003/D.hs +/tests/ghci/prog004/ctest.c +/tests/ghci/prog005/A.hs +/tests/ghci/prog006/Boot.hs +/tests/ghci/prog009/A.hs +/tests/ghci/prog012/Bar.hs +/tests/ghci/scripts/Ghci058.hs +/tests/ghci/scripts/T1914A.hs +/tests/ghci/scripts/T1914B.hs +/tests/ghci/scripts/T6106.hs +/tests/ghci/scripts/T6106_preproc +/tests/ghci/scripts/föøbà r1.hs +/tests/ghci/scripts/föøbà r2.hs +/tests/ghci/scripts/ghci027.hs +/tests/ghci/should_run/3171.err +/tests/hsc2hs/3837.hs +/tests/hsc2hs/T3837.hs +/tests/hsc2hs/hsc2hs001.hs +/tests/hsc2hs/hsc2hs002.hs +/tests/hsc2hs/hsc2hs003 +/tests/hsc2hs/hsc2hs003.hs +/tests/hsc2hs/hsc2hs004 +/tests/hsc2hs/hsc2hs004.hs +/tests/indexed-types/should_fail/T8129.trace +/tests/indexed-types/should_run/GMapAssoc +/tests/indexed-types/should_run/GMapTop +/tests/indexed-types/should_run/T2985 +/tests/indexed-types/should_run/T4235 +/tests/indexed-types/should_run/T5719 +/tests/lib/Concurrent/4876 +/tests/lib/Concurrent/ThreadDelay001 +/tests/lib/Data.ByteString/bytestring002 +/tests/lib/Data.ByteString/bytestring003 +/tests/lib/Data.ByteString/bytestring006 +/tests/lib/IO/2122 +/tests/lib/IO/2122-test +/tests/lib/IO/3307 +/tests/lib/IO/4808 +/tests/lib/IO/4808.test +/tests/lib/IO/4855 +/tests/lib/IO/4895 +/tests/lib/IO/IOError001 +/tests/lib/IO/IOError002 +/tests/lib/IO/T4113 +/tests/lib/IO/T4144 +/tests/lib/IO/chinese-file-* +/tests/lib/IO/chinese-name +/tests/lib/IO/concio002 +/tests/lib/IO/countReaders001 +/tests/lib/IO/countReaders001.txt +/tests/lib/IO/decodingerror001 +/tests/lib/IO/decodingerror002 +/tests/lib/IO/encoding001 +/tests/lib/IO/encoding001.utf16 +/tests/lib/IO/encoding001.utf16.utf16be +/tests/lib/IO/encoding001.utf16.utf16le +/tests/lib/IO/encoding001.utf16.utf32 +/tests/lib/IO/encoding001.utf16.utf32be +/tests/lib/IO/encoding001.utf16.utf32le +/tests/lib/IO/encoding001.utf16.utf8 +/tests/lib/IO/encoding001.utf16.utf8_bom +/tests/lib/IO/encoding001.utf16be +/tests/lib/IO/encoding001.utf16be.utf16 +/tests/lib/IO/encoding001.utf16be.utf16le +/tests/lib/IO/encoding001.utf16be.utf32 +/tests/lib/IO/encoding001.utf16be.utf32be +/tests/lib/IO/encoding001.utf16be.utf32le +/tests/lib/IO/encoding001.utf16be.utf8 +/tests/lib/IO/encoding001.utf16be.utf8_bom +/tests/lib/IO/encoding001.utf16le +/tests/lib/IO/encoding001.utf16le.utf16 +/tests/lib/IO/encoding001.utf16le.utf16be +/tests/lib/IO/encoding001.utf16le.utf32 +/tests/lib/IO/encoding001.utf16le.utf32be +/tests/lib/IO/encoding001.utf16le.utf32le +/tests/lib/IO/encoding001.utf16le.utf8 +/tests/lib/IO/encoding001.utf16le.utf8_bom +/tests/lib/IO/encoding001.utf32 +/tests/lib/IO/encoding001.utf32.utf16 +/tests/lib/IO/encoding001.utf32.utf16be +/tests/lib/IO/encoding001.utf32.utf16le +/tests/lib/IO/encoding001.utf32.utf32be +/tests/lib/IO/encoding001.utf32.utf32le +/tests/lib/IO/encoding001.utf32.utf8 +/tests/lib/IO/encoding001.utf32.utf8_bom +/tests/lib/IO/encoding001.utf32be +/tests/lib/IO/encoding001.utf32be.utf16 +/tests/lib/IO/encoding001.utf32be.utf16be +/tests/lib/IO/encoding001.utf32be.utf16le +/tests/lib/IO/encoding001.utf32be.utf32 +/tests/lib/IO/encoding001.utf32be.utf32le +/tests/lib/IO/encoding001.utf32be.utf8 +/tests/lib/IO/encoding001.utf32be.utf8_bom +/tests/lib/IO/encoding001.utf32le +/tests/lib/IO/encoding001.utf32le.utf16 +/tests/lib/IO/encoding001.utf32le.utf16be +/tests/lib/IO/encoding001.utf32le.utf16le +/tests/lib/IO/encoding001.utf32le.utf32 +/tests/lib/IO/encoding001.utf32le.utf32be +/tests/lib/IO/encoding001.utf32le.utf8 +/tests/lib/IO/encoding001.utf32le.utf8_bom +/tests/lib/IO/encoding001.utf8 +/tests/lib/IO/encoding001.utf8.utf16 +/tests/lib/IO/encoding001.utf8.utf16be +/tests/lib/IO/encoding001.utf8.utf16le +/tests/lib/IO/encoding001.utf8.utf32 +/tests/lib/IO/encoding001.utf8.utf32be +/tests/lib/IO/encoding001.utf8.utf32le +/tests/lib/IO/encoding001.utf8.utf8_bom +/tests/lib/IO/encoding001.utf8_bom +/tests/lib/IO/encoding001.utf8_bom.utf16 +/tests/lib/IO/encoding001.utf8_bom.utf16be +/tests/lib/IO/encoding001.utf8_bom.utf16le +/tests/lib/IO/encoding001.utf8_bom.utf32 +/tests/lib/IO/encoding001.utf8_bom.utf32be +/tests/lib/IO/encoding001.utf8_bom.utf32le +/tests/lib/IO/encoding001.utf8_bom.utf8 +/tests/lib/IO/encoding002 +/tests/lib/IO/encodingerror001 +/tests/lib/IO/environment001 +/tests/lib/IO/finalization001 +/tests/lib/IO/hClose001 +/tests/lib/IO/hClose001.tmp +/tests/lib/IO/hClose002 +/tests/lib/IO/hClose002.tmp +/tests/lib/IO/hClose003 +/tests/lib/IO/hDuplicateTo001 +/tests/lib/IO/hFileSize001 +/tests/lib/IO/hFileSize002 +/tests/lib/IO/hFileSize002.out +/tests/lib/IO/hFlush001 +/tests/lib/IO/hFlush001.out +/tests/lib/IO/hGetBuf001 +/tests/lib/IO/hGetBuffering001 +/tests/lib/IO/hGetChar001 +/tests/lib/IO/hGetLine001 +/tests/lib/IO/hGetLine002 +/tests/lib/IO/hGetLine003 +/tests/lib/IO/hGetPosn001 +/tests/lib/IO/hGetPosn001.out +/tests/lib/IO/hIsEOF001 +/tests/lib/IO/hIsEOF002 +/tests/lib/IO/hIsEOF002.out +/tests/lib/IO/hReady001 +/tests/lib/IO/hReady002 +/tests/lib/IO/hSeek001 +/tests/lib/IO/hSeek002 +/tests/lib/IO/hSeek003 +/tests/lib/IO/hSeek004 +/tests/lib/IO/hSeek004.out +/tests/lib/IO/hSetBuffering002 +/tests/lib/IO/hSetBuffering003 +/tests/lib/IO/hSetBuffering004 +/tests/lib/IO/hSetEncoding001 +/tests/lib/IO/ioeGetErrorString001 +/tests/lib/IO/ioeGetFileName001 +/tests/lib/IO/ioeGetHandle001 +/tests/lib/IO/isEOF001 +/tests/lib/IO/misc001 +/tests/lib/IO/misc001.out +/tests/lib/IO/newline001 +/tests/lib/IO/newline001.out +/tests/lib/IO/openFile001 +/tests/lib/IO/openFile002 +/tests/lib/IO/openFile003 +/tests/lib/IO/openFile004 +/tests/lib/IO/openFile004.out +/tests/lib/IO/openFile005 +/tests/lib/IO/openFile005.out1 +/tests/lib/IO/openFile005.out2 +/tests/lib/IO/openFile006 +/tests/lib/IO/openFile006.out +/tests/lib/IO/openFile007 +/tests/lib/IO/openFile007.out +/tests/lib/IO/openFile008 +/tests/lib/IO/openTempFile001 +/tests/lib/IO/putStr001 +/tests/lib/IO/readFile001 +/tests/lib/IO/readFile001.out +/tests/lib/IO/readwrite001 +/tests/lib/IO/readwrite001.inout +/tests/lib/IO/readwrite002 +/tests/lib/IO/readwrite002.inout +/tests/lib/IO/readwrite003 +/tests/lib/IO/readwrite003.txt +/tests/lib/IO/tmp +/tests/lib/IOExts/echo001 +/tests/lib/IOExts/hGetBuf002 +/tests/lib/IOExts/hGetBuf003 +/tests/lib/IOExts/hPutBuf001 +/tests/lib/IOExts/hPutBuf002 +/tests/lib/IOExts/hPutBuf002.out +/tests/lib/IOExts/hTell001 +/tests/lib/IOExts/hTell002 +/tests/lib/IOExts/performGC001 +/tests/lib/IOExts/trace001 +/tests/lib/IORef/ +/tests/lib/Numeric/ +/tests/lib/OldException/OldException001 +/tests/lib/PrettyPrint/T3911 +/tests/lib/PrettyPrint/pp1 +/tests/lib/Text.Printf/1548 +/tests/lib/Time/T5430 +/tests/lib/Time/time002 +/tests/lib/Time/time003 +/tests/lib/Time/time004 +/tests/lib/exceptions/exceptions001 +/tests/lib/integer/IntegerConversionRules.simpl +/tests/lib/integer/fromToInteger.simpl +/tests/lib/integer/gcdInteger +/tests/lib/integer/integerBits +/tests/lib/integer/integerConstantFolding +/tests/lib/integer/integerConstantFolding.simpl +/tests/lib/integer/integerConversions +/tests/lib/integer/integerGmpInternals +/tests/lib/libposix/po003.out +/tests/lib/libposix/posix002 +/tests/lib/libposix/posix003 +/tests/lib/libposix/posix004 +/tests/lib/libposix/posix006 +/tests/lib/libposix/posix009 +/tests/lib/libposix/posix010 +/tests/lib/libposix/posix014 +/tests/lib/should_run/4006 +/tests/lib/should_run/addr001 +/tests/lib/should_run/array001 +/tests/lib/should_run/array001.data +/tests/lib/should_run/char001 +/tests/lib/should_run/char002 +/tests/lib/should_run/cstring001 +/tests/lib/should_run/dynamic001 +/tests/lib/should_run/dynamic002 +/tests/lib/should_run/dynamic003 +/tests/lib/should_run/dynamic004 +/tests/lib/should_run/dynamic005 +/tests/lib/should_run/enum01 +/tests/lib/should_run/enum02 +/tests/lib/should_run/enum03 +/tests/lib/should_run/enum04 +/tests/lib/should_run/exceptionsrun001 +/tests/lib/should_run/exceptionsrun002 +/tests/lib/should_run/length001 +/tests/lib/should_run/list001 +/tests/lib/should_run/list002 +/tests/lib/should_run/list003 +/tests/lib/should_run/memo001 +/tests/lib/should_run/memo002 +/tests/lib/should_run/rand001 +/tests/lib/should_run/ratio001 +/tests/lib/should_run/reads001 +/tests/lib/should_run/show001 +/tests/lib/should_run/stableptr001 +/tests/lib/should_run/stableptr003 +/tests/lib/should_run/stableptr004 +/tests/lib/should_run/stableptr005 +/tests/lib/should_run/text001 +/tests/lib/should_run/tup001 +/tests/lib/should_run/weak001 +/tests/mdo/should_compile/mdo001 +/tests/mdo/should_compile/mdo002 +/tests/mdo/should_compile/mdo003 +/tests/mdo/should_compile/mdo004 +/tests/mdo/should_compile/mdo005 +/tests/mdo/should_fail/mdofail006 +/tests/mdo/should_run/mdorun001 +/tests/mdo/should_run/mdorun002 +/tests/mdo/should_run/mdorun003 +/tests/mdo/should_run/mdorun004 +/tests/mdo/should_run/mdorun005 +/tests/module/Mod145_A.mod146_hi +/tests/module/Mod145_A.mod146_o +/tests/module/Mod157_A.mod158_hi +/tests/module/Mod157_A.mod158_o +/tests/module/Mod157_B.mod158_hi +/tests/module/Mod157_B.mod158_o +/tests/module/Mod157_C.mod158_hi +/tests/module/Mod157_C.mod158_o +/tests/module/Mod157_D.mod158_hi +/tests/module/Mod157_D.mod158_o +/tests/module/Mod159_A.mod160_hi +/tests/module/Mod159_A.mod160_o +/tests/module/Mod159_B.mod160_hi +/tests/module/Mod159_B.mod160_o +/tests/module/Mod159_C.mod160_hi +/tests/module/Mod159_C.mod160_o +/tests/module/Mod159_D.mod160_hi +/tests/module/Mod159_D.mod160_o +/tests/module/Mod164_A.mod165_hi +/tests/module/Mod164_A.mod165_o +/tests/module/Mod164_A.mod166_hi +/tests/module/Mod164_A.mod166_o +/tests/module/Mod164_A.mod167_hi +/tests/module/Mod164_A.mod167_o +/tests/module/Mod164_B.mod165_hi +/tests/module/Mod164_B.mod165_o +/tests/module/Mod164_B.mod166_hi +/tests/module/Mod164_B.mod166_o +/tests/module/Mod164_B.mod167_hi +/tests/module/Mod164_B.mod167_o +/tests/module/mod166.mod166_hi +/tests/module/mod166.mod166_o +/tests/module/mod167.mod167_hi +/tests/module/mod167.mod167_o +/tests/module/mod175/test +/tests/module/mod175/test2 +/tests/module/mod179 +/tests/numeric/should_run/3676 +/tests/numeric/should_run/4381 +/tests/numeric/should_run/4383 +/tests/numeric/should_run/NumDecimals +/tests/numeric/should_run/T3676 +/tests/numeric/should_run/T4381 +/tests/numeric/should_run/T4383 +/tests/numeric/should_run/T5863 +/tests/numeric/should_run/T7014 +/tests/numeric/should_run/T7014.simpl +/tests/numeric/should_run/T7233 +/tests/numeric/should_run/T7689 +/tests/numeric/should_run/T8726 +/tests/numeric/should_run/add2 +/tests/numeric/should_run/arith001 +/tests/numeric/should_run/arith002 +/tests/numeric/should_run/arith003 +/tests/numeric/should_run/arith004 +/tests/numeric/should_run/arith005 +/tests/numeric/should_run/arith006 +/tests/numeric/should_run/arith007 +/tests/numeric/should_run/arith008 +/tests/numeric/should_run/arith009 +/tests/numeric/should_run/arith010 +/tests/numeric/should_run/arith011 +/tests/numeric/should_run/arith012 +/tests/numeric/should_run/arith013 +/tests/numeric/should_run/arith014 +/tests/numeric/should_run/arith015 +/tests/numeric/should_run/arith016 +/tests/numeric/should_run/arith017 +/tests/numeric/should_run/arith018 +/tests/numeric/should_run/arith019 +/tests/numeric/should_run/expfloat +/tests/numeric/should_run/mul2 +/tests/numeric/should_run/numrun009 +/tests/numeric/should_run/numrun010 +/tests/numeric/should_run/numrun011 +/tests/numeric/should_run/numrun012 +/tests/numeric/should_run/numrun013 +/tests/numeric/should_run/numrun014 +/tests/numeric/should_run/quotRem2 +/tests/optasm-log +/tests/optllvm-32-log +/tests/optllvm-log +/tests/overloadedlists/should_run/overloadedlistsrun01 +/tests/overloadedlists/should_run/overloadedlistsrun02 +/tests/overloadedlists/should_run/overloadedlistsrun03 +/tests/overloadedlists/should_run/overloadedlistsrun04 +/tests/overloadedlists/should_run/overloadedlistsrun05 +/tests/parser/should_compile/T5243 +/tests/parser/should_compile/T7476/Main.imports +/tests/parser/should_compile/T7476/T7476 +/tests/parser/should_run/BinaryLiterals0 +/tests/parser/should_run/BinaryLiterals1 +/tests/parser/should_run/BinaryLiterals2 +/tests/parser/should_run/ParserMultiWayIf +/tests/parser/should_run/T1344 +/tests/parser/should_run/operator +/tests/parser/should_run/operator2 +/tests/parser/should_run/readRun001 +/tests/parser/should_run/readRun002 +/tests/parser/should_run/readRun003 +/tests/parser/should_run/readRun004 +/tests/parser/unicode/1744 +/tests/parser/unicode/T1744 +/tests/parser/unicode/utf8_024 +/tests/patsyn/should_run/bidir-explicit +/tests/patsyn/should_run/bidir-explicit-scope +/tests/patsyn/should_run/eval +/tests/patsyn/should_run/ex-prov +/tests/patsyn/should_run/ex-prov-run +/tests/patsyn/should_run/match +/tests/perf/compiler/T1969.comp.stats +/tests/perf/compiler/T3064.comp.stats +/tests/perf/compiler/T3294.comp.stats +/tests/perf/compiler/T4801.comp.stats +/tests/perf/compiler/T5030.comp.stats +/tests/perf/compiler/T5321FD.comp.stats +/tests/perf/compiler/T5321Fun.comp.stats +/tests/perf/compiler/T5631.comp.stats +/tests/perf/compiler/T5642.comp.stats +/tests/perf/compiler/T5837.comp.stats +/tests/perf/compiler/T6048.comp.stats +/tests/perf/compiler/T783.comp.stats +/tests/perf/compiler/parsing001.comp.stats +/tests/perf/should_run/3586 +/tests/perf/should_run/3586.stats +/tests/perf/should_run/Conversions +/tests/perf/should_run/Conversions.stats +/tests/perf/should_run/InlineArrayAlloc +/tests/perf/should_run/InlineByteArrayAlloc +/tests/perf/should_run/InlineCloneArrayAlloc +/tests/perf/should_run/MethSharing +/tests/perf/should_run/MethSharing.stats +/tests/perf/should_run/T149_A +/tests/perf/should_run/T149_B +/tests/perf/should_run/T2902_A +/tests/perf/should_run/T2902_B +/tests/perf/should_run/T3245 +/tests/perf/should_run/T3586 +/tests/perf/should_run/T3736 +/tests/perf/should_run/T3736.speed.f32 +/tests/perf/should_run/T3738 +/tests/perf/should_run/T3738.stats +/tests/perf/should_run/T4267 +/tests/perf/should_run/T4321 +/tests/perf/should_run/T4474a +/tests/perf/should_run/T4474a.stats +/tests/perf/should_run/T4474b +/tests/perf/should_run/T4474b.stats +/tests/perf/should_run/T4474c +/tests/perf/should_run/T4474c.stats +/tests/perf/should_run/T4830 +/tests/perf/should_run/T4830.stats +/tests/perf/should_run/T4978 +/tests/perf/should_run/T4978.stats +/tests/perf/should_run/T5113 +/tests/perf/should_run/T5113.stats +/tests/perf/should_run/T5205 +/tests/perf/should_run/T5205.stats +/tests/perf/should_run/T5237 +/tests/perf/should_run/T5237.stats +/tests/perf/should_run/T5536 +/tests/perf/should_run/T5536.data +/tests/perf/should_run/T5536.stats +/tests/perf/should_run/T5549 +/tests/perf/should_run/T5549.stats +/tests/perf/should_run/T5949 +/tests/perf/should_run/T7257 +/tests/perf/should_run/T7257.stats +/tests/perf/should_run/T7436 +/tests/perf/should_run/T7436.stats +/tests/perf/should_run/T7507 +/tests/perf/should_run/T7619 +/tests/perf/should_run/T7797 +/tests/perf/should_run/T7850 +/tests/perf/should_run/T7954 +/tests/perf/should_run/T876 +/tests/perf/should_run/T9203 +/tests/perf/should_run/T9339 +/tests/perf/should_run/lazy-bs-alloc +/tests/perf/should_run/lazy-bs-alloc.stats +/tests/perf/should_run/speed.f32 +/tests/perf/space_leaks/T2762 +/tests/perf/space_leaks/T2762.stats +/tests/perf/space_leaks/T4018 +/tests/perf/space_leaks/T4334 +/tests/perf/space_leaks/T4334.stats +/tests/perf/space_leaks/space_leak_001 +/tests/perf/space_leaks/space_leak_001.stats +/tests/plugins/plugins01 +/tests/plugins/plugins05 +/tests/plugins/plugins06 /tests/plugins/simple-plugin/dist/ /tests/plugins/simple-plugin/install/ /tests/plugins/simple-plugin/local.package.conf +/tests/plugins/simple-plugin/pkg.plugins01/ +/tests/plugins/simple-plugin/pkg.plugins02/ +/tests/plugins/simple-plugin/pkg.plugins03/ /tests/plugins/simple-plugin/setup +/tests/polykinds/Freeman +/tests/polykinds/MonoidsFD +/tests/polykinds/MonoidsTF +/tests/polykinds/PolyKinds09 +/tests/polykinds/PolyKinds10 +/tests/primops/should_run/T6135 +/tests/primops/should_run/T7689 +/tests/profiling/should_compile/prof001 +/tests/profiling/should_compile/prof002 +/tests/profiling/should_run/2592 +/tests/profiling/should_run/2592.aux +/tests/profiling/should_run/2592.hp +/tests/profiling/should_run/2592.ps +/tests/profiling/should_run/5314 +/tests/profiling/should_run/5314.hp +/tests/profiling/should_run/5314.ps +/tests/profiling/should_run/T2552 +/tests/profiling/should_run/T2592 +/tests/profiling/should_run/T3001 +/tests/profiling/should_run/T3001-2 +/tests/profiling/should_run/T3001-2.hp +/tests/profiling/should_run/T3001-2.ps +/tests/profiling/should_run/T3001.hp +/tests/profiling/should_run/T3001.ps +/tests/profiling/should_run/T5314 +/tests/profiling/should_run/T5363 +/tests/profiling/should_run/T5559 +/tests/profiling/should_run/T680 +/tests/profiling/should_run/T949 +/tests/profiling/should_run/T949.hp +/tests/profiling/should_run/T949.ps +/tests/profiling/should_run/callstack001 +/tests/profiling/should_run/callstack002 +/tests/profiling/should_run/heapprof001 +/tests/profiling/should_run/heapprof001.hp +/tests/profiling/should_run/heapprof001.ps +/tests/profiling/should_run/ioprof +/tests/profiling/should_run/prof-doc-fib +/tests/profiling/should_run/prof-doc-last +/tests/profiling/should_run/profinline001 +/tests/profiling/should_run/scc001 +/tests/profiling/should_run/scc002 +/tests/profiling/should_run/scc003 +/tests/profiling/should_run/scc004 +/tests/profiling/should_run/test.bin +/tests/programs/10queens/10queens +/tests/programs/Queens/queens +/tests/programs/andre_monad/andre_monad +/tests/programs/andy_cherry/andy_cherry +/tests/programs/barton-mangler-bug/barton-mangler-bug +/tests/programs/cholewo-eval/cholewo-eval +/tests/programs/cvh_unboxing/cvh_unboxing +/tests/programs/fast2haskell/fast2haskell +/tests/programs/fun_insts/fun_insts /tests/programs/hs-boot/Main +/tests/programs/jl_defaults/jl_defaults +/tests/programs/joao-circular/joao-circular +/tests/programs/jq_readsPrec/jq_readsPrec +/tests/programs/jtod_circint/jtod_circint +/tests/programs/jules_xref/jules_xref +/tests/programs/jules_xref2/jules_xref2 +/tests/programs/launchbury/launchbury +/tests/programs/lennart_range/lennart_range +/tests/programs/lex/lex +/tests/programs/life_space_leak/life_space_leak +/tests/programs/north_array/north_array +/tests/programs/record_upd/record_upd +/tests/programs/rittri/rittri +/tests/programs/sanders_array/sanders_array +/tests/programs/seward-space-leak/seward-space-leak +/tests/programs/strict_anns/strict_anns +/tests/programs/thurston-modular-arith/thurston-modular-arith +/tests/quasiquotation/T4491/T4491 +/tests/quasiquotation/T7918 +/tests/rebindable/T5038 +/tests/rebindable/rebindable10 +/tests/rebindable/rebindable2 +/tests/rebindable/rebindable3 +/tests/rebindable/rebindable4 +/tests/rebindable/rebindable5 +/tests/rebindable/rebindable7 +/tests/rename/prog006/local.package.conf +/tests/rename/prog006/pkg.conf +/tests/rename/prog006/pwd +/tests/rename/should_compile/T1792_imports.imports +/tests/rename/should_compile/T4239.imports +/tests/rename/should_compile/T4240.imports +/tests/rename/should_compile/T5592 +/tests/rts/2047 +/tests/rts/2783 +/tests/rts/3236 +/tests/rts/3424 +/tests/rts/4059 +/tests/rts/4850 +/tests/rts/5250 +/tests/rts/5644/5644 +/tests/rts/5993 +/tests/rts/7087 +/tests/rts/T2047 +/tests/rts/T2615 +/tests/rts/T2783 +/tests/rts/T3236 +/tests/rts/T3424 +/tests/rts/T4059 +/tests/rts/T4850 +/tests/rts/T5250 +/tests/rts/T5423 +/tests/rts/T5435*.so +/tests/rts/T5435*_o +/tests/rts/T5435_dyn_asm +/tests/rts/T5435_dyn_gcc +/tests/rts/T5435_v_asm +/tests/rts/T5435_v_gcc +/tests/rts/T5644/T5644 +/tests/rts/T5993 +/tests/rts/T6006 +/tests/rts/T7037 +/tests/rts/T7037_main +/tests/rts/T7040 +/tests/rts/T7087 +/tests/rts/T7160 +/tests/rts/T7227 +/tests/rts/T7227.stat +/tests/rts/T7636 +/tests/rts/T7815 +/tests/rts/T7919 +/tests/rts/T8035 +/tests/rts/T8124 +/tests/rts/T8209 +/tests/rts/T8242 +/tests/rts/T9045 +/tests/rts/T9078 +/tests/rts/atomicinc +/tests/rts/bug1010 +/tests/rts/derefnull +/tests/rts/divbyzero +/tests/rts/exec_signals +/tests/rts/exec_signals_child +/tests/rts/exec_signals_prepare +/tests/rts/ffishutdown +/tests/rts/libfoo_T2615.so +/tests/rts/linker_unload +/tests/rts/outofmem +/tests/rts/outofmem2 +/tests/rts/overflow1 +/tests/rts/overflow2 +/tests/rts/overflow3 +/tests/rts/prep.out +/tests/rts/return_mem_to_os +/tests/rts/rtsflags001 +/tests/rts/rtsflags002 +/tests/rts/stablename001 +/tests/rts/stack001 +/tests/rts/stack002 +/tests/rts/stack003 +/tests/rts/testblockalloc +/tests/rts/testwsdeque +/tests/rts/traceEvent +/tests/safeHaskell/check/Check04 /tests/safeHaskell/check/pkg01/dist/ /tests/safeHaskell/check/pkg01/install/ /tests/safeHaskell/check/pkg01/local.db/ +/tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly01/ +/tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly02/ +/tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly03/ +/tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly04/ +/tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly05/ +/tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly06/ +/tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly07/ +/tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly08/ +/tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly09/ +/tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly10/ +/tests/safeHaskell/check/pkg01/pdb.safePkg01/ /tests/safeHaskell/check/pkg01/setup -mk/ghc-config -tests/annotations/should_run/Config.hs -tests/annotations/should_run/annrun01 -tests/array/should_run/arr001 -tests/array/should_run/arr002 -tests/array/should_run/arr003 -tests/array/should_run/arr004 -tests/array/should_run/arr005 -tests/array/should_run/arr006 -tests/array/should_run/arr007 -tests/array/should_run/arr008 -tests/array/should_run/arr009 -tests/array/should_run/arr010 -tests/array/should_run/arr011 -tests/array/should_run/arr012 -tests/array/should_run/arr013 -tests/array/should_run/arr014 -tests/array/should_run/arr015 -tests/array/should_run/arr016 -tests/array/should_run/arr017 -tests/array/should_run/arr018 -tests/array/should_run/arr019 -tests/array/should_run/arr020 -tests/arrows/should_run/T3822 -tests/arrows/should_run/arrowrun001 -tests/arrows/should_run/arrowrun002 -tests/arrows/should_run/arrowrun003 -tests/arrows/should_run/arrowrun004 -tests/boxy/T2193 -tests/cabal/1750.hs -tests/cabal/1750.out -tests/cabal/T1750.hs -tests/cabal/T1750.out -tests/cabal/cabal01/dist/ -tests/cabal/cabal01/install/ -tests/cabal/cabal01/local.db/ -tests/cabal/cabal01/setup -tests/cabal/cabal03/Setup -tests/cabal/cabal03/p/dist/ -tests/cabal/cabal03/q/dist/ -tests/cabal/cabal03/tmp.d/ -tests/cabal/cabal04/Setup -tests/cabal/cabal04/dist/ -tests/cabal/cabal04/err -tests/cabal/local01.package.conf/ -tests/cabal/local03.package.conf/ -tests/cabal/local04.package.conf/ -tests/cabal/local05a.package.conf/ -tests/cabal/local05b.package.conf/ -tests/cabal/local06.package.conf/ -tests/cabal/local1750.package.conf/ -tests/cabal/localT1750.package.conf/ -tests/cabal/localshadow1.package.conf/ -tests/cabal/localshadow2.package.conf/ -tests/cabal/package.conf.ghcpkg02/ -tests/cabal/shadow.hs -tests/cabal/shadow1.out -tests/cabal/shadow2.out -tests/cabal/shadow3.out -tests/codeGen/should_compile/2578 -tests/codeGen/should_compile/T2578 -tests/codeGen/should_gen_asm/memcpy-unroll-conprop.s -tests/codeGen/should_gen_asm/memcpy-unroll.s -tests/codeGen/should_gen_asm/memcpy.s -tests/codeGen/should_gen_asm/memset-unroll.s -tests/codeGen/should_run/1852 -tests/codeGen/should_run/1861 -tests/codeGen/should_run/2080 -tests/codeGen/should_run/2838 -tests/codeGen/should_run/3207 -tests/codeGen/should_run/3561 -tests/codeGen/should_run/3677 -tests/codeGen/should_run/4441 -tests/codeGen/should_run/5129 -tests/codeGen/should_run/5149 -tests/codeGen/should_run/5626 -tests/codeGen/should_run/5747 -tests/codeGen/should_run/5785 -tests/codeGen/should_run/6146 -tests/codeGen/should_run/T1852 -tests/codeGen/should_run/T1861 -tests/codeGen/should_run/T2080 -tests/codeGen/should_run/T2838 -tests/codeGen/should_run/T3207 -tests/codeGen/should_run/T3561 -tests/codeGen/should_run/T3677 -tests/codeGen/should_run/T4441 -tests/codeGen/should_run/T5129 -tests/codeGen/should_run/T5149 -tests/codeGen/should_run/T5626 -tests/codeGen/should_run/T5747 -tests/codeGen/should_run/T5785 -tests/codeGen/should_run/T5900 -tests/codeGen/should_run/T6146 -tests/codeGen/should_run/T7163 -tests/codeGen/should_run/T7319 -tests/codeGen/should_run/T7361 -tests/codeGen/should_run/T7600 -tests/codeGen/should_run/Word2Float64 -tests/codeGen/should_run/cgrun001 -tests/codeGen/should_run/cgrun002 -tests/codeGen/should_run/cgrun003 -tests/codeGen/should_run/cgrun004 -tests/codeGen/should_run/cgrun005 -tests/codeGen/should_run/cgrun006 -tests/codeGen/should_run/cgrun007 -tests/codeGen/should_run/cgrun008 -tests/codeGen/should_run/cgrun009 -tests/codeGen/should_run/cgrun010 -tests/codeGen/should_run/cgrun011 -tests/codeGen/should_run/cgrun012 -tests/codeGen/should_run/cgrun013 -tests/codeGen/should_run/cgrun014 -tests/codeGen/should_run/cgrun015 -tests/codeGen/should_run/cgrun016 -tests/codeGen/should_run/cgrun017 -tests/codeGen/should_run/cgrun018 -tests/codeGen/should_run/cgrun019 -tests/codeGen/should_run/cgrun020 -tests/codeGen/should_run/cgrun021 -tests/codeGen/should_run/cgrun022 -tests/codeGen/should_run/cgrun024 -tests/codeGen/should_run/cgrun026 -tests/codeGen/should_run/cgrun027 -tests/codeGen/should_run/cgrun028 -tests/codeGen/should_run/cgrun031 -tests/codeGen/should_run/cgrun032 -tests/codeGen/should_run/cgrun033 -tests/codeGen/should_run/cgrun034 -tests/codeGen/should_run/cgrun035 -tests/codeGen/should_run/cgrun036 -tests/codeGen/should_run/cgrun037 -tests/codeGen/should_run/cgrun038 -tests/codeGen/should_run/cgrun039 -tests/codeGen/should_run/cgrun040 -tests/codeGen/should_run/cgrun043 -tests/codeGen/should_run/cgrun044 -tests/codeGen/should_run/cgrun045 -tests/codeGen/should_run/cgrun046 -tests/codeGen/should_run/cgrun047 -tests/codeGen/should_run/cgrun048 -tests/codeGen/should_run/cgrun049 -tests/codeGen/should_run/cgrun050 -tests/codeGen/should_run/cgrun051 -tests/codeGen/should_run/cgrun052 -tests/codeGen/should_run/cgrun053 -tests/codeGen/should_run/cgrun054 -tests/codeGen/should_run/cgrun055 -tests/codeGen/should_run/cgrun056 -tests/codeGen/should_run/cgrun057 -tests/codeGen/should_run/cgrun058 -tests/codeGen/should_run/cgrun059 -tests/codeGen/should_run/cgrun060 -tests/codeGen/should_run/cgrun061 -tests/codeGen/should_run/cgrun062 -tests/codeGen/should_run/cgrun063 -tests/codeGen/should_run/cgrun064 -tests/codeGen/should_run/cgrun065 -tests/codeGen/should_run/cgrun066 -tests/codeGen/should_run/cgrun067 -tests/codeGen/should_run/cgrun068 -tests/codeGen/should_run/cgrun069 -tests/codeGen/should_run/cgrun070 -tests/codeGen/should_run/cgrun071 -tests/codeGen/should_run/setByteArray -tests/concurrent/prog001/concprog001 -tests/concurrent/prog002/concprog002 -tests/concurrent/prog002/concprog002.aux -tests/concurrent/prog002/concprog002.hp -tests/concurrent/prog002/concprog002.ps -tests/concurrent/prog003/concprog003 -tests/concurrent/should_run/1980 -tests/concurrent/should_run/2910 -tests/concurrent/should_run/2910a -tests/concurrent/should_run/3279 -tests/concurrent/should_run/3429 -tests/concurrent/should_run/367 -tests/concurrent/should_run/367_letnoescape -tests/concurrent/should_run/4030 -tests/concurrent/should_run/4811 -tests/concurrent/should_run/4813 -tests/concurrent/should_run/5238 -tests/concurrent/should_run/5421 -tests/concurrent/should_run/5558 -tests/concurrent/should_run/5611 -tests/concurrent/should_run/5866 -tests/concurrent/should_run/T1980 -tests/concurrent/should_run/T2910 -tests/concurrent/should_run/T2910a -tests/concurrent/should_run/T3279 -tests/concurrent/should_run/T3429 -tests/concurrent/should_run/T367 -tests/concurrent/should_run/T367_letnoescape -tests/concurrent/should_run/T4030 -tests/concurrent/should_run/T4811 -tests/concurrent/should_run/T4813 -tests/concurrent/should_run/T5238 -tests/concurrent/should_run/T5421 -tests/concurrent/should_run/T5558 -tests/concurrent/should_run/T5611 -tests/concurrent/should_run/T5866 -tests/concurrent/should_run/allowinterrupt001 -tests/concurrent/should_run/async001 -tests/concurrent/should_run/conc001 -tests/concurrent/should_run/conc002 -tests/concurrent/should_run/conc003 -tests/concurrent/should_run/conc004 -tests/concurrent/should_run/conc006 -tests/concurrent/should_run/conc007 -tests/concurrent/should_run/conc008 -tests/concurrent/should_run/conc009 -tests/concurrent/should_run/conc010 -tests/concurrent/should_run/conc012 -tests/concurrent/should_run/conc013 -tests/concurrent/should_run/conc014 -tests/concurrent/should_run/conc015 -tests/concurrent/should_run/conc015a -tests/concurrent/should_run/conc016 -tests/concurrent/should_run/conc017 -tests/concurrent/should_run/conc017a -tests/concurrent/should_run/conc018 -tests/concurrent/should_run/conc019 -tests/concurrent/should_run/conc020 -tests/concurrent/should_run/conc021 -tests/concurrent/should_run/conc022 -tests/concurrent/should_run/conc023 -tests/concurrent/should_run/conc024 -tests/concurrent/should_run/conc025 -tests/concurrent/should_run/conc026 -tests/concurrent/should_run/conc027 -tests/concurrent/should_run/conc028 -tests/concurrent/should_run/conc029 -tests/concurrent/should_run/conc030 -tests/concurrent/should_run/conc031 -tests/concurrent/should_run/conc032 -tests/concurrent/should_run/conc033 -tests/concurrent/should_run/conc034 -tests/concurrent/should_run/conc035 -tests/concurrent/should_run/conc036 -tests/concurrent/should_run/conc037 -tests/concurrent/should_run/conc038 -tests/concurrent/should_run/conc039 -tests/concurrent/should_run/conc040 -tests/concurrent/should_run/conc041 -tests/concurrent/should_run/conc042 -tests/concurrent/should_run/conc043 -tests/concurrent/should_run/conc044 -tests/concurrent/should_run/conc045 -tests/concurrent/should_run/conc051 -tests/concurrent/should_run/conc058 -tests/concurrent/should_run/conc059 -tests/concurrent/should_run/conc064 -tests/concurrent/should_run/conc065 -tests/concurrent/should_run/conc066 -tests/concurrent/should_run/conc067 -tests/concurrent/should_run/conc068 -tests/concurrent/should_run/conc069 -tests/concurrent/should_run/conc069a -tests/concurrent/should_run/conc070 -tests/concurrent/should_run/conc071 -tests/concurrent/should_run/conc072 -tests/concurrent/should_run/conc073 -tests/concurrent/should_run/foreignInterruptible -tests/concurrent/should_run/mask001 -tests/concurrent/should_run/mask002 -tests/concurrent/should_run/numsparks001 -tests/concurrent/should_run/throwto001 -tests/concurrent/should_run/throwto002 -tests/concurrent/should_run/throwto003 -tests/deSugar/should_run/DsLambdaCase -tests/deSugar/should_run/DsMultiWayIf -tests/deSugar/should_run/T246 -tests/deSugar/should_run/T3126 -tests/deSugar/should_run/T3382 -tests/deSugar/should_run/T5742 -tests/deSugar/should_run/dsrun001 -tests/deSugar/should_run/dsrun002 -tests/deSugar/should_run/dsrun003 -tests/deSugar/should_run/dsrun004 -tests/deSugar/should_run/dsrun005 -tests/deSugar/should_run/dsrun006 -tests/deSugar/should_run/dsrun007 -tests/deSugar/should_run/dsrun008 -tests/deSugar/should_run/dsrun009 -tests/deSugar/should_run/dsrun010 -tests/deSugar/should_run/dsrun011 -tests/deSugar/should_run/dsrun012 -tests/deSugar/should_run/dsrun013 -tests/deSugar/should_run/dsrun014 -tests/deSugar/should_run/dsrun015 -tests/deSugar/should_run/dsrun016 -tests/deSugar/should_run/dsrun017 -tests/deSugar/should_run/dsrun018 -tests/deSugar/should_run/dsrun019 -tests/deSugar/should_run/dsrun020 -tests/deSugar/should_run/dsrun021 -tests/deSugar/should_run/dsrun022 -tests/deSugar/should_run/dsrun023 -tests/deSugar/should_run/mc01 -tests/deSugar/should_run/mc02 -tests/deSugar/should_run/mc03 -tests/deSugar/should_run/mc04 -tests/deSugar/should_run/mc05 -tests/deSugar/should_run/mc06 -tests/deSugar/should_run/mc07 -tests/deSugar/should_run/mc08 -tests/deriving/should_run/T2529 -tests/deriving/should_run/T4136 -tests/deriving/should_run/T4528a -tests/deriving/should_run/T5041 -tests/deriving/should_run/T5628 -tests/deriving/should_run/T5712 -tests/deriving/should_run/T7931 -tests/deriving/should_run/drvrun-foldable1 -tests/deriving/should_run/drvrun-functor1 -tests/deriving/should_run/drvrun001 -tests/deriving/should_run/drvrun002 -tests/deriving/should_run/drvrun003 -tests/deriving/should_run/drvrun004 -tests/deriving/should_run/drvrun005 -tests/deriving/should_run/drvrun006 -tests/deriving/should_run/drvrun007 -tests/deriving/should_run/drvrun008 -tests/deriving/should_run/drvrun009 -tests/deriving/should_run/drvrun010 -tests/deriving/should_run/drvrun011 -tests/deriving/should_run/drvrun012 -tests/deriving/should_run/drvrun013 -tests/deriving/should_run/drvrun014 -tests/deriving/should_run/drvrun015 -tests/deriving/should_run/drvrun016 -tests/deriving/should_run/drvrun017 -tests/deriving/should_run/drvrun018 -tests/deriving/should_run/drvrun019 -tests/deriving/should_run/drvrun020 -tests/deriving/should_run/drvrun021 -tests/dph/classes/dph-classes-copy-fast -tests/dph/classes/dph-classes-fast -tests/dph/classes/dph-classes-vseg-fast -tests/dph/diophantine/dph-diophantine-copy-fast -tests/dph/diophantine/dph-diophantine-copy-opt -tests/dph/dotp/dph-dotp-copy-fast -tests/dph/dotp/dph-dotp-copy-opt -tests/dph/dotp/dph-dotp-opt -tests/dph/dotp/dph-dotp-vseg-fast -tests/dph/dotp/dph-dotp-vseg-opt -tests/dph/nbody/dph-nbody-copy-fast -tests/dph/nbody/dph-nbody-copy-opt -tests/dph/nbody/dph-nbody-vseg-fast -tests/dph/nbody/dph-nbody-vseg-opt -tests/dph/primespj/dph-primespj-copy-fast -tests/dph/primespj/dph-primespj-copy-opt -tests/dph/primespj/dph-primespj-opt -tests/dph/quickhull/dph-quickhull-copy-fast -tests/dph/quickhull/dph-quickhull-copy-opt -tests/dph/quickhull/dph-quickhull-opt -tests/dph/quickhull/dph-quickhull-vseg-fast -tests/dph/quickhull/dph-quickhull-vseg-opt -tests/dph/smvm/dph-smvm-copy -tests/dph/smvm/dph-smvm-vseg -tests/dph/sumnats/dph-sumnats-copy -tests/dph/sumnats/dph-sumnats-vseg -tests/dph/words/dph-words-copy-fast -tests/dph/words/dph-words-copy-opt -tests/dph/words/dph-words-opt -tests/dph/words/dph-words-vseg-fast -tests/dph/words/dph-words-vseg-opt -tests/driver/1959/E.hs -tests/driver/1959/prog -tests/driver/3674_pre -tests/driver/437/Test -tests/driver/437/Test2 -tests/driver/5313 -tests/driver/A012.ooo -tests/driver/A013.xhi -tests/driver/A061a.s -tests/driver/A061b.s -tests/driver/A064.hspp -tests/driver/A065.hspp -tests/driver/A066.tmp -tests/driver/A067.tmp -tests/driver/A070.s -tests/driver/A071.tmp -tests/driver/B022/C.ooo -tests/driver/B023/C.xhi -tests/driver/B024a/ -tests/driver/B062d/ -tests/driver/B062e/ -tests/driver/F018a.obj.018 -tests/driver/F018a_stub.obj.018 -tests/driver/Hello062a.hs -tests/driver/Hello062b.hs -tests/driver/Hello062c.hs -tests/driver/T1959/E.hs -tests/driver/T1959/prog -tests/driver/T3007/A/Setup -tests/driver/T3007/A/dist/ -tests/driver/T3007/B/Setup -tests/driver/T3007/B/dist/ -tests/driver/T3007/package.conf -tests/driver/T3389 -tests/driver/T3674_pre -tests/driver/T437/Test -tests/driver/T437/Test2 -tests/driver/T4437 -tests/driver/T5147/B.hs -tests/driver/T5198dump/ -tests/driver/T5313 -tests/driver/T5584/A.hi-boot -tests/driver/T5584_out/ -tests/driver/T706.hs -tests/driver/T7060dump/ -tests/driver/T7373/package.conf -tests/driver/T7373/pkg/Setup -tests/driver/T7373/pkg/dist/ -tests/driver/Test.081b -tests/driver/Test.081b.hs -tests/driver/Test_081a -tests/driver/Test_081a.hs -tests/driver/depend200 -tests/driver/dynHelloWorld -tests/driver/dynamicToo/A001.dyn_hi -tests/driver/dynamicToo/A001.dyn_o -tests/driver/dynamicToo/A002.dyn_hi -tests/driver/dynamicToo/A002.dyn_o -tests/driver/dynamicToo/A003.dyn_hi -tests/driver/dynamicToo/A003.dyn_o -tests/driver/dynamicToo/B001.dyn_hi -tests/driver/dynamicToo/B001.dyn_o -tests/driver/dynamicToo/B002.dyn_hi -tests/driver/dynamicToo/B002.dyn_o -tests/driver/dynamicToo/C001.dyn_hi -tests/driver/dynamicToo/C001.dyn_o -tests/driver/dynamicToo/C002.dyn_hi -tests/driver/dynamicToo/C002.dyn_o -tests/driver/dynamicToo/d001 -tests/driver/dynamicToo/s001 -tests/driver/dynamicToo/dynamicToo004/Setup -tests/driver/dynamicToo/dynamicToo004/local.package.conf/ -tests/driver/dynamicToo/dynamicToo004/pkg1/dist/ -tests/driver/dynamicToo/dynamicToo004/pkg1dyn/dist/ -tests/driver/dynamicToo/dynamicToo004/pkg2/dist/ -tests/driver/dynamicToo/dynamicToo004/progstatic -tests/indexed-types/should_fail/T8129.trace -tests/rts/T5435*_o -tests/rts/T5435*.so -tests/driver/dynamic_flags_001/C -tests/driver/hello062a -tests/driver/hello062b -tests/driver/hello062c -tests/driver/hello062d -tests/driver/hello062e -tests/driver/objc/objc-hi -tests/driver/objc/objcpp-hi -tests/driver/out019/ -tests/driver/recomp001/B.hs -tests/driver/recomp001/C -tests/driver/recomp003/Data/ -tests/driver/recomp003/err -tests/driver/recomp004/MainX -tests/driver/recomp004/MainX.hs -tests/driver/recomp004/c.c -tests/driver/recomp005/C.hs -tests/driver/recomp006/B.hs -tests/driver/recomp006/err -tests/driver/recomp006/out -tests/driver/recomp007/Setup -tests/driver/recomp007/a1/dist/ -tests/driver/recomp007/a2/dist/ -tests/driver/recomp007/b/dist/ -tests/driver/recomp007/local.package.conf/ -tests/driver/recomp008/A.hs -tests/driver/recomp008/prog -tests/driver/recomp010/Main -tests/driver/recomp010/X.hs -tests/driver/recomp011/A.hsinc -tests/driver/recomp011/B.hsinc -tests/driver/recomp011/Main -tests/driver/recomp012/Foo.hs -tests/driver/recomp012/Main -tests/driver/recomp012/Main.hs -tests/driver/recomp012/MyBool.hs -tests/driver/rtsOpts -tests/driver/rtsopts002 -tests/driver/spacesInArgs -tests/driver/stub017/ -tests/driver/stub028/ -tests/driver/stub035/ -tests/driver/stub045/ -tests/driver/withRtsOpts -tests/driver/withRtsOpts.out -tests/dynlibs/T3807-load -tests/dynlibs/T3807test.so -tests/dynlibs/T5373A -tests/dynlibs/T5373B -tests/dynlibs/T5373C -tests/dynlibs/T5373D -tests/ext-core/T7239.hcr -tests/ffi/should_run/.hpc/ -tests/ffi/should_run/1288 -tests/ffi/should_run/1679 -tests/ffi/should_run/2276 -tests/ffi/should_run/2469 -tests/ffi/should_run/2594 -tests/ffi/should_run/2917a -tests/ffi/should_run/4038 -tests/ffi/should_run/4221 -tests/ffi/should_run/5402 -tests/ffi/should_run/5594 -tests/ffi/should_run/7170 -tests/ffi/should_run/Capi_Ctype_001 -tests/ffi/should_run/Capi_Ctype_001.hs -tests/ffi/should_run/Capi_Ctype_002 -tests/ffi/should_run/Capi_Ctype_A_001.hs -tests/ffi/should_run/Capi_Ctype_A_002.hs -tests/ffi/should_run/T1288 -tests/ffi/should_run/T1679 -tests/ffi/should_run/T2276 -tests/ffi/should_run/T2469 -tests/ffi/should_run/T2594 -tests/ffi/should_run/T2917a -tests/ffi/should_run/T4012 -tests/ffi/should_run/T4038 -tests/ffi/should_run/T4221 -tests/ffi/should_run/T5402 -tests/ffi/should_run/T5594 -tests/ffi/should_run/T7170 -tests/ffi/should_run/capi_value -tests/ffi/should_run/fed001 -tests/ffi/should_run/ffi001 -tests/ffi/should_run/ffi002 -tests/ffi/should_run/ffi003 -tests/ffi/should_run/ffi005 -tests/ffi/should_run/ffi006 -tests/ffi/should_run/ffi007 -tests/ffi/should_run/ffi008 -tests/ffi/should_run/ffi009 -tests/ffi/should_run/ffi010 -tests/ffi/should_run/ffi011 -tests/ffi/should_run/ffi013 -tests/ffi/should_run/ffi014 -tests/ffi/should_run/ffi015 -tests/ffi/should_run/ffi016 -tests/ffi/should_run/ffi017 -tests/ffi/should_run/ffi018 -tests/ffi/should_run/ffi019 -tests/ffi/should_run/ffi020 -tests/ffi/should_run/ffi021 -tests/ffi/should_run/ffi022 -tests/ffi/should_run/ffi_parsing_001 -tests/ffi/should_run/fptr01 -tests/ffi/should_run/fptr02 -tests/ffi/should_run/fptrfail01 -tests/gadt/CasePrune -tests/gadt/Session -tests/gadt/gadt2 -tests/gadt/gadt23 -tests/gadt/gadt4 -tests/gadt/gadt5 -tests/gadt/records -tests/gadt/tc -tests/gadt/type-rep -tests/gadt/ubx-records -tests/gadt/while -tests/generics/GEq/GEq1 -tests/generics/GEq/GEq2 -tests/generics/GFunctor/GFunctor1 -tests/generics/GMap/GMap1 -tests/generics/GShow/GShow1 -tests/generics/GenNewtype -tests/generics/Uniplate/GUniplate1 -tests/ghc-api/T4891/T4891 -tests/ghc-api/T7478/A -tests/ghc-api/T7478/T7478 -tests/ghc-api/apirecomp001/myghc -tests/ghc-api/dynCompileExpr/dynCompileExpr -tests/ghc-api/ghcApi -tests/ghci.debugger/scripts/break022/A.hs -tests/ghci.debugger/scripts/break023/A.hs -tests/ghci/linking/dir001/ -tests/ghci/linking/dir002/ -tests/ghci/linking/dir004/ -tests/ghci/linking/dir005/ -tests/ghci/linking/dir006/ -tests/ghci/prog001/C.hs -tests/ghci/prog001/D.hs -tests/ghci/prog002/A.hs -tests/ghci/prog003/D.hs -tests/ghci/prog004/ctest.c -tests/ghci/prog005/A.hs -tests/ghci/prog006/Boot.hs -tests/ghci/prog009/A.hs -tests/ghci/prog012/Bar.hs -tests/ghci/scripts/Ghci058.hs -tests/ghci/scripts/T1914A.hs -tests/ghci/scripts/T1914B.hs -tests/ghci/scripts/T6106.hs -tests/ghci/scripts/T6106_preproc -tests/ghci/scripts/ghci027.hs -tests/ghci/should_run/3171.err -tests/hsc2hs/3837.hs -tests/hsc2hs/T3837.hs -tests/hsc2hs/hsc2hs001.hs -tests/hsc2hs/hsc2hs002.hs -tests/hsc2hs/hsc2hs003 -tests/hsc2hs/hsc2hs003.hs -tests/hsc2hs/hsc2hs004 -tests/hsc2hs/hsc2hs004.hs -tests/indexed-types/should_run/GMapAssoc -tests/indexed-types/should_run/GMapTop -tests/indexed-types/should_run/T2985 -tests/indexed-types/should_run/T4235 -tests/indexed-types/should_run/T5719 -tests/lib/Concurrent/4876 -tests/lib/Concurrent/ThreadDelay001 -tests/lib/Data.ByteString/bytestring002 -tests/lib/Data.ByteString/bytestring003 -tests/lib/Data.ByteString/bytestring006 -tests/lib/IO/2122 -tests/lib/IO/2122-test -tests/lib/IO/3307 -tests/lib/IO/4808 -tests/lib/IO/4808.test -tests/lib/IO/4855 -tests/lib/IO/4895 -tests/lib/IO/IOError001 -tests/lib/IO/IOError002 -tests/lib/IO/T4113 -tests/lib/IO/T4144 -tests/lib/IO/chinese-file-* -tests/lib/IO/chinese-name -tests/lib/IO/concio002 -tests/lib/IO/countReaders001 -tests/lib/IO/countReaders001.txt -tests/lib/IO/decodingerror001 -tests/lib/IO/decodingerror002 -tests/lib/IO/encoding001 -tests/lib/IO/encoding001.utf16 -tests/lib/IO/encoding001.utf16.utf16be -tests/lib/IO/encoding001.utf16.utf16le -tests/lib/IO/encoding001.utf16.utf32 -tests/lib/IO/encoding001.utf16.utf32be -tests/lib/IO/encoding001.utf16.utf32le -tests/lib/IO/encoding001.utf16.utf8 -tests/lib/IO/encoding001.utf16.utf8_bom -tests/lib/IO/encoding001.utf16be -tests/lib/IO/encoding001.utf16be.utf16 -tests/lib/IO/encoding001.utf16be.utf16le -tests/lib/IO/encoding001.utf16be.utf32 -tests/lib/IO/encoding001.utf16be.utf32be -tests/lib/IO/encoding001.utf16be.utf32le -tests/lib/IO/encoding001.utf16be.utf8 -tests/lib/IO/encoding001.utf16be.utf8_bom -tests/lib/IO/encoding001.utf16le -tests/lib/IO/encoding001.utf16le.utf16 -tests/lib/IO/encoding001.utf16le.utf16be -tests/lib/IO/encoding001.utf16le.utf32 -tests/lib/IO/encoding001.utf16le.utf32be -tests/lib/IO/encoding001.utf16le.utf32le -tests/lib/IO/encoding001.utf16le.utf8 -tests/lib/IO/encoding001.utf16le.utf8_bom -tests/lib/IO/encoding001.utf32 -tests/lib/IO/encoding001.utf32.utf16 -tests/lib/IO/encoding001.utf32.utf16be -tests/lib/IO/encoding001.utf32.utf16le -tests/lib/IO/encoding001.utf32.utf32be -tests/lib/IO/encoding001.utf32.utf32le -tests/lib/IO/encoding001.utf32.utf8 -tests/lib/IO/encoding001.utf32.utf8_bom -tests/lib/IO/encoding001.utf32be -tests/lib/IO/encoding001.utf32be.utf16 -tests/lib/IO/encoding001.utf32be.utf16be -tests/lib/IO/encoding001.utf32be.utf16le -tests/lib/IO/encoding001.utf32be.utf32 -tests/lib/IO/encoding001.utf32be.utf32le -tests/lib/IO/encoding001.utf32be.utf8 -tests/lib/IO/encoding001.utf32be.utf8_bom -tests/lib/IO/encoding001.utf32le -tests/lib/IO/encoding001.utf32le.utf16 -tests/lib/IO/encoding001.utf32le.utf16be -tests/lib/IO/encoding001.utf32le.utf16le -tests/lib/IO/encoding001.utf32le.utf32 -tests/lib/IO/encoding001.utf32le.utf32be -tests/lib/IO/encoding001.utf32le.utf8 -tests/lib/IO/encoding001.utf32le.utf8_bom -tests/lib/IO/encoding001.utf8 -tests/lib/IO/encoding001.utf8.utf16 -tests/lib/IO/encoding001.utf8.utf16be -tests/lib/IO/encoding001.utf8.utf16le -tests/lib/IO/encoding001.utf8.utf32 -tests/lib/IO/encoding001.utf8.utf32be -tests/lib/IO/encoding001.utf8.utf32le -tests/lib/IO/encoding001.utf8.utf8_bom -tests/lib/IO/encoding001.utf8_bom -tests/lib/IO/encoding001.utf8_bom.utf16 -tests/lib/IO/encoding001.utf8_bom.utf16be -tests/lib/IO/encoding001.utf8_bom.utf16le -tests/lib/IO/encoding001.utf8_bom.utf32 -tests/lib/IO/encoding001.utf8_bom.utf32be -tests/lib/IO/encoding001.utf8_bom.utf32le -tests/lib/IO/encoding001.utf8_bom.utf8 -tests/lib/IO/encoding002 -tests/lib/IO/encodingerror001 -tests/lib/IO/environment001 -tests/lib/IO/finalization001 -tests/lib/IO/hClose001 -tests/lib/IO/hClose001.tmp -tests/lib/IO/hClose002 -tests/lib/IO/hClose002.tmp -tests/lib/IO/hClose003 -tests/lib/IO/hDuplicateTo001 -tests/lib/IO/hFileSize001 -tests/lib/IO/hFileSize002 -tests/lib/IO/hFileSize002.out -tests/lib/IO/hFlush001 -tests/lib/IO/hFlush001.out -tests/lib/IO/hGetBuf001 -tests/lib/IO/hGetBuffering001 -tests/lib/IO/hGetChar001 -tests/lib/IO/hGetLine001 -tests/lib/IO/hGetLine002 -tests/lib/IO/hGetLine003 -tests/lib/IO/hGetPosn001 -tests/lib/IO/hGetPosn001.out -tests/lib/IO/hIsEOF001 -tests/lib/IO/hIsEOF002 -tests/lib/IO/hIsEOF002.out -tests/lib/IO/hReady001 -tests/lib/IO/hReady002 -tests/lib/IO/hSeek001 -tests/lib/IO/hSeek002 -tests/lib/IO/hSeek003 -tests/lib/IO/hSeek004 -tests/lib/IO/hSeek004.out -tests/lib/IO/hSetBuffering002 -tests/lib/IO/hSetBuffering003 -tests/lib/IO/hSetBuffering004 -tests/lib/IO/hSetEncoding001 -tests/lib/IO/ioeGetErrorString001 -tests/lib/IO/ioeGetFileName001 -tests/lib/IO/ioeGetHandle001 -tests/lib/IO/isEOF001 -tests/lib/IO/misc001 -tests/lib/IO/misc001.out -tests/lib/IO/newline001 -tests/lib/IO/newline001.out -tests/lib/IO/openFile001 -tests/lib/IO/openFile002 -tests/lib/IO/openFile003 -tests/lib/IO/openFile004 -tests/lib/IO/openFile004.out -tests/lib/IO/openFile005 -tests/lib/IO/openFile005.out1 -tests/lib/IO/openFile005.out2 -tests/lib/IO/openFile006 -tests/lib/IO/openFile006.out -tests/lib/IO/openFile007 -tests/lib/IO/openFile007.out -tests/lib/IO/openFile008 -tests/lib/IO/openTempFile001 -tests/lib/IO/putStr001 -tests/lib/IO/readFile001 -tests/lib/IO/readFile001.out -tests/lib/IO/readwrite001 -tests/lib/IO/readwrite001.inout -tests/lib/IO/readwrite002 -tests/lib/IO/readwrite002.inout -tests/lib/IO/readwrite003 -tests/lib/IO/readwrite003.txt -tests/lib/IO/tmp -tests/lib/IOExts/echo001 -tests/lib/IOExts/hGetBuf002 -tests/lib/IOExts/hGetBuf003 -tests/lib/IOExts/hPutBuf001 -tests/lib/IOExts/hPutBuf002 -tests/lib/IOExts/hPutBuf002.out -tests/lib/IOExts/hTell001 -tests/lib/IOExts/hTell002 -tests/lib/IOExts/performGC001 -tests/lib/IOExts/trace001 -tests/lib/IORef/ -tests/lib/Numeric/ -tests/lib/OldException/OldException001 -tests/lib/PrettyPrint/T3911 -tests/lib/PrettyPrint/pp1 -tests/lib/Text.Printf/1548 -tests/lib/Time/T5430 -tests/lib/Time/time002 -tests/lib/Time/time003 -tests/lib/Time/time004 -tests/lib/exceptions/exceptions001 -tests/lib/integer/IntegerConversionRules.simpl -tests/lib/integer/fromToInteger.simpl -tests/lib/integer/gcdInteger -tests/lib/integer/integerBits -tests/lib/integer/integerConstantFolding -tests/lib/integer/integerConstantFolding.simpl -tests/lib/integer/integerConversions -tests/lib/integer/integerGmpInternals -tests/lib/libposix/po003.out -tests/lib/libposix/posix002 -tests/lib/libposix/posix003 -tests/lib/libposix/posix004 -tests/lib/libposix/posix006 -tests/lib/libposix/posix009 -tests/lib/libposix/posix010 -tests/lib/libposix/posix014 -tests/lib/should_run/4006 -tests/lib/should_run/addr001 -tests/lib/should_run/array001 -tests/lib/should_run/array001.data -tests/lib/should_run/char001 -tests/lib/should_run/char002 -tests/lib/should_run/cstring001 -tests/lib/should_run/dynamic001 -tests/lib/should_run/dynamic002 -tests/lib/should_run/dynamic003 -tests/lib/should_run/dynamic004 -tests/lib/should_run/dynamic005 -tests/lib/should_run/enum01 -tests/lib/should_run/enum02 -tests/lib/should_run/enum03 -tests/lib/should_run/enum04 -tests/lib/should_run/exceptionsrun001 -tests/lib/should_run/exceptionsrun002 -tests/lib/should_run/length001 -tests/lib/should_run/list001 -tests/lib/should_run/list002 -tests/lib/should_run/list003 -tests/lib/should_run/memo001 -tests/lib/should_run/memo002 -tests/lib/should_run/rand001 -tests/lib/should_run/ratio001 -tests/lib/should_run/reads001 -tests/lib/should_run/show001 -tests/lib/should_run/stableptr001 -tests/lib/should_run/stableptr003 -tests/lib/should_run/stableptr004 -tests/lib/should_run/stableptr005 -tests/lib/should_run/text001 -tests/lib/should_run/tup001 -tests/lib/should_run/weak001 -tests/mdo/should_compile/mdo001 -tests/mdo/should_compile/mdo002 -tests/mdo/should_compile/mdo003 -tests/mdo/should_compile/mdo004 -tests/mdo/should_compile/mdo005 -tests/mdo/should_fail/mdofail006 -tests/mdo/should_run/mdorun001 -tests/mdo/should_run/mdorun002 -tests/mdo/should_run/mdorun003 -tests/mdo/should_run/mdorun004 -tests/mdo/should_run/mdorun005 -tests/module/Mod145_A.mod146_hi -tests/module/Mod145_A.mod146_o -tests/module/Mod157_A.mod158_hi -tests/module/Mod157_A.mod158_o -tests/module/Mod157_B.mod158_hi -tests/module/Mod157_B.mod158_o -tests/module/Mod157_C.mod158_hi -tests/module/Mod157_C.mod158_o -tests/module/Mod157_D.mod158_hi -tests/module/Mod157_D.mod158_o -tests/module/Mod159_A.mod160_hi -tests/module/Mod159_A.mod160_o -tests/module/Mod159_B.mod160_hi -tests/module/Mod159_B.mod160_o -tests/module/Mod159_C.mod160_hi -tests/module/Mod159_C.mod160_o -tests/module/Mod159_D.mod160_hi -tests/module/Mod159_D.mod160_o -tests/module/Mod164_A.mod165_hi -tests/module/Mod164_A.mod165_o -tests/module/Mod164_A.mod166_hi -tests/module/Mod164_A.mod166_o -tests/module/Mod164_A.mod167_hi -tests/module/Mod164_A.mod167_o -tests/module/Mod164_B.mod165_hi -tests/module/Mod164_B.mod165_o -tests/module/Mod164_B.mod166_hi -tests/module/Mod164_B.mod166_o -tests/module/Mod164_B.mod167_hi -tests/module/Mod164_B.mod167_o -tests/module/mod166.mod166_hi -tests/module/mod166.mod166_o -tests/module/mod167.mod167_hi -tests/module/mod167.mod167_o -tests/module/mod175/test -tests/module/mod175/test2 -tests/module/mod179 -tests/numeric/should_run/3676 -tests/numeric/should_run/4381 -tests/numeric/should_run/4383 -tests/numeric/should_run/T3676 -tests/numeric/should_run/T4381 -tests/numeric/should_run/T4383 -tests/numeric/should_run/T5863 -tests/numeric/should_run/T7014 -tests/numeric/should_run/T7014.simpl -tests/numeric/should_run/T7233 -tests/numeric/should_run/T7689 -tests/numeric/should_run/add2 -tests/numeric/should_run/arith001 -tests/numeric/should_run/arith002 -tests/numeric/should_run/arith003 -tests/numeric/should_run/arith004 -tests/numeric/should_run/arith005 -tests/numeric/should_run/arith006 -tests/numeric/should_run/arith007 -tests/numeric/should_run/arith008 -tests/numeric/should_run/arith009 -tests/numeric/should_run/arith010 -tests/numeric/should_run/arith011 -tests/numeric/should_run/arith012 -tests/numeric/should_run/arith013 -tests/numeric/should_run/arith014 -tests/numeric/should_run/arith015 -tests/numeric/should_run/arith016 -tests/numeric/should_run/arith017 -tests/numeric/should_run/arith018 -tests/numeric/should_run/arith019 -tests/numeric/should_run/expfloat -tests/numeric/should_run/mul2 -tests/numeric/should_run/numrun009 -tests/numeric/should_run/numrun010 -tests/numeric/should_run/numrun011 -tests/numeric/should_run/numrun012 -tests/numeric/should_run/numrun013 -tests/numeric/should_run/numrun014 -tests/numeric/should_run/quotRem2 -tests/optasm-log -tests/optllvm-32-log -tests/optllvm-log -tests/overloadedlists/should_run/overloadedlistsrun01 -tests/overloadedlists/should_run/overloadedlistsrun02 -tests/overloadedlists/should_run/overloadedlistsrun03 -tests/overloadedlists/should_run/overloadedlistsrun04 -tests/overloadedlists/should_run/overloadedlistsrun05 -tests/parser/should_compile/T5243 -tests/parser/should_compile/T7476/Main.imports -tests/parser/should_compile/T7476/T7476 -tests/parser/should_run/BinaryLiterals0 -tests/parser/should_run/BinaryLiterals1 -tests/parser/should_run/BinaryLiterals2 -tests/parser/should_run/ParserMultiWayIf -tests/parser/should_run/T1344 -tests/parser/should_run/operator -tests/parser/should_run/operator2 -tests/parser/should_run/readRun001 -tests/parser/should_run/readRun002 -tests/parser/should_run/readRun003 -tests/parser/should_run/readRun004 -tests/parser/unicode/1744 -tests/parser/unicode/T1744 -tests/parser/unicode/utf8_024 -tests/perf/compiler/T1969.comp.stats -tests/perf/compiler/T3064.comp.stats -tests/perf/compiler/T3294.comp.stats -tests/perf/compiler/T4801.comp.stats -tests/perf/compiler/T5030.comp.stats -tests/perf/compiler/T5321FD.comp.stats -tests/perf/compiler/T5321Fun.comp.stats -tests/perf/compiler/T5631.comp.stats -tests/perf/compiler/T5642.comp.stats -tests/perf/compiler/T5837.comp.stats -tests/perf/compiler/T6048.comp.stats -tests/perf/compiler/T783.comp.stats -tests/perf/compiler/parsing001.comp.stats -tests/perf/should_run/3586 -tests/perf/should_run/3586.stats -tests/perf/should_run/Conversions -tests/perf/should_run/Conversions.stats -tests/perf/should_run/MethSharing -tests/perf/should_run/MethSharing.stats -tests/perf/should_run/T149_A -tests/perf/should_run/T149_B -tests/perf/should_run/T2902_A -tests/perf/should_run/T2902_B -tests/perf/should_run/T3245 -tests/perf/should_run/T3586 -tests/perf/should_run/T3736 -tests/perf/should_run/T3736.speed.f32 -tests/perf/should_run/T3738 -tests/perf/should_run/T3738.stats -tests/perf/should_run/T4321 -tests/perf/should_run/T4474a -tests/perf/should_run/T4474a.stats -tests/perf/should_run/T4474b -tests/perf/should_run/T4474b.stats -tests/perf/should_run/T4474c -tests/perf/should_run/T4474c.stats -tests/perf/should_run/T4830 -tests/perf/should_run/T4830.stats -tests/perf/should_run/T4978 -tests/perf/should_run/T4978.stats -tests/perf/should_run/T5113 -tests/perf/should_run/T5113.stats -tests/perf/should_run/T5205 -tests/perf/should_run/T5205.stats -tests/perf/should_run/T5237 -tests/perf/should_run/T5237.stats -tests/perf/should_run/T5536 -tests/perf/should_run/T5536.data -tests/perf/should_run/T5536.stats -tests/perf/should_run/T5549 -tests/perf/should_run/T5549.stats -tests/perf/should_run/T7257 -tests/perf/should_run/T7257.stats -tests/perf/should_run/T7436 -tests/perf/should_run/T7436.stats -tests/perf/should_run/T7507 -tests/perf/should_run/T7797 -tests/perf/should_run/T876 -tests/perf/should_run/lazy-bs-alloc -tests/perf/should_run/lazy-bs-alloc.stats -tests/perf/should_run/speed.f32 -tests/perf/space_leaks/T2762 -tests/perf/space_leaks/T2762.stats -tests/perf/space_leaks/T4018 -tests/perf/space_leaks/T4334 -tests/perf/space_leaks/T4334.stats -tests/perf/space_leaks/space_leak_001 -tests/perf/space_leaks/space_leak_001.stats -tests/plugins/plugins01 -tests/plugins/plugins05 -tests/plugins/plugins06 -tests/plugins/simple-plugin/pkg.plugins01/ -tests/plugins/simple-plugin/pkg.plugins02/ -tests/plugins/simple-plugin/pkg.plugins03/ -tests/polykinds/Freeman -tests/polykinds/MonoidsFD -tests/polykinds/MonoidsTF -tests/polykinds/PolyKinds09 -tests/polykinds/PolyKinds10 -tests/profiling/should_compile/prof001 -tests/profiling/should_compile/prof002 -tests/profiling/should_run/2592 -tests/profiling/should_run/2592.aux -tests/profiling/should_run/2592.hp -tests/profiling/should_run/2592.ps -tests/profiling/should_run/5314 -tests/profiling/should_run/5314.hp -tests/profiling/should_run/5314.ps -tests/profiling/should_run/T2552 -tests/profiling/should_run/T2592 -tests/profiling/should_run/T3001 -tests/profiling/should_run/T3001-2 -tests/profiling/should_run/T3001-2.hp -tests/profiling/should_run/T3001-2.ps -tests/profiling/should_run/T3001.hp -tests/profiling/should_run/T3001.ps -tests/profiling/should_run/T5314 -tests/profiling/should_run/T5363 -tests/profiling/should_run/T5559 -tests/profiling/should_run/T680 -tests/profiling/should_run/T949 -tests/profiling/should_run/T949.hp -tests/profiling/should_run/T949.ps -tests/profiling/should_run/callstack001 -tests/profiling/should_run/callstack002 -tests/profiling/should_run/heapprof001 -tests/profiling/should_run/heapprof001.hp -tests/profiling/should_run/heapprof001.ps -tests/profiling/should_run/ioprof -tests/profiling/should_run/prof-doc-fib -tests/profiling/should_run/prof-doc-last -tests/profiling/should_run/profinline001 -tests/profiling/should_run/scc001 -tests/profiling/should_run/scc002 -tests/profiling/should_run/scc003 -tests/profiling/should_run/scc004 -tests/profiling/should_run/test.bin -tests/programs/10queens/10queens -tests/programs/Queens/queens -tests/programs/andre_monad/andre_monad -tests/programs/andy_cherry/andy_cherry -tests/programs/barton-mangler-bug/barton-mangler-bug -tests/programs/cholewo-eval/cholewo-eval -tests/programs/cvh_unboxing/cvh_unboxing -tests/programs/fast2haskell/fast2haskell -tests/programs/fun_insts/fun_insts -tests/programs/jl_defaults/jl_defaults -tests/programs/joao-circular/joao-circular -tests/programs/jq_readsPrec/jq_readsPrec -tests/programs/jtod_circint/jtod_circint -tests/programs/jules_xref/jules_xref -tests/programs/jules_xref2/jules_xref2 -tests/programs/launchbury/launchbury -tests/programs/lennart_range/lennart_range -tests/programs/lex/lex -tests/programs/life_space_leak/life_space_leak -tests/programs/north_array/north_array -tests/programs/record_upd/record_upd -tests/programs/rittri/rittri -tests/programs/sanders_array/sanders_array -tests/programs/seward-space-leak/seward-space-leak -tests/programs/strict_anns/strict_anns -tests/programs/thurston-modular-arith/thurston-modular-arith -tests/quasiquotation/T4491/T4491 -tests/rebindable/T5038 -tests/rebindable/rebindable10 -tests/rebindable/rebindable2 -tests/rebindable/rebindable3 -tests/rebindable/rebindable4 -tests/rebindable/rebindable5 -tests/rebindable/rebindable7 -tests/rename/prog006/local.package.conf -tests/rename/prog006/pkg.conf -tests/rename/prog006/pwd -tests/rename/should_compile/T1792_imports.imports -tests/rename/should_compile/T4239.imports -tests/rename/should_compile/T4240.imports -tests/rename/should_compile/T5592 -tests/rts/2047 -tests/rts/2783 -tests/rts/3236 -tests/rts/3424 -tests/rts/4059 -tests/rts/4850 -tests/rts/5250 -tests/rts/5644/5644 -tests/rts/5993 -tests/rts/7087 -tests/rts/T2047 -tests/rts/T2615 -tests/rts/T2783 -tests/rts/T3236 -tests/rts/T4059 -tests/rts/T4850 -tests/rts/T5250 -tests/rts/T5423 -tests/rts/T5644/T5644 -tests/rts/T5993 -tests/rts/T6006 -tests/rts/T7037 -tests/rts/T7037_main -tests/rts/T7040 -tests/rts/T7087 -tests/rts/T7160 -tests/rts/T7227 -tests/rts/T7227.stat -tests/rts/T7636 -tests/rts/T7815 -tests/rts/atomicinc -tests/rts/bug1010 -tests/rts/derefnull -tests/rts/divbyzero -tests/rts/exec_signals -tests/rts/exec_signals_child -tests/rts/exec_signals_prepare -tests/rts/ffishutdown -tests/rts/libfoo_T2615.so -tests/rts/outofmem -tests/rts/outofmem2 -tests/rts/prep.out -tests/rts/return_mem_to_os -tests/rts/rtsflags001 -tests/rts/rtsflags002 -tests/rts/stablename001 -tests/rts/stack001 -tests/rts/stack002 -tests/rts/stack003 -tests/rts/testblockalloc -tests/rts/testwsdeque -tests/rts/traceEvent -tests/safeHaskell/check/Check04 -tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly01/ -tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly02/ -tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly03/ -tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly04/ -tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly05/ -tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly06/ -tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly07/ -tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly08/ -tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly09/ -tests/safeHaskell/check/pkg01/pdb.ImpSafeOnly10/ -tests/safeHaskell/check/pkg01/pdb.safePkg01/ -tests/safeHaskell/safeLanguage/SafeLang04 -tests/safeHaskell/safeLanguage/SafeLang05 -tests/safeHaskell/safeLanguage/SafeLang06 -tests/safeHaskell/safeLanguage/SafeLang09 -tests/safeHaskell/safeLanguage/SafeLang11 -tests/safeHaskell/safeLanguage/SafeLang13 -tests/safeHaskell/safeLanguage/SafeLang15 -tests/safeHaskell/unsafeLibs/BadImport02 -tests/simplCore/should_compile/T3055.simpl -tests/simplCore/should_compile/T4138.simpl -tests/simplCore/should_compile/T7702plugin/pkg.T7702/ -tests/simplCore/should_compile/T7796.prep -tests/simplCore/should_run/SeqRule -tests/simplCore/should_run/T2756 -tests/simplCore/should_run/T3403 -tests/simplCore/should_run/T3437 -tests/simplCore/should_run/T3591 -tests/simplCore/should_run/T3959 -tests/simplCore/should_run/T3972 -tests/simplCore/should_run/T3983 -tests/simplCore/should_run/T4814 -tests/simplCore/should_run/T5315 -tests/simplCore/should_run/T5441 -tests/simplCore/should_run/T5453 -tests/simplCore/should_run/T5587 -tests/simplCore/should_run/T5603 -tests/simplCore/should_run/T5625 -tests/simplCore/should_run/T5915 -tests/simplCore/should_run/T5920 -tests/simplCore/should_run/T5997 -tests/simplCore/should_run/T7101 -tests/simplCore/should_run/T7924 -tests/simplCore/should_run/simplrun001 -tests/simplCore/should_run/simplrun002 -tests/simplCore/should_run/simplrun003 -tests/simplCore/should_run/simplrun004 -tests/simplCore/should_run/simplrun005 -tests/simplCore/should_run/simplrun007 -tests/simplCore/should_run/simplrun008 -tests/simplCore/should_run/simplrun009 -tests/simplCore/should_run/simplrun010 -tests/stranal/should_run/T2756b -tests/stranal/should_run/T7649 -tests/stranal/should_run/strun001 -tests/stranal/should_run/strun002 -tests/stranal/should_run/strun003 -tests/stranal/should_run/strun004 -tests/th/T1835 -tests/th/T3572 -tests/th/T3920 -tests/th/T5379 -tests/th/T5410 -tests/th/T5555 -tests/th/T7064 -tests/th/T7910 -tests/th/TH_Depends -tests/th/TH_Depends_external.txt -tests/th/TH_StringPrimL -tests/th/TH_import_loop/ModuleA.hi-boot -tests/th/TH_import_loop/ModuleA.o-boot -tests/th/TH_lookupName -tests/th/TH_ppr1 -tests/th/TH_recover -tests/th/TH_repE2 -tests/th/TH_repGuardOutput -tests/th/TH_repPrimOutput -tests/th/TH_repPrimOutput2 -tests/th/TH_spliceE1 -tests/th/TH_spliceE4 -tests/th/TH_spliceE5 -tests/th/TH_spliceE5_prof -tests/th/TH_spliceViewPat/TH_spliceViewPat -tests/th/TH_unresolvedInfix -tests/th/TH_viewPatPrint -tests/th/TH_where -tests/typecheck/should_compile/tc159 -tests/typecheck/should_fail/T3468.o-boot -tests/typecheck/should_fail/tcfail149 -tests/typecheck/should_run/Defer01 -tests/typecheck/should_run/IPRun -tests/typecheck/should_run/T1624 -tests/typecheck/should_run/T1735 -tests/typecheck/should_run/T2722 -tests/typecheck/should_run/T3500a -tests/typecheck/should_run/T3500b -tests/typecheck/should_run/T3731 -tests/typecheck/should_run/T3731-short -tests/typecheck/should_run/T4809 -tests/typecheck/should_run/T5573a -tests/typecheck/should_run/T5573b -tests/typecheck/should_run/T5751 -tests/typecheck/should_run/T5759 -tests/typecheck/should_run/T5913 -tests/typecheck/should_run/T6117 -tests/typecheck/should_run/T7023 -tests/typecheck/should_run/T7126 -tests/typecheck/should_run/T7748 -tests/typecheck/should_run/T7861 -tests/typecheck/should_run/TcNullaryTC -tests/typecheck/should_run/church -tests/typecheck/should_run/mc17 -tests/typecheck/should_run/tcrun001 -tests/typecheck/should_run/tcrun002 -tests/typecheck/should_run/tcrun003 -tests/typecheck/should_run/tcrun004 -tests/typecheck/should_run/tcrun005 -tests/typecheck/should_run/tcrun006 -tests/typecheck/should_run/tcrun008 -tests/typecheck/should_run/tcrun009 -tests/typecheck/should_run/tcrun010 -tests/typecheck/should_run/tcrun011 -tests/typecheck/should_run/tcrun012 -tests/typecheck/should_run/tcrun013 -tests/typecheck/should_run/tcrun014 -tests/typecheck/should_run/tcrun015 -tests/typecheck/should_run/tcrun016 -tests/typecheck/should_run/tcrun017 -tests/typecheck/should_run/tcrun018 -tests/typecheck/should_run/tcrun019 -tests/typecheck/should_run/tcrun020 -tests/typecheck/should_run/tcrun021 -tests/typecheck/should_run/tcrun022 -tests/typecheck/should_run/tcrun023 -tests/typecheck/should_run/tcrun024 -tests/typecheck/should_run/tcrun025 -tests/typecheck/should_run/tcrun026 -tests/typecheck/should_run/tcrun027 -tests/typecheck/should_run/tcrun028 -tests/typecheck/should_run/tcrun029 -tests/typecheck/should_run/tcrun030 -tests/typecheck/should_run/tcrun031 -tests/typecheck/should_run/tcrun032 -tests/typecheck/should_run/tcrun033 -tests/typecheck/should_run/tcrun034 -tests/typecheck/should_run/tcrun036 -tests/typecheck/should_run/tcrun037 -tests/typecheck/should_run/tcrun038 -tests/typecheck/should_run/tcrun039 -tests/typecheck/should_run/tcrun040 -tests/typecheck/should_run/tcrun041 -tests/typecheck/should_run/tcrun042 -tests/typecheck/should_run/tcrun043 -tests/typecheck/should_run/tcrun044 -tests/typecheck/should_run/tcrun045 -tests/typecheck/should_run/tcrun046 -tests/typecheck/should_run/tcrun047 -tests/typecheck/should_run/tcrun048 -tests/typecheck/should_run/tcrun049 -tests/typecheck/should_run/tcrun050 -tests/typecheck/should_run/tcrun051 -tests/typecheck/should_run/testeq2 -tests/typecheck/testeq1/typecheck.testeq1 -timeout/calibrate.out -timeout/dist/ -timeout/install-inplace/ +/tests/safeHaskell/safeLanguage/SafeLang04 +/tests/safeHaskell/safeLanguage/SafeLang05 +/tests/safeHaskell/safeLanguage/SafeLang06 +/tests/safeHaskell/safeLanguage/SafeLang09 +/tests/safeHaskell/safeLanguage/SafeLang11 +/tests/safeHaskell/safeLanguage/SafeLang13 +/tests/safeHaskell/safeLanguage/SafeLang15 +/tests/safeHaskell/unsafeLibs/BadImport02 +/tests/simplCore/should_compile/T3055.simpl +/tests/simplCore/should_compile/T4138.simpl +/tests/simplCore/should_compile/T7702plugin/pkg.T7702/ +/tests/simplCore/should_compile/T7796.prep +/tests/simplCore/should_run/SeqRule +/tests/simplCore/should_run/T2110 +/tests/simplCore/should_run/T2756 +/tests/simplCore/should_run/T3403 +/tests/simplCore/should_run/T3437 +/tests/simplCore/should_run/T3591 +/tests/simplCore/should_run/T3959 +/tests/simplCore/should_run/T3972 +/tests/simplCore/should_run/T3983 +/tests/simplCore/should_run/T457 +/tests/simplCore/should_run/T4814 +/tests/simplCore/should_run/T5315 +/tests/simplCore/should_run/T5441 +/tests/simplCore/should_run/T5453 +/tests/simplCore/should_run/T5587 +/tests/simplCore/should_run/T5603 +/tests/simplCore/should_run/T5625 +/tests/simplCore/should_run/T5915 +/tests/simplCore/should_run/T5920 +/tests/simplCore/should_run/T5997 +/tests/simplCore/should_run/T7101 +/tests/simplCore/should_run/T7924 +/tests/simplCore/should_run/T9128 +/tests/simplCore/should_run/runST +/tests/simplCore/should_run/simplrun001 +/tests/simplCore/should_run/simplrun002 +/tests/simplCore/should_run/simplrun003 +/tests/simplCore/should_run/simplrun004 +/tests/simplCore/should_run/simplrun005 +/tests/simplCore/should_run/simplrun007 +/tests/simplCore/should_run/simplrun008 +/tests/simplCore/should_run/simplrun009 +/tests/simplCore/should_run/simplrun010 +/tests/simplCore/should_run/simplrun011 +/tests/stranal/should_run/T2756b +/tests/stranal/should_run/T7649 +/tests/stranal/should_run/T8425/T8425 +/tests/stranal/should_run/T9254 +/tests/stranal/should_run/strun001 +/tests/stranal/should_run/strun002 +/tests/stranal/should_run/strun003 +/tests/stranal/should_run/strun004 +/tests/th/T1835 +/tests/th/T3572 +/tests/th/T3920 +/tests/th/T5379 +/tests/th/T5410 +/tests/th/T5555 +/tests/th/T7064 +/tests/th/T7910 +/tests/th/T8186 +/tests/th/T8633 +/tests/th/TH_Depends +/tests/th/TH_Depends_external.txt +/tests/th/TH_StringPrimL +/tests/th/TH_import_loop/ModuleA.hi-boot +/tests/th/TH_import_loop/ModuleA.o-boot +/tests/th/TH_lookupName +/tests/th/TH_ppr1 +/tests/th/TH_recover +/tests/th/TH_repE2 +/tests/th/TH_repGuardOutput +/tests/th/TH_repPrimOutput +/tests/th/TH_repPrimOutput2 +/tests/th/TH_spliceE1 +/tests/th/TH_spliceE4 +/tests/th/TH_spliceE5 +/tests/th/TH_spliceE5_prof +/tests/th/TH_spliceViewPat/TH_spliceViewPat +/tests/th/TH_unresolvedInfix +/tests/th/TH_viewPatPrint +/tests/th/TH_where +/tests/typecheck/should_compile/tc159 +/tests/typecheck/should_compile/tc263 +/tests/typecheck/should_fail/T3468.o-boot +/tests/typecheck/should_fail/tcfail149 +/tests/typecheck/should_run/Defer01 +/tests/typecheck/should_run/IPRun +/tests/typecheck/should_run/T1624 +/tests/typecheck/should_run/T1735 +/tests/typecheck/should_run/T2722 +/tests/typecheck/should_run/T3500a +/tests/typecheck/should_run/T3500b +/tests/typecheck/should_run/T3731 +/tests/typecheck/should_run/T3731-short +/tests/typecheck/should_run/T4809 +/tests/typecheck/should_run/T5573a +/tests/typecheck/should_run/T5573b +/tests/typecheck/should_run/T5751 +/tests/typecheck/should_run/T5759 +/tests/typecheck/should_run/T5913 +/tests/typecheck/should_run/T6117 +/tests/typecheck/should_run/T7023 +/tests/typecheck/should_run/T7126 +/tests/typecheck/should_run/T7748 +/tests/typecheck/should_run/T7861 +/tests/typecheck/should_run/T8492 +/tests/typecheck/should_run/T8739 +/tests/typecheck/should_run/TcCoercible +/tests/typecheck/should_run/TcNullaryTC +/tests/typecheck/should_run/TcTypeNatSimpleRun +/tests/typecheck/should_run/church +/tests/typecheck/should_run/mc17 +/tests/typecheck/should_run/tcrun001 +/tests/typecheck/should_run/tcrun002 +/tests/typecheck/should_run/tcrun003 +/tests/typecheck/should_run/tcrun004 +/tests/typecheck/should_run/tcrun005 +/tests/typecheck/should_run/tcrun006 +/tests/typecheck/should_run/tcrun008 +/tests/typecheck/should_run/tcrun009 +/tests/typecheck/should_run/tcrun010 +/tests/typecheck/should_run/tcrun011 +/tests/typecheck/should_run/tcrun012 +/tests/typecheck/should_run/tcrun013 +/tests/typecheck/should_run/tcrun014 +/tests/typecheck/should_run/tcrun015 +/tests/typecheck/should_run/tcrun016 +/tests/typecheck/should_run/tcrun017 +/tests/typecheck/should_run/tcrun018 +/tests/typecheck/should_run/tcrun019 +/tests/typecheck/should_run/tcrun020 +/tests/typecheck/should_run/tcrun021 +/tests/typecheck/should_run/tcrun022 +/tests/typecheck/should_run/tcrun023 +/tests/typecheck/should_run/tcrun024 +/tests/typecheck/should_run/tcrun025 +/tests/typecheck/should_run/tcrun026 +/tests/typecheck/should_run/tcrun027 +/tests/typecheck/should_run/tcrun028 +/tests/typecheck/should_run/tcrun029 +/tests/typecheck/should_run/tcrun030 +/tests/typecheck/should_run/tcrun031 +/tests/typecheck/should_run/tcrun032 +/tests/typecheck/should_run/tcrun033 +/tests/typecheck/should_run/tcrun034 +/tests/typecheck/should_run/tcrun036 +/tests/typecheck/should_run/tcrun037 +/tests/typecheck/should_run/tcrun038 +/tests/typecheck/should_run/tcrun039 +/tests/typecheck/should_run/tcrun040 +/tests/typecheck/should_run/tcrun041 +/tests/typecheck/should_run/tcrun042 +/tests/typecheck/should_run/tcrun043 +/tests/typecheck/should_run/tcrun044 +/tests/typecheck/should_run/tcrun045 +/tests/typecheck/should_run/tcrun046 +/tests/typecheck/should_run/tcrun047 +/tests/typecheck/should_run/tcrun048 +/tests/typecheck/should_run/tcrun049 +/tests/typecheck/should_run/tcrun050 +/tests/typecheck/should_run/tcrun051 +/tests/typecheck/should_run/testeq2 +/tests/typecheck/testeq1/typecheck.testeq1 +/timeout/calibrate.out +/timeout/dist/ +/timeout/install-inplace/ diff --git a/testsuite/driver/runtests.py b/testsuite/driver/runtests.py index c92eaefacc..103c7ace7c 100644 --- a/testsuite/driver/runtests.py +++ b/testsuite/driver/runtests.py @@ -98,8 +98,8 @@ for opt,arg in opts: config.skip_perf_tests = True if opt == '--verbose': - if arg not in ["0","1","2","3"]: - sys.stderr.write("ERROR: requested verbosity %s not supported, use 0,1,2 or 3" % arg) + if arg not in ["0","1","2","3","4"]: + sys.stderr.write("ERROR: requested verbosity %s not supported, use 0,1,2,3 or 4" % arg) sys.exit(1) config.verbose = int(arg) diff --git a/testsuite/driver/testlib.py b/testsuite/driver/testlib.py index 3479b6a5ba..9a6951b6e5 100644 --- a/testsuite/driver/testlib.py +++ b/testsuite/driver/testlib.py @@ -232,6 +232,17 @@ def exit_code( val ): def _exit_code( name, opts, v ): opts.exit_code = v +def signal_exit_code( val ): + if opsys('solaris2'): + return exit_code( val ); + else: + # When application running on Linux receives fatal error + # signal, then its exit code is encoded as 128 + signal + # value. See http://www.tldp.org/LDP/abs/html/exitcodes.html + # I assume that Mac OS X behaves in the same way at least Mac + # OS X builder behavior suggests this. + return exit_code( val+128 ); + # ----- def timeout_multiplier( val ): @@ -1021,12 +1032,14 @@ def multi_compile_and_run( name, way, top_mod, extra_mods, extra_hc_opts ): def stats( name, way, stats_file ): opts = getTestOpts() - return checkStats(stats_file, opts.stats_range_fields) + return checkStats(name, way, stats_file, opts.stats_range_fields) # ----------------------------------------------------------------------------- # Check -t stats info -def checkStats(stats_file, range_fields): +def checkStats(name, way, stats_file, range_fields): + full_name = name + '(' + way + ')' + result = passed() if len(range_fields) > 0: f = open(in_testdir(stats_file)) @@ -1040,8 +1053,10 @@ def checkStats(stats_file, range_fields): result = failBecause('no such stats field') val = int(m.group(1)) - lowerBound = trunc( expected * ((100 - float(dev))/100)); - upperBound = trunc(0.5 + ceil(expected * ((100 + float(dev))/100))); + lowerBound = trunc( expected * ((100 - float(dev))/100)) + upperBound = trunc(0.5 + ceil(expected * ((100 + float(dev))/100))) + + deviation = round(((float(val) * 100)/ expected) - 100, 1) if val < lowerBound: print field, 'value is too low:' @@ -1052,7 +1067,7 @@ def checkStats(stats_file, range_fields): print field, 'value is too high:' result = failBecause('stat not good enough') - if val < lowerBound or val > upperBound: + if val < lowerBound or val > upperBound or config.verbose >= 4: valStr = str(val) valLen = len(valStr) expectedStr = str(expected) @@ -1060,10 +1075,12 @@ def checkStats(stats_file, range_fields): length = max(map (lambda x : len(str(x)), [expected, lowerBound, upperBound, val])) def display(descr, val, extra): print descr, string.rjust(str(val), length), extra - display(' Expected ' + field + ':', expected, '+/-' + str(dev) + '%') - display(' Lower bound ' + field + ':', lowerBound, '') - display(' Upper bound ' + field + ':', upperBound, '') - display(' Actual ' + field + ':', val, '') + display(' Expected ' + full_name + ' ' + field + ':', expected, '+/-' + str(dev) + '%') + display(' Lower bound ' + full_name + ' ' + field + ':', lowerBound, '') + display(' Upper bound ' + full_name + ' ' + field + ':', upperBound, '') + display(' Actual ' + full_name + ' ' + field + ':', val, '') + if val != expected: + display(' Deviation ' + full_name + ' ' + field + ':', deviation, '%') return result @@ -1154,7 +1171,7 @@ def simple_build( name, way, extra_hc_opts, should_fail, top_mod, link, addsuf, # ToDo: if the sub-shell was killed by ^C, then exit - statsResult = checkStats(stats_file, opts.compiler_stats_range_fields) + statsResult = checkStats(name, way, stats_file, opts.compiler_stats_range_fields) if badResult(statsResult): return statsResult @@ -1254,7 +1271,7 @@ def simple_run( name, way, prog, args ): if check_prof and not check_prof_ok(name): return failBecause('bad profile') - return checkStats(stats_file, opts.stats_range_fields) + return checkStats(name, way, stats_file, opts.stats_range_fields) def rts_flags(way): if (way == ''): diff --git a/testsuite/tests/annotations/should_compile/th/.gitignore b/testsuite/tests/annotations/should_compile/th/.gitignore deleted file mode 100644 index 7bec7a7cb5..0000000000 --- a/testsuite/tests/annotations/should_compile/th/.gitignore +++ /dev/null @@ -1 +0,0 @@ -build_make diff --git a/testsuite/tests/cabal/Makefile b/testsuite/tests/cabal/Makefile index f0091bceeb..062850f76f 100644 --- a/testsuite/tests/cabal/Makefile +++ b/testsuite/tests/cabal/Makefile @@ -165,6 +165,60 @@ shadow: @echo "should SUCCEED:" '$(TEST_HC)' $(TEST_HC_OPTS) -package-db $(PKGCONFSHADOW1) -package-db $(PKGCONFSHADOW2) -package-id shadowdep-1-XXX -c shadow.hs -fno-code +# If we pass --global, we should ignore instances in the user database +T5442a: + @rm -rf package.conf.T5442a.global package.conf.T5442a.user + '$(GHC_PKG)' init package.conf.T5442a.global + '$(GHC_PKG)' init package.conf.T5442a.user + '$(GHC_PKG)' -f package.conf.T5442a.global register --force-files test.pkg 2>/dev/null + '$(GHC_PKG)' -f package.conf.T5442a.user register --force-files test.pkg 2>/dev/null + '$(GHC_PKG)' --global-package-db=package.conf.T5442a.global --user-package-db=package.conf.T5442a.user --global unregister testpkg + @echo "global (should be empty):" + '$(GHC_PKG)' -f package.conf.T5442a.global list --simple-output + @echo "user:" + '$(GHC_PKG)' -f package.conf.T5442a.user list --simple-output + +# If we pass --user, we should ignore instances in the global database +T5442b: + @rm -rf package.conf.T5442b.global package.conf.T5442b.user + '$(GHC_PKG)' init package.conf.T5442b.global + '$(GHC_PKG)' init package.conf.T5442b.user + '$(GHC_PKG)' -f package.conf.T5442b.global register --force-files test.pkg 2>/dev/null + ! '$(GHC_PKG)' --global-package-db=package.conf.T5442b.global --user-package-db=package.conf.T5442b.user --user unregister testpkg + @echo "global (should have testpkg):" + '$(GHC_PKG)' -f package.conf.T5442b.global list --simple-output + +# If we pass -f, we should ignore the user and global databases +T5442c: + @rm -rf package.conf.T5442c.global package.conf.T5442c.user package.conf.T5442c.extra + '$(GHC_PKG)' init package.conf.T5442c.global + '$(GHC_PKG)' init package.conf.T5442c.user + '$(GHC_PKG)' init package.conf.T5442c.extra + '$(GHC_PKG)' -f package.conf.T5442c.global register --force-files test.pkg 2>/dev/null + '$(GHC_PKG)' -f package.conf.T5442c.user register --force-files test.pkg 2>/dev/null + ! '$(GHC_PKG)' --global-package-db=package.conf.T5442c.global --user-package-db=package.conf.T5442c.user -f package.conf.T5442c.extra unregister testpkg + @echo "global (should have testpkg):" + '$(GHC_PKG)' -f package.conf.T5442c.global list --simple-output + @echo "use (should have testpkg):" + '$(GHC_PKG)' -f package.conf.T5442c.user list --simple-output + +# If we pass --global and -f, we remove from the global database, but +# warn about possible breakage in the full package stack +T5442d: + @rm -rf package.conf.T5442d.global package.conf.T5442d.user package.conf.T5442d.extra + '$(GHC_PKG)' init package.conf.T5442d.global + '$(GHC_PKG)' init package.conf.T5442d.user + '$(GHC_PKG)' init package.conf.T5442d.extra + '$(GHC_PKG)' -f package.conf.T5442d.global register --force-files shadow1.pkg 2>/dev/null + '$(GHC_PKG)' -f package.conf.T5442d.user register --force-files shadow3.pkg 2>/dev/null + '$(GHC_PKG)' --global-package-db=package.conf.T5442d.global -f package.conf.T5442d.extra register --force-files shadow2.pkg 2>/dev/null + '$(GHC_PKG)' --global-package-db=package.conf.T5442d.global --user-package-db=package.conf.T5442d.user -f package.conf.T5442d.extra --global unregister shadow --force + @echo "global (should be empty):" + '$(GHC_PKG)' -f package.conf.T5442d.global list --simple-output + @echo "user:" + '$(GHC_PKG)' -f package.conf.T5442d.user list --simple-output + @echo "extra:" + '$(GHC_PKG)' -f package.conf.T5442d.extra list --simple-output # ----------------------------------------------------------------------------- # Try piping the output of "ghc-pkg describe" into "ghc-pkg update" for @@ -182,3 +236,18 @@ ghcpkg02: echo Updating $$i; \ $(GHC_PKG) describe --global $$i | $(GHC_PKG_ghcpkg02) update --global --force -; \ done + +PKGCONF07=local07.package.conf +LOCAL_GHC_PKG07 = '$(GHC_PKG)' --no-user-package-db -f $(PKGCONF07) +ghcpkg07: + @rm -rf $(PKGCONF07) + $(LOCAL_GHC_PKG07) init $(PKGCONF07) + $(LOCAL_GHC_PKG07) register --force test.pkg 2>/dev/null + $(LOCAL_GHC_PKG07) register --force test7a.pkg 2>/dev/null + $(LOCAL_GHC_PKG07) field testpkg7a reexported-modules + $(LOCAL_GHC_PKG07) register --force test7b.pkg 2>/dev/null + $(LOCAL_GHC_PKG07) field testpkg7b reexported-modules + +recache_reexport: + @rm -rf recache_reexport_db/package.cache + '$(GHC_PKG)' --no-user-package-db --global-package-db=recache_reexport_db recache diff --git a/testsuite/tests/cabal/T1750A.pkg b/testsuite/tests/cabal/T1750A.pkg index 9bda51eea0..3f4a96e22b 100644 --- a/testsuite/tests/cabal/T1750A.pkg +++ b/testsuite/tests/cabal/T1750A.pkg @@ -1,4 +1,5 @@ name: T1750A version: 1 id: T1750A-1-XXX +key: T1750A-1 depends: T1750B-1-XXX diff --git a/testsuite/tests/cabal/T1750B.pkg b/testsuite/tests/cabal/T1750B.pkg index 479ce7092c..caaaefaa1a 100644 --- a/testsuite/tests/cabal/T1750B.pkg +++ b/testsuite/tests/cabal/T1750B.pkg @@ -1,4 +1,5 @@ name: T1750B version: 1 id: T1750B-1-XXX +key: T1750B-1 depends: T1750A-1-XXX diff --git a/testsuite/tests/cabal/T5442a.stdout b/testsuite/tests/cabal/T5442a.stdout new file mode 100644 index 0000000000..7bc64650e0 --- /dev/null +++ b/testsuite/tests/cabal/T5442a.stdout @@ -0,0 +1,5 @@ +Reading package info from "test.pkg" ... done. +Reading package info from "test.pkg" ... done. +global (should be empty): +user: +testpkg-1.2.3.4 diff --git a/testsuite/tests/cabal/T5442b.stderr b/testsuite/tests/cabal/T5442b.stderr new file mode 100644 index 0000000000..da7439820d --- /dev/null +++ b/testsuite/tests/cabal/T5442b.stderr @@ -0,0 +1 @@ +ghc-pkg: cannot find package testpkg diff --git a/testsuite/tests/cabal/T5442b.stdout b/testsuite/tests/cabal/T5442b.stdout new file mode 100644 index 0000000000..42814de517 --- /dev/null +++ b/testsuite/tests/cabal/T5442b.stdout @@ -0,0 +1,3 @@ +Reading package info from "test.pkg" ... done. +global (should have testpkg): +testpkg-1.2.3.4 diff --git a/testsuite/tests/cabal/T5442c.stderr b/testsuite/tests/cabal/T5442c.stderr new file mode 100644 index 0000000000..da7439820d --- /dev/null +++ b/testsuite/tests/cabal/T5442c.stderr @@ -0,0 +1 @@ +ghc-pkg: cannot find package testpkg diff --git a/testsuite/tests/cabal/T5442c.stdout b/testsuite/tests/cabal/T5442c.stdout new file mode 100644 index 0000000000..a183e595ba --- /dev/null +++ b/testsuite/tests/cabal/T5442c.stdout @@ -0,0 +1,6 @@ +Reading package info from "test.pkg" ... done. +Reading package info from "test.pkg" ... done. +global (should have testpkg): +testpkg-1.2.3.4 +use (should have testpkg): +testpkg-1.2.3.4 diff --git a/testsuite/tests/cabal/T5442d.stderr b/testsuite/tests/cabal/T5442d.stderr new file mode 100644 index 0000000000..be98dec17a --- /dev/null +++ b/testsuite/tests/cabal/T5442d.stderr @@ -0,0 +1 @@ +unregistering would break the following packages: shadowdep-1 (ignoring) diff --git a/testsuite/tests/cabal/T5442d.stdout b/testsuite/tests/cabal/T5442d.stdout new file mode 100644 index 0000000000..05c6619dde --- /dev/null +++ b/testsuite/tests/cabal/T5442d.stdout @@ -0,0 +1,8 @@ +Reading package info from "shadow1.pkg" ... done. +Reading package info from "shadow3.pkg" ... done. +Reading package info from "shadow2.pkg" ... done. +global (should be empty): +user: +shadow-1 +extra: +shadowdep-1 diff --git a/testsuite/tests/cabal/all.T b/testsuite/tests/cabal/all.T index d05d05fe1e..60f8d6df9b 100644 --- a/testsuite/tests/cabal/all.T +++ b/testsuite/tests/cabal/all.T @@ -47,6 +47,12 @@ test('ghcpkg06', run_command, ['$MAKE -s --no-print-directory ghcpkg06']) +test('ghcpkg07', + extra_clean(['local07.package.conf', + 'local07.package.conf.old']), + run_command, + ['$MAKE -s --no-print-directory ghcpkg07']) + # Test that we *can* compile a module that also belongs to a package # (this was disallowed in GHC 6.4 and earlier) test('pkg01', normal, compile, ['']) @@ -57,6 +63,28 @@ test('T1750', 'localT1750.package.conf.old']), run_command, ['$MAKE -s --no-print-directory T1750']) +test('T5442a', + [extra_clean(['package.conf.T5442a.global', 'package.conf.T5442a.user'])], + run_command, + ['$MAKE -s --no-print-directory T5442a']) + +test('T5442b', + [extra_clean(['package.conf.T5442b.global', 'package.conf.T5442b.user'])], + run_command, + ['$MAKE -s --no-print-directory T5442b']) + +test('T5442c', + [extra_clean(['package.conf.T5442c.global', 'package.conf.T5442c.user', + 'package.conf.T5442c.extra'])], + run_command, + ['$MAKE -s --no-print-directory T5442c']) + +test('T5442d', + [extra_clean(['package.conf.T5442d.global', 'package.conf.T5442d.user', + 'package.conf.T5442d.extra'])], + run_command, + ['$MAKE -s --no-print-directory T5442d']) + test('shadow', extra_clean(['shadow.out', 'shadow.hs', 'shadow.hi', 'local1shadow1.package.conf', diff --git a/testsuite/tests/cabal/cabal05/Makefile b/testsuite/tests/cabal/cabal05/Makefile new file mode 100644 index 0000000000..d1ade74113 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/Makefile @@ -0,0 +1,72 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +SETUP = ../Setup -v0 + +# This test is for package reexports +# 1. install p +# 2. install q (reexporting p modules) +# 3. install r (reexporting p and q modules) +# 4. configure and build s, using modules from q and r +# +# Here are the permutations we test for: +# - Package qualifier? (YES/NO) +# - Where is module? (defined in SELF / +# (ORIGinally defined/REEXported) in DEPendency) +# For deps, could be BOTH, if there is NO package qualifier +# - Renamed? (YES/NO) +# - Multiple modules with same name? (YES/NO) +# +# It's illegal for the module to be defined in SELF without renaming, or +# for a package to cause a conflict with itself. A reexport which does +# not rename definitionally "conflicts" with the original package's definition. +# +# Probably the trickiest bits are when we automatically pick out which package +# when the package qualifier is missing, and handling whether or not modules +# should be exposed or hidden. + +cabal05: clean + $(MAKE) clean + '$(GHC_PKG)' init tmp.d + '$(TEST_HC)' -v0 --make Setup + # build p + cd p && $(SETUP) clean + cd p && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d --prefix='$(PWD)/$$pkgid' + cd p && $(SETUP) build + cd p && $(SETUP) copy + cd p && $(SETUP) register + # build q + cd q && $(SETUP) clean + cd q && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d --prefix='$(PWD)/$$pkgid' + cd q && $(SETUP) build + cd q && $(SETUP) copy + cd q && $(SETUP) register + # build r + cd r && $(SETUP) clean + cd r && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d --prefix='$(PWD)/$$pkgid' + cd r && $(SETUP) build + cd r && $(SETUP) copy + cd r && $(SETUP) register + # build s + cd s && $(SETUP) clean + cd s && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d + cd s && $(SETUP) build + # now test that package recaching works + rm tmp.d/package.cache + '$(GHC_PKG)' --no-user-package-db --global-package-db=tmp.d recache + cd s && $(SETUP) clean + cd s && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d + cd s && $(SETUP) build + cd t && $(SETUP) clean + cd t && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d + ! (cd t && $(SETUP) build) +ifneq "$(CLEANUP)" "" + $(MAKE) clean +endif + +clean : + '$(GHC_PKG)' unregister --force p >/dev/null 2>&1 || true + '$(GHC_PKG)' unregister --force q >/dev/null 2>&1 || true + '$(GHC_PKG)' unregister --force r >/dev/null 2>&1 || true + $(RM) -r p-* q-* r-* s-* t-* tmp.d *.o *.hi */*.o */*.hi */Setup$(exeext) */dist Setup$(exeext) diff --git a/testsuite/tests/cabal/cabal05/Setup.hs b/testsuite/tests/cabal/cabal05/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/cabal/cabal05/all.T b/testsuite/tests/cabal/cabal05/all.T new file mode 100644 index 0000000000..36dcbdf9de --- /dev/null +++ b/testsuite/tests/cabal/cabal05/all.T @@ -0,0 +1,9 @@ +if default_testopts.cleanup != '': + cleanup = 'CLEANUP=1' +else: + cleanup = '' + +test('cabal05', + ignore_output, + run_command, + ['$MAKE -s --no-print-directory cabal05 ' + cleanup]) diff --git a/testsuite/tests/cabal/cabal05/p/LICENSE b/testsuite/tests/cabal/cabal05/p/LICENSE new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/p/LICENSE diff --git a/testsuite/tests/cabal/cabal05/p/P.hs b/testsuite/tests/cabal/cabal05/p/P.hs new file mode 100644 index 0000000000..f8b82de2ca --- /dev/null +++ b/testsuite/tests/cabal/cabal05/p/P.hs @@ -0,0 +1,3 @@ +module P where +data P = P +p = True diff --git a/testsuite/tests/cabal/cabal05/p/P2.hs b/testsuite/tests/cabal/cabal05/p/P2.hs new file mode 100644 index 0000000000..769760dff8 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/p/P2.hs @@ -0,0 +1 @@ +module P2 where diff --git a/testsuite/tests/cabal/cabal05/p/Setup.hs b/testsuite/tests/cabal/cabal05/p/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/p/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/cabal/cabal05/p/p.cabal b/testsuite/tests/cabal/cabal05/p/p.cabal new file mode 100644 index 0000000000..989156c5be --- /dev/null +++ b/testsuite/tests/cabal/cabal05/p/p.cabal @@ -0,0 +1,11 @@ +name: p +version: 0.1.0.0 +license-file: LICENSE +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.21 + +library + exposed-modules: P, P2 + build-depends: base diff --git a/testsuite/tests/cabal/cabal05/q/LICENSE b/testsuite/tests/cabal/cabal05/q/LICENSE new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/q/LICENSE diff --git a/testsuite/tests/cabal/cabal05/q/Q.hs b/testsuite/tests/cabal/cabal05/q/Q.hs new file mode 100644 index 0000000000..721b231aa1 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/q/Q.hs @@ -0,0 +1,4 @@ +module Q where +import P +data Q = Q +q = not p diff --git a/testsuite/tests/cabal/cabal05/q/Setup.hs b/testsuite/tests/cabal/cabal05/q/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/q/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/cabal/cabal05/q/q.cabal b/testsuite/tests/cabal/cabal05/q/q.cabal new file mode 100644 index 0000000000..338acdd382 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/q/q.cabal @@ -0,0 +1,30 @@ +name: q +version: 0.1.0.0 +license-file: LICENSE +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.21 + +library + exposed-modules: Q + reexported-modules: + -- qualified=NO, where=DEP(ORIG), renaming=NO, conflict=NO + -- impossible + -- qualified=NO, where=DEP(ORIG), renaming=NO, conflict=YES (p,s) + P, + -- qualified=NO, where=DEP(ORIG), renaming=YES, conflict=NO + P as QP, + -- qualified=NO, where=DEP(ORIG), renaming=YES, conflict=YES (r) + P as PMerge, + P2 as PMerge2, + -- qualified=NO, where=SELF, renaming=NO, conflict=NO + -- impossible + -- qualified=NO, where=SELF, renaming=NO, conflict=YES + -- should error + -- qualified=NO, where=SELF, renaming=YES, conflict=NO + Q as QQ, + -- qualified=NO, where=SELF, renaming=YES, conflict=YES (r) + Q as QMerge, + P2 as Conflict + build-depends: base, p diff --git a/testsuite/tests/cabal/cabal05/r/LICENSE b/testsuite/tests/cabal/cabal05/r/LICENSE new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/r/LICENSE diff --git a/testsuite/tests/cabal/cabal05/r/R.hs b/testsuite/tests/cabal/cabal05/r/R.hs new file mode 100644 index 0000000000..6f086340cf --- /dev/null +++ b/testsuite/tests/cabal/cabal05/r/R.hs @@ -0,0 +1,11 @@ +module R where +import P -- p (exposed), q (reexport p:P) +import P2 -- q (reexport p:P) +import Q -- q (exposed) +import qualified QP -- q (reexport p:P) +import qualified QQ -- q (reexport q:Q) +import qualified PMerge -- q (reexport p:P) +import qualified PMerge2 -- q (reexport p:P2) +import qualified QMerge -- q (reexport q:Q) +data R = R +r = p && q diff --git a/testsuite/tests/cabal/cabal05/r/Setup.hs b/testsuite/tests/cabal/cabal05/r/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/r/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/cabal/cabal05/r/r.cabal b/testsuite/tests/cabal/cabal05/r/r.cabal new file mode 100644 index 0000000000..b2d4ab0939 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/r/r.cabal @@ -0,0 +1,33 @@ +name: r +version: 0.1.0.0 +license-file: LICENSE +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.21 + +library + exposed-modules: R + reexported-modules: + -- qualified=NO, where=DEP(BOTH), renaming=NO, conflict=YES (p,q) + P, + -- qualified=NO, where=DEP(BOTH), renaming=YES, conflict=NO + P as RP2, + -- qualified=NO, where=DEP(BOTH), renaming=YES, conflict=YES + P as PMerge, + -- qualified=YES, where=DEP(ORIG), renaming=YES, conflict=NO + p:P as RP, + -- qualified=YES, where=DEP(REEX), renaming=YES, conflict=NO + q:QP as RQP, + -- qualified=YES, where=DEP(REEX), renaming=YES, conflict=NO + q:P as RQP2, + -- qualified=YES, where=DEP(REEX), renaming=YES, conflict=YES + q:QQ as QMerge, + -- qualified=YES, where=SELF, renaming=YES, conflict=NO + r:R as RR, + -- qualified=YES, where=DEP, renaming=NO, conflict=YES (q) + q:Q, + -- qualified=YES, where=DEP(ORIG), renaming=YES, conflict=YES (q) + p:P2 as PMerge2, + P as Conflict + build-depends: base, p, q diff --git a/testsuite/tests/cabal/cabal05/s/LICENSE b/testsuite/tests/cabal/cabal05/s/LICENSE new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/s/LICENSE diff --git a/testsuite/tests/cabal/cabal05/s/S.hs b/testsuite/tests/cabal/cabal05/s/S.hs new file mode 100644 index 0000000000..ed3c378072 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/s/S.hs @@ -0,0 +1,18 @@ +module S where +-- NB: package p is hidden! +import qualified QP -- q (reexport p:P) +import qualified RP -- r (reexport p:P) +import qualified Q -- q (exposed), r (reexport q:Q) +import qualified R -- r (exposed) +import qualified RR -- r (reexport r:R) +import qualified RP -- r (reexport p:P) +import qualified RQP -- r (reexport p:P) +import qualified RQP2 -- r (reexport p:P) +import qualified PMerge -- q (reexport p:P), r (reexport p:P) +import qualified PMerge2 -- q (reexport p:P2), r (reexport p:P2) +import qualified QMerge -- q (reexport q:Q), r (reexport q:Q) + +x :: QP.P +x = RP.P + +s = QP.p || Q.q || R.r diff --git a/testsuite/tests/cabal/cabal05/s/Setup.hs b/testsuite/tests/cabal/cabal05/s/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/s/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/cabal/cabal05/s/s.cabal b/testsuite/tests/cabal/cabal05/s/s.cabal new file mode 100644 index 0000000000..a0b09939a1 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/s/s.cabal @@ -0,0 +1,11 @@ +name: s +version: 0.1.0.0 +license-file: LICENSE +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.21 + +library + exposed-modules: S + build-depends: base, q, r diff --git a/testsuite/tests/cabal/cabal05/t/LICENSE b/testsuite/tests/cabal/cabal05/t/LICENSE new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/t/LICENSE diff --git a/testsuite/tests/cabal/cabal05/t/Setup.hs b/testsuite/tests/cabal/cabal05/t/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/t/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/cabal/cabal05/t/T.hs b/testsuite/tests/cabal/cabal05/t/T.hs new file mode 100644 index 0000000000..fcc3fb0479 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/t/T.hs @@ -0,0 +1,3 @@ +module T where + +import Conflict -- should be ambiguous diff --git a/testsuite/tests/cabal/cabal05/t/t.cabal b/testsuite/tests/cabal/cabal05/t/t.cabal new file mode 100644 index 0000000000..10117d6da6 --- /dev/null +++ b/testsuite/tests/cabal/cabal05/t/t.cabal @@ -0,0 +1,11 @@ +name: t +version: 0.1.0.0 +license-file: LICENSE +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.21 + +library + exposed-modules: T + build-depends: base, q, r diff --git a/testsuite/tests/cabal/cabal06/Makefile b/testsuite/tests/cabal/cabal06/Makefile new file mode 100644 index 0000000000..5934b9b29c --- /dev/null +++ b/testsuite/tests/cabal/cabal06/Makefile @@ -0,0 +1,70 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +SETUP=../Setup -v0 + +# This test is for packages whose package IDs overlap, but whose package keys +# do not. +# +# 1. install p-1.0 +# 2. install q-1.0 (depending on p-1.0) +# 3. install p-1.1 +# 4. install q-1.0, asking for p-1.1 +# 5. install r-1.0 (depending on p-1.1, q-1.0) +# 6. install r-1.0 asking for p-1.0 +# +# The notable steps are (4), which previously would have required a reinstall, +# and (6), where the dependency solver picks between two package keys with the +# same package ID based on their depenencies. +# +# ./Setup configure is pretty dumb, so we spoonfeed it precisely the +# dependencies it needs. + +cabal06: clean + $(MAKE) clean + '$(GHC_PKG)' init tmp.d + '$(TEST_HC)' -v0 --make Setup + cd p-1.0 && $(SETUP) clean + cd p-1.0 && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d --prefix='$(PWD)/inst-a' --ghc-pkg-options='--enable-multi-instance' + cd p-1.0 && $(SETUP) build + cd p-1.0 && $(SETUP) copy + cd p-1.0 && $(SETUP) register + cd q && $(SETUP) clean + cd q && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d --prefix='$(PWD)/inst-b' --ghc-pkg-options='--enable-multi-instance' + cd q && $(SETUP) build + cd q && $(SETUP) copy + (cd q && $(SETUP) register --print-ipid) > tmp_first_q + cd p-1.1 && $(SETUP) clean + cd p-1.1 && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d --prefix='$(PWD)/inst-c' --ghc-pkg-options='--enable-multi-instance' + cd p-1.1 && $(SETUP) build + cd p-1.1 && $(SETUP) copy + cd p-1.1 && $(SETUP) register + cd q && $(SETUP) clean + cd q && $(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d --constraint="p==1.1" --prefix='$(PWD)/inst-d' --ghc-pkg-options='--enable-multi-instance' + cd q && $(SETUP) build + cd q && $(SETUP) copy + (cd q && $(SETUP) register --print-ipid) > tmp_second_q + @echo "Does the first instance of q depend on p-1.0?" + '$(GHC_PKG)' field --ipid `cat tmp_first_q` depends -f tmp.d | grep p-1.0 | wc -l + @echo "Does the second instance of q depend on p-1.0?" + '$(GHC_PKG)' field --ipid `cat tmp_second_q` depends -f tmp.d | grep p-1.1 | wc -l + cd r && $(SETUP) clean + cd r && ../Setup configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d --dependency="q=`cat ../tmp_first_q`" --constraint="p==1.0" --prefix='$(PWD)/inst-e' --ghc-pkg-options='--enable-multi-instance' + cd r && $(SETUP) build + cd r && $(SETUP) copy + cd r && $(SETUP) clean + cd r && ../Setup configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)' --package-db=../tmp.d --dependency="q=`cat ../tmp_second_q`" --constraint="p==1.1" --prefix='$(PWD)/inst-f' --ghc-pkg-options='--enable-multi-instance' + cd r && $(SETUP) build + cd r && $(SETUP) copy + inst-e/bin/cabal06 + inst-f/bin/cabal06 +ifneq "$(CLEANUP)" "" + $(MAKE) clean +endif + +clean : + '$(GHC_PKG)' unregister --force p >/dev/null 2>&1 || true + '$(GHC_PKG)' unregister --force q >/dev/null 2>&1 || true + '$(GHC_PKG)' unregister --force r >/dev/null 2>&1 || true + $(RM) -r tmp.d inst-* *.o *.hi */*.o */*.hi */Setup$(exeext) */dist Setup$(exeext) diff --git a/testsuite/tests/cabal/cabal06/Setup.hs b/testsuite/tests/cabal/cabal06/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/testsuite/tests/cabal/cabal06/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/testsuite/tests/cabal/cabal06/all.T b/testsuite/tests/cabal/cabal06/all.T new file mode 100644 index 0000000000..edca288265 --- /dev/null +++ b/testsuite/tests/cabal/cabal06/all.T @@ -0,0 +1,9 @@ +if default_testopts.cleanup != '': + cleanup = 'CLEANUP=1' +else: + cleanup = '' + +test('cabal06', + normal, + run_command, + ['$MAKE -s --no-print-directory cabal06 ' + cleanup]) diff --git a/testsuite/tests/cabal/cabal06/cabal06.stderr b/testsuite/tests/cabal/cabal06/cabal06.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/cabal/cabal06/cabal06.stderr diff --git a/testsuite/tests/cabal/cabal06/cabal06.stdout b/testsuite/tests/cabal/cabal06/cabal06.stdout new file mode 100644 index 0000000000..e5ff042302 --- /dev/null +++ b/testsuite/tests/cabal/cabal06/cabal06.stdout @@ -0,0 +1,8 @@ +Does the first instance of q depend on p-1.0? +1 +Does the second instance of q depend on p-1.0? +1 +Configuring r-1.0... +Configuring r-1.0... +10 +11 diff --git a/testsuite/tests/cabal/cabal06/p-1.0/LICENSE b/testsuite/tests/cabal/cabal06/p-1.0/LICENSE new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/cabal/cabal06/p-1.0/LICENSE diff --git a/testsuite/tests/cabal/cabal06/p-1.0/P.hs b/testsuite/tests/cabal/cabal06/p-1.0/P.hs new file mode 100644 index 0000000000..7d63e39dac --- /dev/null +++ b/testsuite/tests/cabal/cabal06/p-1.0/P.hs @@ -0,0 +1,3 @@ +module P where +p :: Int +p = 0 diff --git a/testsuite/tests/cabal/cabal06/p-1.0/p.cabal b/testsuite/tests/cabal/cabal06/p-1.0/p.cabal new file mode 100644 index 0000000000..ab7b3ebffe --- /dev/null +++ b/testsuite/tests/cabal/cabal06/p-1.0/p.cabal @@ -0,0 +1,12 @@ +name: p +version: 1.0 +license-file: LICENSE +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.20 + +library + exposed-modules: P + build-depends: base + default-language: Haskell2010 diff --git a/testsuite/tests/cabal/cabal06/p-1.1/LICENSE b/testsuite/tests/cabal/cabal06/p-1.1/LICENSE new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/cabal/cabal06/p-1.1/LICENSE diff --git a/testsuite/tests/cabal/cabal06/p-1.1/P.hs b/testsuite/tests/cabal/cabal06/p-1.1/P.hs new file mode 100644 index 0000000000..446448039f --- /dev/null +++ b/testsuite/tests/cabal/cabal06/p-1.1/P.hs @@ -0,0 +1,3 @@ +module P where +p :: Int +p = 1 diff --git a/testsuite/tests/cabal/cabal06/p-1.1/p.cabal b/testsuite/tests/cabal/cabal06/p-1.1/p.cabal new file mode 100644 index 0000000000..8a7b7b271d --- /dev/null +++ b/testsuite/tests/cabal/cabal06/p-1.1/p.cabal @@ -0,0 +1,12 @@ +name: p +version: 1.1 +license-file: LICENSE +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.20 + +library + exposed-modules: P + build-depends: base + default-language: Haskell2010 diff --git a/testsuite/tests/cabal/cabal06/q/LICENSE b/testsuite/tests/cabal/cabal06/q/LICENSE new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/cabal/cabal06/q/LICENSE diff --git a/testsuite/tests/cabal/cabal06/q/Q.hs b/testsuite/tests/cabal/cabal06/q/Q.hs new file mode 100644 index 0000000000..03d0923450 --- /dev/null +++ b/testsuite/tests/cabal/cabal06/q/Q.hs @@ -0,0 +1,4 @@ +module Q where +import P +q :: Int +q = p + 10 diff --git a/testsuite/tests/cabal/cabal06/q/q-1.0.conf b/testsuite/tests/cabal/cabal06/q/q-1.0.conf new file mode 100644 index 0000000000..2c25cee262 --- /dev/null +++ b/testsuite/tests/cabal/cabal06/q/q-1.0.conf @@ -0,0 +1,19 @@ +name: q +version: 1.0 +id: q-1.0-beaf238a500e9dd4ea74fe12762b72e1 + +key: d54a904d84001e92dbb7d30e2bede8ce +license: AllRightsReserved +maintainer: ezyang@cs.stanford.edu +author: Edward Z. Yang +exposed: True +exposed-modules: + Q +trusted: False +import-dirs: /5playpen/t-edyang/ghc-backpack/testsuite/tests/cabal/cabal06/inst-d/lib/x86_64-linux-ghc-7.9.20140719/q-1.0 +library-dirs: /5playpen/t-edyang/ghc-backpack/testsuite/tests/cabal/cabal06/inst-d/lib/x86_64-linux-ghc-7.9.20140719/q-1.0 +hs-libraries: HSd54a904d84001e92dbb7d30e2bede8ce +depends: base-4.7.1.0-inplace + p-1.0-168289aa0216a183a2729001bb18e7a8 +haddock-interfaces: /5playpen/t-edyang/ghc-backpack/testsuite/tests/cabal/cabal06/inst-d/share/doc/x86_64-linux-ghc-7.9.20140719/q-1.0/html/q.haddock +haddock-html: /5playpen/t-edyang/ghc-backpack/testsuite/tests/cabal/cabal06/inst-d/share/doc/x86_64-linux-ghc-7.9.20140719/q-1.0/html diff --git a/testsuite/tests/cabal/cabal06/q/q.cabal b/testsuite/tests/cabal/cabal06/q/q.cabal new file mode 100644 index 0000000000..7b3a074f88 --- /dev/null +++ b/testsuite/tests/cabal/cabal06/q/q.cabal @@ -0,0 +1,12 @@ +name: q +version: 1.0 +license-file: LICENSE +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.20 + +library + exposed-modules: Q + build-depends: base, p + default-language: Haskell2010 diff --git a/testsuite/tests/cabal/cabal06/r/LICENSE b/testsuite/tests/cabal/cabal06/r/LICENSE new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/cabal/cabal06/r/LICENSE diff --git a/testsuite/tests/cabal/cabal06/r/Main.hs b/testsuite/tests/cabal/cabal06/r/Main.hs new file mode 100644 index 0000000000..5e626645cd --- /dev/null +++ b/testsuite/tests/cabal/cabal06/r/Main.hs @@ -0,0 +1,3 @@ +module Main where +import Q +main = print q diff --git a/testsuite/tests/cabal/cabal06/r/r.cabal b/testsuite/tests/cabal/cabal06/r/r.cabal new file mode 100644 index 0000000000..60e16c1c78 --- /dev/null +++ b/testsuite/tests/cabal/cabal06/r/r.cabal @@ -0,0 +1,12 @@ +name: r +version: 1.0 +license-file: LICENSE +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.20 + +executable cabal06 + build-depends: base, p, q + main-is: Main.hs + default-language: Haskell2010 diff --git a/testsuite/tests/cabal/ghcpkg01.stderr b/testsuite/tests/cabal/ghcpkg01.stderr index 585c7aaa83..a6ef40019e 100644 --- a/testsuite/tests/cabal/ghcpkg01.stderr +++ b/testsuite/tests/cabal/ghcpkg01.stderr @@ -1,2 +1,2 @@ -ghc-pkg: unregistering testpkg-2.0 would break the following packages: testpkg-3.0 (use --force to override) +ghc-pkg: unregistering would break the following packages: testpkg-3.0 (use --force to override) testpkg-3.0: dependency "testpkg-2.0-XXX" doesn't exist (use --force to override) diff --git a/testsuite/tests/cabal/ghcpkg01.stdout b/testsuite/tests/cabal/ghcpkg01.stdout index da50cd92f6..c8faf7fdbb 100644 --- a/testsuite/tests/cabal/ghcpkg01.stdout +++ b/testsuite/tests/cabal/ghcpkg01.stdout @@ -4,6 +4,7 @@ Reading package info from "test.pkg" ... done. name: testpkg version: 1.2.3.4 id: testpkg-1.2.3.4-XXX +key: testpkg-1.2.3.4 license: BSD3 copyright: (c) The Univsersity of Glasgow 2004 maintainer: glasgow-haskell-users@haskell.org @@ -28,6 +29,7 @@ pkgroot: name: testpkg version: 1.2.3.4 id: testpkg-1.2.3.4-XXX +key: testpkg-1.2.3.4 license: BSD3 copyright: (c) The Univsersity of Glasgow 2004 maintainer: glasgow-haskell-users@haskell.org @@ -58,6 +60,7 @@ local01.package.conf: name: testpkg version: 2.0 id: testpkg-2.0-XXX +key: testpkg-2.0 license: BSD3 copyright: (c) The Univsersity of Glasgow 2004 maintainer: glasgow-haskell-users@haskell.org @@ -82,6 +85,7 @@ pkgroot: name: testpkg version: 2.0 id: testpkg-2.0-XXX +key: testpkg-2.0 license: BSD3 copyright: (c) The Univsersity of Glasgow 2004 maintainer: glasgow-haskell-users@haskell.org @@ -106,6 +110,7 @@ pkgroot: name: testpkg version: 1.2.3.4 id: testpkg-1.2.3.4-XXX +key: testpkg-1.2.3.4 license: BSD3 copyright: (c) The Univsersity of Glasgow 2004 maintainer: glasgow-haskell-users@haskell.org @@ -137,6 +142,7 @@ Reading package info from "test3.pkg" ... done. name: testpkg version: 1.2.3.4 id: testpkg-1.2.3.4-XXX +key: testpkg-1.2.3.4 license: BSD3 copyright: (c) The Univsersity of Glasgow 2004 maintainer: glasgow-haskell-users@haskell.org diff --git a/testsuite/tests/cabal/ghcpkg05.stderr b/testsuite/tests/cabal/ghcpkg05.stderr index c4e38c16d9..df8d11a6b9 100644 --- a/testsuite/tests/cabal/ghcpkg05.stderr +++ b/testsuite/tests/cabal/ghcpkg05.stderr @@ -15,4 +15,4 @@ The following packages are broken, either because they have a problem listed above, or because they depend on a broken package. testpkg-2.0 testpkg-3.0 -ghc-pkg: unregistering testpkg-2.0 would break the following packages: testpkg-3.0 (use --force to override) +ghc-pkg: unregistering would break the following packages: testpkg-3.0 (use --force to override) diff --git a/testsuite/tests/cabal/ghcpkg07.stdout b/testsuite/tests/cabal/ghcpkg07.stdout new file mode 100644 index 0000000000..f890b5bfe1 --- /dev/null +++ b/testsuite/tests/cabal/ghcpkg07.stdout @@ -0,0 +1,11 @@ +Reading package info from "test.pkg" ... done. +Reading package info from "test7a.pkg" ... done. +reexported-modules: testpkg:A (A@testpkg-1.2.3.4-XXX) + testpkg:A as A1 (A@testpkg-1.2.3.4-XXX) + E as E2 (E@testpkg7a-1.0-XXX) +Reading package info from "test7b.pkg" ... done. +reexported-modules: testpkg:A as F1 (A@testpkg-1.2.3.4-XXX) + testpkg7a:A as F2 (A@testpkg-1.2.3.4-XXX) + testpkg7a:A1 as F3 (A@testpkg-1.2.3.4-XXX) + testpkg7a:E as F4 (E@testpkg7a-1.0-XXX) E (E@testpkg7a-1.0-XXX) + E2 as E3 (E@testpkg7a-1.0-XXX) diff --git a/testsuite/tests/cabal/recache_reexport_db/a.conf b/testsuite/tests/cabal/recache_reexport_db/a.conf new file mode 100644 index 0000000000..c0698d70b9 --- /dev/null +++ b/testsuite/tests/cabal/recache_reexport_db/a.conf @@ -0,0 +1,17 @@ +name: testpkg7a +version: 1.0 +id: testpkg7a-1.0-XXX +license: BSD3 +copyright: (c) The Univsersity of Glasgow 2004 +maintainer: glasgow-haskell-users@haskell.org +stability: stable +homepage: http://www.haskell.org/ghc +package-url: http://www.haskell.org/ghc +description: A Test Package +category: none +author: simonmar@microsoft.com +exposed: True +exposed-modules: E +reexported-modules: testpkg:A, testpkg:A as A1, E as E2 +hs-libraries: testpkg7a-1.0 +depends: testpkg-1.2.3.4-XXX diff --git a/testsuite/tests/cabal/shadow1.pkg b/testsuite/tests/cabal/shadow1.pkg index 7bf047f3d2..553ebeb776 100644 --- a/testsuite/tests/cabal/shadow1.pkg +++ b/testsuite/tests/cabal/shadow1.pkg @@ -1,4 +1,5 @@ name: shadow version: 1 id: shadow-1-XXX +key: shadow-1 depends: diff --git a/testsuite/tests/cabal/shadow2.pkg b/testsuite/tests/cabal/shadow2.pkg index b720dc9479..ae89641176 100644 --- a/testsuite/tests/cabal/shadow2.pkg +++ b/testsuite/tests/cabal/shadow2.pkg @@ -1,4 +1,5 @@ name: shadowdep version: 1 id: shadowdep-1-XXX +key: shadowdep-1 depends: shadow-1-XXX diff --git a/testsuite/tests/cabal/shadow3.pkg b/testsuite/tests/cabal/shadow3.pkg index 933ed3f67d..62c93f95e1 100644 --- a/testsuite/tests/cabal/shadow3.pkg +++ b/testsuite/tests/cabal/shadow3.pkg @@ -1,4 +1,5 @@ name: shadow version: 1 id: shadow-1-YYY +key: shadow-1 depends: diff --git a/testsuite/tests/cabal/test.pkg b/testsuite/tests/cabal/test.pkg index 02a07ab7b6..42c557a0f9 100644 --- a/testsuite/tests/cabal/test.pkg +++ b/testsuite/tests/cabal/test.pkg @@ -1,6 +1,7 @@ name: testpkg version: 1.2.3.4 id: testpkg-1.2.3.4-XXX +key: testpkg-1.2.3.4 license: BSD3 copyright: (c) The Univsersity of Glasgow 2004 maintainer: glasgow-haskell-users@haskell.org diff --git a/testsuite/tests/cabal/test2.pkg b/testsuite/tests/cabal/test2.pkg index a6d28d629a..c027ed3a15 100644 --- a/testsuite/tests/cabal/test2.pkg +++ b/testsuite/tests/cabal/test2.pkg @@ -1,6 +1,7 @@ name: "testpkg" version: 2.0 id: testpkg-2.0-XXX +key: testpkg-2.0 license: BSD3 copyright: (c) The Univsersity of Glasgow 2004 maintainer: glasgow-haskell-users@haskell.org diff --git a/testsuite/tests/cabal/test3.pkg b/testsuite/tests/cabal/test3.pkg index 6d3257126b..8f1ca04366 100644 --- a/testsuite/tests/cabal/test3.pkg +++ b/testsuite/tests/cabal/test3.pkg @@ -1,6 +1,7 @@ name: "testpkg" version: 3.0 id: testpkg-3.0-XXX +key: testpkg-3.0 license: BSD3 copyright: (c) The Univsersity of Glasgow 2004 maintainer: glasgow-haskell-users@haskell.org diff --git a/testsuite/tests/cabal/test4.pkg b/testsuite/tests/cabal/test4.pkg index 598559a80f..c4b1883512 100644 --- a/testsuite/tests/cabal/test4.pkg +++ b/testsuite/tests/cabal/test4.pkg @@ -1,6 +1,7 @@ name: "testpkg" version: 4.0 id: testpkg-4.0-XXX +key: testpkg-4.0 license: BSD3 copyright: (c) The Univsersity of Glasgow 2004 maintainer: glasgow-haskell-users@haskell.org diff --git a/testsuite/tests/cabal/test5.pkg b/testsuite/tests/cabal/test5.pkg index fc27bc9ba5..48e198cd30 100644 --- a/testsuite/tests/cabal/test5.pkg +++ b/testsuite/tests/cabal/test5.pkg @@ -1,6 +1,7 @@ name: "newtestpkg" version: 2.0 id: newtestpkg-2.0-XXX +key: newtestpkg-2.0 license: BSD3 copyright: (c) The Univsersity of Glasgow 2004 maintainer: glasgow-haskell-users@haskell.org diff --git a/testsuite/tests/cabal/test7a.pkg b/testsuite/tests/cabal/test7a.pkg new file mode 100644 index 0000000000..f90fa7320f --- /dev/null +++ b/testsuite/tests/cabal/test7a.pkg @@ -0,0 +1,18 @@ +name: testpkg7a +version: 1.0 +id: testpkg7a-1.0-XXX +key: testpkg7a-1.0 +license: BSD3 +copyright: (c) The Univsersity of Glasgow 2004 +maintainer: glasgow-haskell-users@haskell.org +stability: stable +homepage: http://www.haskell.org/ghc +package-url: http://www.haskell.org/ghc +description: A Test Package +category: none +author: simonmar@microsoft.com +exposed: True +exposed-modules: E +reexported-modules: testpkg:A, testpkg:A as A1, E as E2 +hs-libraries: testpkg7a-1.0 +depends: testpkg-1.2.3.4-XXX diff --git a/testsuite/tests/cabal/test7b.pkg b/testsuite/tests/cabal/test7b.pkg new file mode 100644 index 0000000000..e89ac444d8 --- /dev/null +++ b/testsuite/tests/cabal/test7b.pkg @@ -0,0 +1,18 @@ +name: testpkg7b +version: 1.0 +id: testpkg7b-1.0-XXX +key: testpkg7b-1.0 +license: BSD3 +copyright: (c) The Univsersity of Glasgow 2004 +maintainer: glasgow-haskell-users@haskell.org +stability: stable +homepage: http://www.haskell.org/ghc +package-url: http://www.haskell.org/ghc +description: A Test Package +category: none +author: simonmar@microsoft.com +exposed: True +reexported-modules: testpkg:A as F1, testpkg7a:A as F2, + testpkg7a:A1 as F3, testpkg7a:E as F4, E, E2 as E3 +hs-libraries: testpkg7b-1.0 +depends: testpkg-1.2.3.4-XXX, testpkg7a-1.0-XXX diff --git a/testsuite/tests/cabal/testdup.pkg b/testsuite/tests/cabal/testdup.pkg index 77000eda27..0e368e5ae8 100644 --- a/testsuite/tests/cabal/testdup.pkg +++ b/testsuite/tests/cabal/testdup.pkg @@ -1,5 +1,6 @@ name: testdup version: 1.0 id: testdup-1.0-XXX +key: testdup-1.0 license: BSD3 depends: testpkg-1.2.3.4-XXX testpkg-1.2.3.4-XXX diff --git a/testsuite/tests/callarity/perf/.gitignore b/testsuite/tests/callarity/perf/.gitignore deleted file mode 100644 index 9b33309aea..0000000000 --- a/testsuite/tests/callarity/perf/.gitignore +++ /dev/null @@ -1 +0,0 @@ -T3924 diff --git a/testsuite/tests/callarity/perf/all.T b/testsuite/tests/callarity/perf/all.T index 765a2e94a7..1c7969474c 100644 --- a/testsuite/tests/callarity/perf/all.T +++ b/testsuite/tests/callarity/perf/all.T @@ -1,8 +1,9 @@ test('T3924', [stats_num_field('bytes allocated', - [ (wordsize(64), 51480, 5), + [ (wordsize(64), 50760, 5), # previously, without call-arity: 22326544 # 2014-01-18: 51480 (amd64/Linux) + # 2014-07-17: 50760 (amd64/Linux) (Roundabout adjustment) (wordsize(32), 44988, 5) ]), # 2014-04-04: 44988 (Windows, 64-bit machine) only_ways(['normal']) diff --git a/testsuite/tests/callarity/should_run/.gitignore b/testsuite/tests/callarity/should_run/.gitignore deleted file mode 100644 index 5268126cf8..0000000000 --- a/testsuite/tests/callarity/should_run/.gitignore +++ /dev/null @@ -1 +0,0 @@ -StrictLet diff --git a/testsuite/tests/callarity/unittest/.gitignore b/testsuite/tests/callarity/unittest/.gitignore deleted file mode 100644 index f7b31b6572..0000000000 --- a/testsuite/tests/callarity/unittest/.gitignore +++ /dev/null @@ -1 +0,0 @@ -CallArity1 diff --git a/testsuite/tests/codeGen/should_compile/T9303.hs b/testsuite/tests/codeGen/should_compile/T9303.hs new file mode 100644 index 0000000000..0b23de251e --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/T9303.hs @@ -0,0 +1,10 @@ +module M (f) where + +f :: Int -> Int +f i = go [ 1, 0 ] + where + go :: [Int] -> Int + go [] = undefined + go [1] = undefined + go (x:xs) | x == i = 2 + | otherwise = go xs diff --git a/testsuite/tests/codeGen/should_compile/T9329.cmm b/testsuite/tests/codeGen/should_compile/T9329.cmm new file mode 100644 index 0000000000..da200694fe --- /dev/null +++ b/testsuite/tests/codeGen/should_compile/T9329.cmm @@ -0,0 +1,5 @@ +foo () +{ + STK_CHK_GEN_N (8); /* panics */ + return (0); +} diff --git a/testsuite/tests/codeGen/should_compile/all.T b/testsuite/tests/codeGen/should_compile/all.T index ae8d0dd24a..a6b6894317 100644 --- a/testsuite/tests/codeGen/should_compile/all.T +++ b/testsuite/tests/codeGen/should_compile/all.T @@ -23,3 +23,5 @@ test('T7237', normal, compile, ['']) test('T7574', [cmm_src, omit_ways(['llvm', 'optllvm'])], compile, ['']) test('T8205', normal, compile, ['-O0']) test('T9155', normal, compile, ['-O2']) +test('T9303', normal, compile, ['-O2']) +test('T9329', [cmm_src], compile, ['']) diff --git a/testsuite/tests/codeGen/should_run/.gitignore b/testsuite/tests/codeGen/should_run/.gitignore deleted file mode 100644 index d313f5f6f0..0000000000 --- a/testsuite/tests/codeGen/should_run/.gitignore +++ /dev/null @@ -1,11 +0,0 @@ -CopySmallArray -CopySmallArrayStressTest -SizeOfSmallArray -StaticArraySize -StaticByteArraySize -T6084 -T7953 -T8103 -T8256 -T9001 -cgrun072 diff --git a/testsuite/tests/concurrent/should_run/.gitignore b/testsuite/tests/concurrent/should_run/.gitignore deleted file mode 100644 index 4f0a3175da..0000000000 --- a/testsuite/tests/concurrent/should_run/.gitignore +++ /dev/null @@ -1,6 +0,0 @@ -T7970 -compareAndSwap -readMVar1 -readMVar2 -readMVar3 -tryReadMVar1 diff --git a/testsuite/tests/concurrent/should_run/AtomicPrimops.hs b/testsuite/tests/concurrent/should_run/AtomicPrimops.hs new file mode 100644 index 0000000000..1789e26bbb --- /dev/null +++ b/testsuite/tests/concurrent/should_run/AtomicPrimops.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main ( main ) where + +import Control.Concurrent +import Control.Concurrent.MVar +import Control.Monad (when) +import Foreign.Storable +import GHC.Exts +import GHC.IO + +-- | Iterations per worker. +iters :: Int +iters = 1000000 + +main :: IO () +main = do + fetchAddSubTest + fetchAndTest + fetchNandTest + fetchOrTest + fetchXorTest + casTest + readWriteTest + +-- | Test fetchAddIntArray# by having two threads concurrenctly +-- increment a counter and then checking the sum at the end. +fetchAddSubTest :: IO () +fetchAddSubTest = do + tot <- race 0 + (\ mba -> work fetchAddIntArray mba iters 2) + (\ mba -> work fetchSubIntArray mba iters 1) + assertEq 1000000 tot "fetchAddSubTest" + where + work :: (MByteArray -> Int -> Int -> IO ()) -> MByteArray -> Int -> Int + -> IO () + work op mba 0 val = return () + work op mba n val = op mba 0 val >> work op mba (n-1) val + +-- | Test fetchXorIntArray# by having two threads concurrenctly XORing +-- and then checking the result at the end. Works since XOR is +-- commutative. +-- +-- Covers the code paths for AND, NAND, and OR as well. +fetchXorTest :: IO () +fetchXorTest = do + res <- race n0 + (\ mba -> work mba iters t1pat) + (\ mba -> work mba iters t2pat) + assertEq expected res "fetchXorTest" + where + work :: MByteArray -> Int -> Int -> IO () + work mba 0 val = return () + work mba n val = fetchXorIntArray mba 0 val >> work mba (n-1) val + + -- Initial value is a large prime and the two patterns are 1010... + -- and 0101... + (n0, t1pat, t2pat) + | sizeOf (undefined :: Int) == 8 = + (0x00000000ffffffff, 0x5555555555555555, 0x9999999999999999) + | otherwise = (0x0000ffff, 0x55555555, 0x99999999) + expected + | sizeOf (undefined :: Int) == 8 = 4294967295 + | otherwise = 65535 + +-- The tests for AND, NAND, and OR are trivial for two reasons: +-- +-- * The code path is already well exercised by 'fetchXorTest'. +-- +-- * It's harder to test these operations, as a long sequence of them +-- convert to a single value but we'd like to write a test in the +-- style of 'fetchXorTest' that applies the operation repeatedly, +-- to make it likely that any race conditions are detected. +-- +-- Right now we only test that they return the correct value for a +-- single op on each thread. + +-- | Test an associative operation. +fetchOpTest :: (MByteArray -> Int -> Int -> IO ()) + -> Int -> String -> IO () +fetchOpTest op expected name = do + res <- race n0 + (\ mba -> work mba t1pat) + (\ mba -> work mba t2pat) + assertEq expected res name + where + work :: MByteArray -> Int -> IO () + work mba val = op mba 0 val + +-- | Initial value and operation arguments for race test. +-- +-- Initial value is a large prime and the two patterns are 1010... +-- and 0101... +n0, t1pat, t2pat :: Int +(n0, t1pat, t2pat) + | sizeOf (undefined :: Int) == 8 = + (0x00000000ffffffff, 0x5555555555555555, 0x9999999999999999) + | otherwise = (0x0000ffff, 0x55555555, 0x99999999) + +fetchAndTest :: IO () +fetchAndTest = fetchOpTest fetchAndIntArray expected "fetchAndTest" + where expected + | sizeOf (undefined :: Int) == 8 = 286331153 + | otherwise = 4369 + +-- | Test NAND without any race, as NAND isn't associative. +fetchNandTest :: IO () +fetchNandTest = do + mba <- newByteArray (sizeOf (undefined :: Int)) + writeIntArray mba 0 n0 + fetchNandIntArray mba 0 t1pat + fetchNandIntArray mba 0 t2pat + res <- readIntArray mba 0 + assertEq expected res "fetchNandTest" + where expected + | sizeOf (undefined :: Int) == 8 = 7378697629770151799 + | otherwise = -2576976009 + +fetchOrTest :: IO () +fetchOrTest = fetchOpTest fetchOrIntArray expected "fetchOrTest" + where expected + | sizeOf (undefined :: Int) == 8 = 15987178197787607039 + | otherwise = 3722313727 + +-- | Test casIntArray# by using it to emulate fetchAddIntArray# and +-- then having two threads concurrenctly increment a counter, +-- checking the sum at the end. +casTest :: IO () +casTest = do + tot <- race 0 + (\ mba -> work mba iters 1) + (\ mba -> work mba iters 2) + assertEq 3000000 tot "casTest" + where + work :: MByteArray -> Int -> Int -> IO () + work mba 0 val = return () + work mba n val = add mba 0 val >> work mba (n-1) val + + -- Fetch-and-add implemented using CAS. + add :: MByteArray -> Int -> Int -> IO () + add mba ix n = do + old <- readIntArray mba ix + old' <- casIntArray mba ix old (old + n) + when (old /= old') $ add mba ix n + +-- | Tests atomic reads and writes by making sure that one thread sees +-- updates that are done on another. This test isn't very good at the +-- moment, as this might work even without atomic ops, but at least it +-- exercises the code. +readWriteTest :: IO () +readWriteTest = do + mba <- newByteArray (sizeOf (undefined :: Int)) + writeIntArray mba 0 0 + latch <- newEmptyMVar + done <- newEmptyMVar + forkIO $ do + takeMVar latch + n <- atomicReadIntArray mba 0 + assertEq 1 n "readWriteTest" + putMVar done () + atomicWriteIntArray mba 0 1 + putMVar latch () + takeMVar done + +-- | Create two threads that mutate the byte array passed to them +-- concurrently. The array is one word large. +race :: Int -- ^ Initial value of array element + -> (MByteArray -> IO ()) -- ^ Thread 1 action + -> (MByteArray -> IO ()) -- ^ Thread 2 action + -> IO Int -- ^ Final value of array element +race n0 thread1 thread2 = do + done1 <- newEmptyMVar + done2 <- newEmptyMVar + mba <- newByteArray (sizeOf (undefined :: Int)) + writeIntArray mba 0 n0 + forkIO $ thread1 mba >> putMVar done1 () + forkIO $ thread2 mba >> putMVar done2 () + mapM_ takeMVar [done1, done2] + readIntArray mba 0 + +------------------------------------------------------------------------ +-- Test helper + +assertEq :: (Eq a, Show a) => a -> a -> String -> IO () +assertEq expected actual name + | expected == actual = putStrLn $ name ++ ": OK" + | otherwise = do + putStrLn $ name ++ ": FAIL" + putStrLn $ "Expected: " ++ show expected + putStrLn $ " Actual: " ++ show actual + +------------------------------------------------------------------------ +-- Wrappers around MutableByteArray# + +data MByteArray = MBA (MutableByteArray# RealWorld) + +fetchAddIntArray :: MByteArray -> Int -> Int -> IO () +fetchAddIntArray (MBA mba#) (I# ix#) (I# n#) = IO $ \ s# -> + case fetchAddIntArray# mba# ix# n# s# of + (# s2#, _ #) -> (# s2#, () #) + +fetchSubIntArray :: MByteArray -> Int -> Int -> IO () +fetchSubIntArray (MBA mba#) (I# ix#) (I# n#) = IO $ \ s# -> + case fetchSubIntArray# mba# ix# n# s# of + (# s2#, _ #) -> (# s2#, () #) + +fetchAndIntArray :: MByteArray -> Int -> Int -> IO () +fetchAndIntArray (MBA mba#) (I# ix#) (I# n#) = IO $ \ s# -> + case fetchAndIntArray# mba# ix# n# s# of + (# s2#, _ #) -> (# s2#, () #) + +fetchNandIntArray :: MByteArray -> Int -> Int -> IO () +fetchNandIntArray (MBA mba#) (I# ix#) (I# n#) = IO $ \ s# -> + case fetchNandIntArray# mba# ix# n# s# of + (# s2#, _ #) -> (# s2#, () #) + +fetchOrIntArray :: MByteArray -> Int -> Int -> IO () +fetchOrIntArray (MBA mba#) (I# ix#) (I# n#) = IO $ \ s# -> + case fetchOrIntArray# mba# ix# n# s# of + (# s2#, _ #) -> (# s2#, () #) + +fetchXorIntArray :: MByteArray -> Int -> Int -> IO () +fetchXorIntArray (MBA mba#) (I# ix#) (I# n#) = IO $ \ s# -> + case fetchXorIntArray# mba# ix# n# s# of + (# s2#, _ #) -> (# s2#, () #) + +newByteArray :: Int -> IO MByteArray +newByteArray (I# n#) = IO $ \ s# -> + case newByteArray# n# s# of + (# s2#, mba# #) -> (# s2#, MBA mba# #) + +writeIntArray :: MByteArray -> Int -> Int -> IO () +writeIntArray (MBA mba#) (I# ix#) (I# n#) = IO $ \ s# -> + case writeIntArray# mba# ix# n# s# of + s2# -> (# s2#, () #) + +readIntArray :: MByteArray -> Int -> IO Int +readIntArray (MBA mba#) (I# ix#) = IO $ \ s# -> + case readIntArray# mba# ix# s# of + (# s2#, n# #) -> (# s2#, I# n# #) + +atomicWriteIntArray :: MByteArray -> Int -> Int -> IO () +atomicWriteIntArray (MBA mba#) (I# ix#) (I# n#) = IO $ \ s# -> + case atomicWriteIntArray# mba# ix# n# s# of + s2# -> (# s2#, () #) + +atomicReadIntArray :: MByteArray -> Int -> IO Int +atomicReadIntArray (MBA mba#) (I# ix#) = IO $ \ s# -> + case atomicReadIntArray# mba# ix# s# of + (# s2#, n# #) -> (# s2#, I# n# #) + +casIntArray :: MByteArray -> Int -> Int -> Int -> IO Int +casIntArray (MBA mba#) (I# ix#) (I# old#) (I# new#) = IO $ \ s# -> + case casIntArray# mba# ix# old# new# s# of + (# s2#, old2# #) -> (# s2#, I# old2# #) diff --git a/testsuite/tests/concurrent/should_run/AtomicPrimops.stdout b/testsuite/tests/concurrent/should_run/AtomicPrimops.stdout new file mode 100644 index 0000000000..c37041a040 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/AtomicPrimops.stdout @@ -0,0 +1,7 @@ +fetchAddSubTest: OK +fetchAndTest: OK +fetchNandTest: OK +fetchOrTest: OK +fetchXorTest: OK +casTest: OK +readWriteTest: OK diff --git a/testsuite/tests/concurrent/should_run/T9379.hs b/testsuite/tests/concurrent/should_run/T9379.hs new file mode 100644 index 0000000000..49e6d1eaed --- /dev/null +++ b/testsuite/tests/concurrent/should_run/T9379.hs @@ -0,0 +1,17 @@ +import Control.Exception +import Control.Concurrent +import Control.Concurrent.STM +import Foreign.StablePtr + +main :: IO () +main = do + tv <- atomically $ newTVar True + _ <- newStablePtr tv + t <- mask_ $ forkIO (blockSTM tv) + killThread t + +blockSTM :: TVar Bool -> IO () +blockSTM tv = do + atomically $ do + v <- readTVar tv + check $ not v diff --git a/testsuite/tests/concurrent/should_run/all.T b/testsuite/tests/concurrent/should_run/all.T index 0b502c3bc7..b43026a2ea 100644 --- a/testsuite/tests/concurrent/should_run/all.T +++ b/testsuite/tests/concurrent/should_run/all.T @@ -81,13 +81,19 @@ test('tryReadMVar1', normal, compile_and_run, ['']) test('tryReadMVar2', normal, compile_and_run, ['']) test('T7970', normal, compile_and_run, ['']) +test('AtomicPrimops', normal, compile_and_run, ['']) + +# test uses 2 threads and yield, scheduling can vary with threaded2 +test('threadstatus-9333', [omit_ways(['threaded2'])], compile_and_run, ['']) + +test('T9379', normal, compile_and_run, ['']) # ----------------------------------------------------------------------------- # These tests we only do for a full run def f( name, opts ): if config.fast: - opts.skip = 1 + opts.skip = 1 setTestOpts(f) diff --git a/testsuite/tests/concurrent/should_run/threadstatus-9333.hs b/testsuite/tests/concurrent/should_run/threadstatus-9333.hs new file mode 100644 index 0000000000..73cd6b895d --- /dev/null +++ b/testsuite/tests/concurrent/should_run/threadstatus-9333.hs @@ -0,0 +1,33 @@ +-- test for threadstatus, checking (mvar read, mvar block reasons) +-- created together with fixing GHC ticket #9333 + +module Main where + +import Control.Concurrent +import GHC.Conc +import GHC.Conc.Sync + +main = do + -- create MVars to block on + v1 <- newMVar "full" + v2 <- newEmptyMVar + -- create a thread which fills both MVars + parent <- myThreadId + putStrLn "p: forking child thread" + child <- forkIO $ + do putStrLn "c: filling full MVar" -- should block + putMVar v1 "filled full var" + yield + putStrLn "c: filling empty MVar (expect parent to be blocked)" + stat2 <- threadStatus parent + putStrLn ("c: parent is " ++ show stat2) + putMVar v2 "filled empty var" + yield + putStrLn "p: emptying full MVar (expect child to be blocked on it)" + stat1 <- threadStatus child + putStrLn ("p: child is " ++ show stat1) + s1 <- takeMVar v1 -- should unblock child + putStrLn ("p: from MVar: " ++ s1) + putStrLn "p: reading empty MVar" + s2 <- readMVar v2 -- should block + putStrLn ("p: from MVar: " ++ s2) diff --git a/testsuite/tests/concurrent/should_run/threadstatus-9333.stdout b/testsuite/tests/concurrent/should_run/threadstatus-9333.stdout new file mode 100644 index 0000000000..7b4f788615 --- /dev/null +++ b/testsuite/tests/concurrent/should_run/threadstatus-9333.stdout @@ -0,0 +1,9 @@ +p: forking child thread +c: filling full MVar +p: emptying full MVar (expect child to be blocked on it) +p: child is ThreadBlocked BlockedOnMVar +p: from MVar: full +p: reading empty MVar +c: filling empty MVar (expect parent to be blocked) +c: parent is ThreadBlocked BlockedOnMVar +p: from MVar: filled empty var diff --git a/testsuite/tests/cpranal/should_run/.gitignore b/testsuite/tests/cpranal/should_run/.gitignore deleted file mode 100644 index a4457dd566..0000000000 --- a/testsuite/tests/cpranal/should_run/.gitignore +++ /dev/null @@ -1 +0,0 @@ -CPRRepeat diff --git a/testsuite/tests/deSugar/should_run/.gitignore b/testsuite/tests/deSugar/should_run/.gitignore deleted file mode 100644 index b064d1b75c..0000000000 --- a/testsuite/tests/deSugar/should_run/.gitignore +++ /dev/null @@ -1 +0,0 @@ -T8952 diff --git a/testsuite/tests/deriving/should_compile/T4966.hs b/testsuite/tests/deriving/should_compile/T4966.hs index d7328c6ef6..363627a415 100644 --- a/testsuite/tests/deriving/should_compile/T4966.hs +++ b/testsuite/tests/deriving/should_compile/T4966.hs @@ -2,7 +2,6 @@ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE OverlappingInstances #-} module HTk.Toolkit.TreeList (getObjectFromTreeList) where @@ -10,7 +9,7 @@ class Eq c => CItem c -- A bizarre instance decl! -- People who use instance decls like this are asking for trouble -instance GUIObject w => Eq w where +instance {-# OVERLAPPABLE #-} GUIObject w => Eq w where w1 == w2 = toGUIObject w1 == toGUIObject w2 data StateEntry a @@ -31,7 +30,7 @@ getObjectFromTreeList state = state == state data CItem a => TreeListObject a -instance CItem a => Eq (TreeListObject a) +instance {-# OVERLAPPING #-} CItem a => Eq (TreeListObject a) class GUIObject w where toGUIObject :: w -> GUIOBJECT diff --git a/testsuite/tests/deriving/should_compile/T4966.stderr b/testsuite/tests/deriving/should_compile/T4966.stderr index d5cc4a24b2..dceeaa698f 100644 --- a/testsuite/tests/deriving/should_compile/T4966.stderr +++ b/testsuite/tests/deriving/should_compile/T4966.stderr @@ -2,7 +2,7 @@ T4966.hs:1:14: Warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. -T4966.hs:34:10: Warning: +T4966.hs:33:30: Warning: No explicit implementation for either ‘==’ or ‘/=’ In the instance declaration for ‘Eq (TreeListObject a)’ diff --git a/testsuite/tests/deriving/should_compile/T9359.hs b/testsuite/tests/deriving/should_compile/T9359.hs new file mode 100644 index 0000000000..313d66e1ca --- /dev/null +++ b/testsuite/tests/deriving/should_compile/T9359.hs @@ -0,0 +1,12 @@ +{-# Language GADTs, PolyKinds, TypeFamilies, DataKinds #-} +module Fam where + +data Cmp a where + Sup :: Cmp a + V :: a -> Cmp a + deriving (Show, Eq) + +data family CmpInterval (a :: Cmp k) (b :: Cmp k) :: * +data instance CmpInterval (V c) Sup = Starting c + deriving( Show ) + diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T index f440e8043e..af05006a88 100644 --- a/testsuite/tests/deriving/should_compile/all.T +++ b/testsuite/tests/deriving/should_compile/all.T @@ -51,3 +51,4 @@ test('T8950', expect_broken(8950), compile, ['']) test('T8963', normal, compile, ['']) test('T7269', normal, compile, ['']) test('T9069', normal, compile, ['']) +test('T9359', normal, compile, ['']) diff --git a/testsuite/tests/deriving/should_run/.gitignore b/testsuite/tests/deriving/should_run/.gitignore deleted file mode 100644 index 92ab843a46..0000000000 --- a/testsuite/tests/deriving/should_run/.gitignore +++ /dev/null @@ -1 +0,0 @@ -T8280 diff --git a/testsuite/tests/driver/.gitignore b/testsuite/tests/driver/.gitignore deleted file mode 100644 index e7a0aad655..0000000000 --- a/testsuite/tests/driver/.gitignore +++ /dev/null @@ -1 +0,0 @@ -T703 diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index c6332ea83c..40ddb4b66b 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -32,7 +32,6 @@ check title expected got expectedGhcOnlyExtensions :: [String] expectedGhcOnlyExtensions = ["RelaxedLayout", "AlternativeLayoutRule", - "BinaryLiterals", "AlternativeLayoutRuleTransitional", "JavaScriptFFI", "PatternSynonyms"] diff --git a/testsuite/tests/driver/T7835/.gitignore b/testsuite/tests/driver/T7835/.gitignore deleted file mode 100644 index 345e6aef71..0000000000 --- a/testsuite/tests/driver/T7835/.gitignore +++ /dev/null @@ -1 +0,0 @@ -Test diff --git a/testsuite/tests/driver/T8526/.gitignore b/testsuite/tests/driver/T8526/.gitignore deleted file mode 100644 index 42d2fab904..0000000000 --- a/testsuite/tests/driver/T8526/.gitignore +++ /dev/null @@ -1 +0,0 @@ -A.inc diff --git a/testsuite/tests/driver/T8602/.gitignore b/testsuite/tests/driver/T8602/.gitignore deleted file mode 100644 index f0f435cb1d..0000000000 --- a/testsuite/tests/driver/T8602/.gitignore +++ /dev/null @@ -1 +0,0 @@ -t8602.sh diff --git a/testsuite/tests/ffi/should_fail/T3066.stderr b/testsuite/tests/ffi/should_fail/T3066.stderr index 2bbaf629c7..e6d292d4ec 100644 --- a/testsuite/tests/ffi/should_fail/T3066.stderr +++ b/testsuite/tests/ffi/should_fail/T3066.stderr @@ -1,6 +1,7 @@ T3066.hs:6:1: - Unacceptable argument type in foreign declaration: forall u. Ptr () + Unacceptable argument type in foreign declaration: + ‘forall u. Ptr ()’ is not a data type When checking declaration: - foreign import ccall safe "static bla" bla - :: (forall u. X u) -> IO () + foreign import ccall safe "static bla" bla + :: (forall u. X u) -> IO () diff --git a/testsuite/tests/ffi/should_fail/T5664.stderr b/testsuite/tests/ffi/should_fail/T5664.stderr index 30bd017a1d..c1652c2288 100644 --- a/testsuite/tests/ffi/should_fail/T5664.stderr +++ b/testsuite/tests/ffi/should_fail/T5664.stderr @@ -1,13 +1,16 @@ T5664.hs:15:1: Unacceptable argument type in foreign declaration: - FunPtr (D -> IO ()) + Expected: Ptr/FunPtr (Int32 -> IO ()), + Actual: FunPtr (D -> IO ()) When checking declaration: foreign import ccall safe "dynamic" mkFun3 :: FunPtr (D -> IO ()) -> CInt -> IO () T5664.hs:24:1: - Unacceptable result type in foreign declaration: IO (FunPtr (IO D)) + Unacceptable result type in foreign declaration: + Expected: Ptr/FunPtr (IO Int32), + Actual: FunPtr (IO D) When checking declaration: foreign import ccall safe "wrapper" mkCallBack3 :: IO CInt -> IO (FunPtr (IO D)) diff --git a/testsuite/tests/ffi/should_fail/T7506.stderr b/testsuite/tests/ffi/should_fail/T7506.stderr index e8e95a9275..dd893df155 100644 --- a/testsuite/tests/ffi/should_fail/T7506.stderr +++ b/testsuite/tests/ffi/should_fail/T7506.stderr @@ -1,7 +1,8 @@ T7506.hs:6:1: - Unacceptable type in foreign declaration: Int -> IO () - A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a) + Unacceptable type in foreign declaration: + ‘Int -> IO ()’ cannot be marshalled in a foreign call + A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a) When checking declaration: foreign import ccall safe "static stdio.h &putchar" c_putchar :: Int -> IO () diff --git a/testsuite/tests/ffi/should_fail/ccfail001.stderr b/testsuite/tests/ffi/should_fail/ccfail001.stderr index 813c5d187c..e890041b02 100644 --- a/testsuite/tests/ffi/should_fail/ccfail001.stderr +++ b/testsuite/tests/ffi/should_fail/ccfail001.stderr @@ -1,6 +1,7 @@ ccfail001.hs:10:1: - Unacceptable result type in foreign declaration: State# RealWorld + Unacceptable result type in foreign declaration: + ‘State# RealWorld’ cannot be marshalled in a foreign call When checking declaration: - foreign import ccall safe "static foo" foo - :: Int -> State# RealWorld + foreign import ccall safe "static foo" foo + :: Int -> State# RealWorld diff --git a/testsuite/tests/ffi/should_fail/ccfail002.stderr b/testsuite/tests/ffi/should_fail/ccfail002.stderr index dfff4272cd..309fa521d2 100644 --- a/testsuite/tests/ffi/should_fail/ccfail002.stderr +++ b/testsuite/tests/ffi/should_fail/ccfail002.stderr @@ -1,7 +1,7 @@ ccfail002.hs:10:1: Unacceptable result type in foreign declaration: - (# Int#, Int#, Int# #) + ‘(# Int#, Int#, Int# #)’ cannot be marshalled in a foreign call When checking declaration: - foreign import ccall unsafe "static foo" foo - :: Int# -> Int# -> Int# -> (# Int#, Int#, Int# #) + foreign import ccall unsafe "static foo" foo + :: Int# -> Int# -> Int# -> (# Int#, Int#, Int# #) diff --git a/testsuite/tests/ffi/should_fail/ccfail003.stderr b/testsuite/tests/ffi/should_fail/ccfail003.stderr index 4ce9db572d..6afdd7678f 100644 --- a/testsuite/tests/ffi/should_fail/ccfail003.stderr +++ b/testsuite/tests/ffi/should_fail/ccfail003.stderr @@ -1,10 +1,12 @@ ccfail003.hs:7:1: - Unacceptable argument type in foreign declaration: Int# + Unacceptable argument type in foreign declaration: + ‘Int#’ cannot be marshalled in a foreign call When checking declaration: foreign export ccall "foo" foo :: Int# -> IO () ccfail003.hs:10:1: - Unacceptable result type in foreign declaration: Int# + Unacceptable result type in foreign declaration: + ‘Int#’ cannot be marshalled in a foreign call When checking declaration: foreign export ccall "bar" bar :: Int -> Int# diff --git a/testsuite/tests/ffi/should_fail/ccfail004.stderr b/testsuite/tests/ffi/should_fail/ccfail004.stderr index cce4258911..f54ac91aa3 100644 --- a/testsuite/tests/ffi/should_fail/ccfail004.stderr +++ b/testsuite/tests/ffi/should_fail/ccfail004.stderr @@ -1,26 +1,36 @@ - ccfail004.hs:9:1: - Unacceptable argument type in foreign declaration: NInt + Unacceptable argument type in foreign declaration: + ‘NInt’ cannot be marshalled in a foreign call + because its data construtor is not in scope + Possible fix: import the data constructor to bring it into scope When checking declaration: foreign import ccall safe "static f1" f1 :: NInt -> IO Int ccfail004.hs:10:1: - Unacceptable result type in foreign declaration: IO NInt + Unacceptable result type in foreign declaration: + ‘NInt’ cannot be marshalled in a foreign call + because its data construtor is not in scope + Possible fix: import the data constructor to bring it into scope When checking declaration: foreign import ccall safe "static f2" f2 :: Int -> IO NInt ccfail004.hs:11:1: - Unacceptable result type in foreign declaration: NIO Int + Unacceptable result type in foreign declaration: + ‘NIO Int’ cannot be marshalled in a foreign call + because the data construtor for ‘NIO’ is not in scope + Possible fix: import the data constructor to bring it into scope When checking declaration: foreign import ccall safe "static f3" f3 :: Int -> NIO Int ccfail004.hs:14:1: - Unacceptable argument type in foreign declaration: [NT] + Unacceptable argument type in foreign declaration: + ‘[NT]’ cannot be marshalled in a foreign call When checking declaration: foreign import ccall safe "static f4" f4 :: NT -> IO () ccfail004.hs:15:1: - Unacceptable result type in foreign declaration: IO [NT] + Unacceptable result type in foreign declaration: + ‘[NT]’ cannot be marshalled in a foreign call When checking declaration: foreign import ccall safe "static f5" f5 :: IO NT diff --git a/testsuite/tests/ffi/should_fail/ccfail005.stderr b/testsuite/tests/ffi/should_fail/ccfail005.stderr index 0d96fe91e3..413faa702c 100644 --- a/testsuite/tests/ffi/should_fail/ccfail005.stderr +++ b/testsuite/tests/ffi/should_fail/ccfail005.stderr @@ -1,10 +1,12 @@ ccfail005.hs:14:1: - Unacceptable argument type in foreign declaration: D + Unacceptable argument type in foreign declaration: + ‘D’ cannot be marshalled in a foreign call When checking declaration: foreign import ccall safe "static f1" f1 :: F Bool ccfail005.hs:15:1: - Unacceptable result type in foreign declaration: IO D + Unacceptable result type in foreign declaration: + ‘D’ cannot be marshalled in a foreign call When checking declaration: foreign import ccall safe "static f2" f2 :: F Char diff --git a/testsuite/tests/ffi/should_run/.gitignore b/testsuite/tests/ffi/should_run/.gitignore deleted file mode 100644 index d1b3f8850e..0000000000 --- a/testsuite/tests/ffi/should_run/.gitignore +++ /dev/null @@ -1 +0,0 @@ -T8083 diff --git a/testsuite/tests/gadt/T9380.hs b/testsuite/tests/gadt/T9380.hs new file mode 100644 index 0000000000..ebc02178f1 --- /dev/null +++ b/testsuite/tests/gadt/T9380.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +module Main where + +import Foreign +import Unsafe.Coerce + +data M = A | B deriving (Show, Eq) + +newtype S (a :: M) = S Int + +data SomeS = forall a . SomeS (S a) + +data V0 :: M -> * where + V0A :: Int -> V0 A + V0B :: Double -> V0 B + +data V1 :: M -> * where + V1A :: Int -> V1 A + V1B :: Double -> V1 B + V1a :: () -> V1 a + +viewV0 :: S a -> V0 a +viewV0 (S i) + | even i = unsafeCoerce $ V0A 1 + | otherwise = unsafeCoerce $ V0B 2 + +viewV1 :: S a -> V1 a +viewV1 (S i) + | even i = unsafeCoerce $ V1A 1 + | otherwise = unsafeCoerce $ V1B 2 + + +typeOf :: S a -> M +typeOf (S i) = if even i then A else B + +cast :: M -> SomeS -> S a +cast ty (SomeS s@(S i)) + | ty == typeOf s = S i + | otherwise = error "cast" + +test0 :: IO () +test0 = + let s = cast A (SomeS (S 0)) + in case viewV0 s of + V0A{} -> putStrLn "test0 - A" + V0B{} -> putStrLn "test0 - B" + +test1 :: IO () +test1 = + let s = cast A (SomeS (S 2)) :: S A + in case viewV0 s of + V0A{} -> putStrLn "test1 - A" + +test2 :: IO () +test2 = + let s = cast A (SomeS (S 4)) + in case viewV1 s of + V1A{} -> putStrLn "test2 - A" + V1B{} -> putStrLn "test2 - B" + V1a{} -> putStrLn "test2 - O_o" + +main = do + test0 -- no ouput at all + test1 -- A + test2 -- O_o
\ No newline at end of file diff --git a/testsuite/tests/gadt/T9380.stdout b/testsuite/tests/gadt/T9380.stdout new file mode 100644 index 0000000000..0a5a466ebc --- /dev/null +++ b/testsuite/tests/gadt/T9380.stdout @@ -0,0 +1,3 @@ +test0 - A +test1 - A +test2 - A diff --git a/testsuite/tests/gadt/all.T b/testsuite/tests/gadt/all.T index 52a8812377..315ecb697d 100644 --- a/testsuite/tests/gadt/all.T +++ b/testsuite/tests/gadt/all.T @@ -40,7 +40,7 @@ test('gadt23', test('gadt24', normal, compile, ['']) test('red-black', normal, compile, ['']) -test('type-rep', [ when(fast(), skip), when(compiler_debugged(),expect_broken_for(8569, ['hpc','optasm','threaded2','dyn','optllvm'])) ] , compile_and_run, ['']) +test('type-rep', when(fast(), skip), compile_and_run, ['']) test('equal', normal, compile, ['']) test('nbe', normal, compile, ['']) test('while', normal, compile_and_run, ['']) @@ -123,3 +123,4 @@ test('T7321', test('T7974', normal, compile, ['']) test('T7558', normal, compile_fail, ['']) test('T9096', normal, compile, ['']) +test('T9380', normal, compile_and_run, ['']) diff --git a/testsuite/tests/generics/Uniplate/GUniplate.hs b/testsuite/tests/generics/Uniplate/GUniplate.hs index 76f387d636..99b0b405a8 100644 --- a/testsuite/tests/generics/Uniplate/GUniplate.hs +++ b/testsuite/tests/generics/Uniplate/GUniplate.hs @@ -4,7 +4,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE IncoherentInstances #-} -- necessary, unfortunately +{- # LANGUAGE IncoherentInstances #-} -- necessary, unfortunately +{-# LANGUAGE OverlappingInstances #-} module GUniplate where @@ -20,7 +21,8 @@ class Uniplate' f b where instance Uniplate' U1 a where children' U1 = [] -instance Uniplate' (K1 i a) a where +instance {-# OVERLAPPING #-} Uniplate' (K1 i a) a where + -- overlaps the (Uniplate' (K1 i a) b) instance children' (K1 a) = [a] instance Uniplate' (K1 i a) b where diff --git a/testsuite/tests/ghc-api/.gitignore b/testsuite/tests/ghc-api/.gitignore deleted file mode 100644 index f52a1f92e9..0000000000 --- a/testsuite/tests/ghc-api/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -T8628 -T8639_api -T6145 diff --git a/testsuite/tests/ghc-api/T7478/T7478.hs b/testsuite/tests/ghc-api/T7478/T7478.hs index 15c3559f7d..dc6edb21a8 100644 --- a/testsuite/tests/ghc-api/T7478/T7478.hs +++ b/testsuite/tests/ghc-api/T7478/T7478.hs @@ -9,7 +9,7 @@ import GHC import qualified Config as GHC import qualified Outputable as GHC import GhcMonad (liftIO) -import Outputable (PprStyle, qualName, qualModule) +import Outputable (PprStyle, queryQual) compileInGhc :: [FilePath] -- ^ Targets -> (String -> IO ()) -- ^ handler for each SevOutput message @@ -42,7 +42,7 @@ compileInGhc targets handlerOutput = do _ -> error "fileFromTarget: not a known target" collectSrcError handlerOutput flags SevOutput _srcspan style msg - = handlerOutput $ GHC.showSDocForUser flags (qualName style,qualModule style) msg + = handlerOutput $ GHC.showSDocForUser flags (queryQual style) msg collectSrcError _ _ _ _ _ _ = return () diff --git a/testsuite/tests/ghc-e/should_run/Makefile b/testsuite/tests/ghc-e/should_run/Makefile index 1971004d4c..5ed1ec2e6c 100644 --- a/testsuite/tests/ghc-e/should_run/Makefile +++ b/testsuite/tests/ghc-e/should_run/Makefile @@ -30,3 +30,5 @@ T3890: T7299: '$(TEST_HC)' $(TEST_HC_OPTS) -ignore-dot-ghci -e "Control.Concurrent.threadDelay (1000 * 1000)" +T9086: + '$(TEST_HC)' $(TEST_HC_OPTS) -ignore-dot-ghci -e ":main" T9086.hs diff --git a/testsuite/tests/ghc-e/should_run/T9086.hs b/testsuite/tests/ghc-e/should_run/T9086.hs new file mode 100644 index 0000000000..a2b4ace33a --- /dev/null +++ b/testsuite/tests/ghc-e/should_run/T9086.hs @@ -0,0 +1 @@ +main = return "this should not be printed" diff --git a/testsuite/tests/ghc-e/should_run/all.T b/testsuite/tests/ghc-e/should_run/all.T index 4ab7567358..9f6491819d 100644 --- a/testsuite/tests/ghc-e/should_run/all.T +++ b/testsuite/tests/ghc-e/should_run/all.T @@ -14,3 +14,4 @@ test('T2228', test('T2636', req_interp, run_command, ['$MAKE --no-print-directory -s T2636']) test('T3890', req_interp, run_command, ['$MAKE --no-print-directory -s T3890']) test('T7299', req_interp, run_command, ['$MAKE --no-print-directory -s T7299']) +test('T9086', req_interp, run_command, ['$MAKE --no-print-directory -s T9086']) diff --git a/testsuite/tests/ghci.debugger/scripts/print019.stderr b/testsuite/tests/ghci.debugger/scripts/print019.stderr index e6a9159836..e364f06f03 100644 --- a/testsuite/tests/ghci.debugger/scripts/print019.stderr +++ b/testsuite/tests/ghci.debugger/scripts/print019.stderr @@ -5,8 +5,8 @@ Use :print or :force to determine these types Relevant bindings include it :: a1 (bound at <interactive>:11:1) Note: there are several potential instances: - instance Show a => Show (List1 a) -- Defined at ../Test.hs:11:12 - instance Show MyInt -- Defined at ../Test.hs:14:16 + instance Show Unary -- Defined at ../Test.hs:37:29 + instance Show a => Show (MkT2 a) -- Defined at ../Test.hs:20:12 instance Show a => Show (MkT a) -- Defined at ../Test.hs:17:13 ...plus 31 others In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/ghci/linking/Makefile b/testsuite/tests/ghci/linking/Makefile index 60cb9cbfda..08c5158acc 100644 --- a/testsuite/tests/ghci/linking/Makefile +++ b/testsuite/tests/ghci/linking/Makefile @@ -60,6 +60,7 @@ ghcilink004 : echo 'name: test' >>$(PKG004) echo 'version: 1.0' >>$(PKG004) echo 'id: test-XXX' >>$(PKG004) + echo 'key: test-1.0' >>$(PKG004) echo 'library-dirs: $${pkgroot}' >>$(PKG004) echo 'extra-libraries: foo' >>$(PKG004) echo '[]' >$(LOCAL_PKGCONF004) @@ -87,6 +88,7 @@ ghcilink005 : echo 'name: test' >>$(PKG005) echo 'version: 1.0' >>$(PKG005) echo 'id: test-XXX' >>$(PKG005) + echo 'key: test-1.0' >>$(PKG005) echo 'library-dirs: $${pkgroot}' >>$(PKG005) echo 'extra-libraries: foo' >>$(PKG005) echo '[]' >$(LOCAL_PKGCONF005) @@ -111,6 +113,7 @@ ghcilink006 : echo "name: test" >>$(PKG006) echo "version: 1.0" >>$(PKG006) echo "id: test-XXX" >>$(PKG006) + echo "key: test-1.0" >>$(PKG006) echo "extra-libraries: stdc++" >>$(PKG006) echo "[]" >$(LOCAL_PKGCONF006) '$(GHC_PKG)' --no-user-package-db -f $(LOCAL_PKGCONF006) register $(PKG006) -v0 diff --git a/testsuite/tests/ghci/prog007/C.hs b/testsuite/tests/ghci/prog007/C.hs index 8273d6bdda..a66d000e8e 100644 --- a/testsuite/tests/ghci/prog007/C.hs +++ b/testsuite/tests/ghci/prog007/C.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverlappingInstances #-} - module C where import A diff --git a/testsuite/tests/ghci/scripts/.gitignore b/testsuite/tests/ghci/scripts/.gitignore deleted file mode 100644 index d1b7ce25f3..0000000000 --- a/testsuite/tests/ghci/scripts/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -föøbà r1.hs -föøbà r2.hs diff --git a/testsuite/tests/ghci/scripts/T5979.stderr b/testsuite/tests/ghci/scripts/T5979.stderr index fe6e012603..bbdba12305 100644 --- a/testsuite/tests/ghci/scripts/T5979.stderr +++ b/testsuite/tests/ghci/scripts/T5979.stderr @@ -1,4 +1,7 @@ <no location info>: Could not find module ‘Control.Monad.Trans.State’ - It is not a module in the current program, or in any known package. + Perhaps you meant + Control.Monad.Trans.State (from transformers-0.4.1.0@trans_ATJ404cg3uBDx7JJZaSn1I) + Control.Monad.Trans.Class (from transformers-0.4.1.0@trans_ATJ404cg3uBDx7JJZaSn1I) + Control.Monad.Trans.Cont (from transformers-0.4.1.0@trans_ATJ404cg3uBDx7JJZaSn1I) diff --git a/testsuite/tests/ghci/scripts/T9086b.script b/testsuite/tests/ghci/scripts/T9086b.script new file mode 100644 index 0000000000..d60156ad02 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T9086b.script @@ -0,0 +1,2 @@ +let main = do { putStrLn "hello"; return "discarded" } +:main diff --git a/testsuite/tests/ghci/scripts/T9086b.stdout b/testsuite/tests/ghci/scripts/T9086b.stdout new file mode 100644 index 0000000000..ce01362503 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T9086b.stdout @@ -0,0 +1 @@ +hello diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T index b71dfd14ce..d5a313a328 100755 --- a/testsuite/tests/ghci/scripts/all.T +++ b/testsuite/tests/ghci/scripts/all.T @@ -61,6 +61,7 @@ test('ghci041', normal, ghci_script, ['ghci041.script']) test('ghci042', normal, ghci_script, ['ghci042.script']) test('ghci043', normal, ghci_script, ['ghci043.script']) test('ghci044', normal, ghci_script, ['ghci044.script']) +test('ghci044a', normal, ghci_script, ['ghci044a.script']) test('ghci045', normal, ghci_script, ['ghci045.script']) test('ghci046', normal, ghci_script, ['ghci046.script']) test('ghci047', normal, ghci_script, ['ghci047.script']) @@ -175,3 +176,4 @@ test('T8931', normal, ghci_script, ['T8931.script']) test('T8959', normal, ghci_script, ['T8959.script']) test('T8959b', expect_broken(8959), ghci_script, ['T8959b.script']) test('T9181', normal, ghci_script, ['T9181.script']) +test('T9086b', normal, ghci_script, ['T9086b.script']) diff --git a/testsuite/tests/ghci/scripts/ghci044.script b/testsuite/tests/ghci/scripts/ghci044.script index 7af66bb935..d6f12ada6e 100644 --- a/testsuite/tests/ghci/scripts/ghci044.script +++ b/testsuite/tests/ghci/scripts/ghci044.script @@ -1,10 +1,15 @@ --Testing flexible and Overlapping instances -class C a where { f :: a -> Int; f _ = 3 } -instance C Int where { f = id } -instance C [Int] +class C a where { f :: a -> String; f _ = "Default" } +instance C Int where { f _ = "Zeroth" } :set -XFlexibleInstances -instance C [Int] -instance C a => C [a] where f xs = length xs --- ***This should be an overlapping instances error!*** -:set -XOverlappingInstances -instance C a => C [a] where f xs = length xs +instance C [Int] where f _ = "First" +f [3::Int] +instance C a => C [a] where f xs = "Second" +f [4::Int] -- ***This should be an overlapping instances error!*** +instance {-# OVERLAPPABLE #-} C a => C [a] where f xs = "Third" +f [5::Int] -- Should be fine +instance {-# OVERLAPPABLE #-} C a => C [a] where f xs = "Fourth" +f [6::Int] -- Should be fine too, overrides +instance C Bool where { f _ = "Bool" } +f [True] -- Should be fine too, overrides + diff --git a/testsuite/tests/ghci/scripts/ghci044.stderr b/testsuite/tests/ghci/scripts/ghci044.stderr index c319dd1f1c..9bc8df9994 100644 --- a/testsuite/tests/ghci/scripts/ghci044.stderr +++ b/testsuite/tests/ghci/scripts/ghci044.stderr @@ -1,13 +1,8 @@ -<interactive>:5:10: - Illegal instance declaration for ‘C [Int]’ - (All instance types must be of the form (T a1 ... an) - where a1 ... an are *distinct type variables*, - and each type variable appears at most once in the instance head. - Use FlexibleInstances if you want to disable this.) - In the instance declaration for ‘C [Int]’ - -<interactive>:7:10: - Overlapping instance declarations: - instance C [Int] -- Defined at <interactive>:7:10 +<interactive>:9:1: + Overlapping instances for C [Int] arising from a use of ‘f’ + Matching instances: + instance C [Int] -- Defined at <interactive>:6:10 instance C a => C [a] -- Defined at <interactive>:8:10 + In the expression: f [4 :: Int] + In an equation for ‘it’: it = f [4 :: Int] diff --git a/testsuite/tests/ghci/scripts/ghci044.stdout b/testsuite/tests/ghci/scripts/ghci044.stdout new file mode 100644 index 0000000000..eadd22f710 --- /dev/null +++ b/testsuite/tests/ghci/scripts/ghci044.stdout @@ -0,0 +1,4 @@ +"First"
+"First"
+"First"
+"Fourth"
diff --git a/testsuite/tests/ghci/scripts/ghci044a.hs b/testsuite/tests/ghci/scripts/ghci044a.hs new file mode 100644 index 0000000000..ac400d3ef9 --- /dev/null +++ b/testsuite/tests/ghci/scripts/ghci044a.hs @@ -0,0 +1,9 @@ +--Testing flexible and Overlapping instances +class C a where { f :: a -> String; f _ = 3 } +instance C Int where { f = id } +:set -XFlexibleInstances +instance C [Int] where f _ = "First" +f [3::Int] +-- Should override the identical one preceding +instance C [Int] where f _ = "Second" +f [3::Int] diff --git a/testsuite/tests/ghci/scripts/ghci044a.script b/testsuite/tests/ghci/scripts/ghci044a.script new file mode 100644 index 0000000000..d78c5c25bc --- /dev/null +++ b/testsuite/tests/ghci/scripts/ghci044a.script @@ -0,0 +1,9 @@ +--Testing flexible and Overlapping instances +class C a where { f :: a -> String; f _ = "Default" } +instance C Int where { f _ = "Zeroth" } +:set -XFlexibleInstances +instance C [Int] where f _ = "First" +f [3::Int] +-- Should override the identical one preceding +instance C [Int] where f _ = "Second" +f [3::Int] diff --git a/testsuite/tests/ghci/scripts/ghci044a.stdout b/testsuite/tests/ghci/scripts/ghci044a.stdout new file mode 100644 index 0000000000..fe475f4745 --- /dev/null +++ b/testsuite/tests/ghci/scripts/ghci044a.stdout @@ -0,0 +1,2 @@ +"First" +"Second" diff --git a/testsuite/tests/ghci/scripts/ghci047.script b/testsuite/tests/ghci/scripts/ghci047.script index 49d93047f6..70cc5181d8 100644 --- a/testsuite/tests/ghci/scripts/ghci047.script +++ b/testsuite/tests/ghci/scripts/ghci047.script @@ -1,7 +1,6 @@ --Testing GADTs, type families as well as a ton of crazy type stuff :set -XGADTs :set -XTypeFamilies -:set -XOverlappingInstances :set -XFunctionalDependencies :set -XFlexibleContexts :set -XFlexibleInstances @@ -22,8 +21,9 @@ data HTrue data HFalse class TypeEq x y b | x y -> b -instance (HTrue ~ b) => TypeEq x x b -instance (HFalse ~ b) => TypeEq x y b +instance {-# OVERLAPS #-} (HTrue ~ b) => TypeEq x x b +instance {-# OVERLAPS #-} (HTrue ~ b) => TypeEq x x b +instance {-# OVERLAPS #-} (HFalse ~ b) => TypeEq x y b type family Or a b type instance Or HTrue HTrue = HTrue diff --git a/testsuite/tests/indexed-types/should_compile/Gentle.hs b/testsuite/tests/indexed-types/should_compile/Gentle.hs index 6cc1512a1f..7ceedfd098 100644 --- a/testsuite/tests/indexed-types/should_compile/Gentle.hs +++ b/testsuite/tests/indexed-types/should_compile/Gentle.hs @@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, - OverlappingInstances, UndecidableInstances #-} + UndecidableInstances #-} -- Rather exotic example posted to Haskell mailing list 17 Oct 07 -- It concerns context reduction and functional dependencies diff --git a/testsuite/tests/indexed-types/should_compile/IndTypesPerfMerge.hs b/testsuite/tests/indexed-types/should_compile/IndTypesPerfMerge.hs index dbba60d595..e37bfe323e 100644 --- a/testsuite/tests/indexed-types/should_compile/IndTypesPerfMerge.hs +++ b/testsuite/tests/indexed-types/should_compile/IndTypesPerfMerge.hs @@ -1,5 +1,5 @@ {-# LANGUAGE EmptyDataDecls, TypeFamilies, UndecidableInstances, - ScopedTypeVariables, OverlappingInstances, TypeOperators, + ScopedTypeVariables, TypeOperators, FlexibleInstances, NoMonomorphismRestriction, MultiParamTypeClasses, FlexibleContexts #-} module IndTypesPerfMerge where diff --git a/testsuite/tests/indexed-types/should_compile/NonLinearLHS.hs b/testsuite/tests/indexed-types/should_compile/NonLinearLHS.hs index dc0ae5392a..26ea632a29 100644 --- a/testsuite/tests/indexed-types/should_compile/NonLinearLHS.hs +++ b/testsuite/tests/indexed-types/should_compile/NonLinearLHS.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TypeFamilies, EmptyDataDecls, FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances, OverlappingInstances, UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} module NonLinearLHS where diff --git a/testsuite/tests/indexed-types/should_compile/T9316.hs b/testsuite/tests/indexed-types/should_compile/T9316.hs new file mode 100644 index 0000000000..b5dfca6a94 --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/T9316.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} + +module SingletonsBug where + +import Control.Applicative +import Data.Traversable (for) +import GHC.Exts( Constraint ) + +----------------------------------- +-- From 'constraints' library +-- import Data.Constraint (Dict(..)) +data Dict :: Constraint -> * where + Dict :: a => Dict a + +----------------------------------- +-- From 'singletons' library +-- import Data.Singletons hiding( withSomeSing ) + +class SingI (a :: k) where + -- | Produce the singleton explicitly. You will likely need the @ScopedTypeVariables@ + -- extension to use this method the way you want. + sing :: Sing a + +data family Sing (a :: k) + +data KProxy (a :: *) = KProxy + +data SomeSing (kproxy :: KProxy k) where + SomeSing :: Sing (a :: k) -> SomeSing ('KProxy :: KProxy k) + +-- SingKind :: forall k. KProxy k -> Constraint +class (kparam ~ 'KProxy) => SingKind (kparam :: KProxy k) where + -- | Get a base type from a proxy for the promoted kind. For example, + -- @DemoteRep ('KProxy :: KProxy Bool)@ will be the type @Bool@. + type DemoteRep kparam :: * + + -- | Convert a singleton to its unrefined version. + fromSing :: Sing (a :: k) -> DemoteRep kparam + + -- | Convert an unrefined type to an existentially-quantified singleton type. + toSing :: DemoteRep kparam -> SomeSing kparam + +withSomeSing :: SingKind ('KProxy :: KProxy k) + => DemoteRep ('KProxy :: KProxy k) + -> (forall (a :: k). Sing a -> r) + -> r +withSomeSing = error "urk" + +----------------------------------- + +data SubscriptionChannel = BookingsChannel +type BookingsChannelSym0 = BookingsChannel +data instance Sing (z_a5I7 :: SubscriptionChannel) where + SBookingsChannel :: Sing BookingsChannel + +instance SingKind ('KProxy :: KProxy SubscriptionChannel) where + type DemoteRep ('KProxy :: KProxy SubscriptionChannel) = SubscriptionChannel + fromSing SBookingsChannel = BookingsChannel + toSing BookingsChannel = SomeSing SBookingsChannel + +instance SingI BookingsChannel where + sing = SBookingsChannel + +type family T (c :: SubscriptionChannel) :: * +type instance T 'BookingsChannel = Bool + +witnessC :: Sing channel -> Dict (Show (T channel), SingI channel) +witnessC SBookingsChannel = Dict + +forAllSubscriptionChannels + :: forall m r. (Applicative m) + => (forall channel. (SingI channel, Show (T channel)) => Sing channel -> m r) + -> m r +forAllSubscriptionChannels f = + withSomeSing BookingsChannel $ \(sChannel) -> + case witnessC sChannel of + Dict -> f sChannel + diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T index 7c41be8afb..016444a138 100644 --- a/testsuite/tests/indexed-types/should_compile/all.T +++ b/testsuite/tests/indexed-types/should_compile/all.T @@ -244,3 +244,4 @@ test('T8913', normal, compile, ['']) test('T8978', normal, compile, ['']) test('T8979', normal, compile, ['']) test('T9085', normal, compile, ['']) +test('T9316', normal, compile, ['']) diff --git a/testsuite/tests/indexed-types/should_fail/Overlap4.stderr b/testsuite/tests/indexed-types/should_fail/Overlap4.stderr index d64036c4bc..d1622335d8 100644 --- a/testsuite/tests/indexed-types/should_fail/Overlap4.stderr +++ b/testsuite/tests/indexed-types/should_fail/Overlap4.stderr @@ -1,5 +1,4 @@ Overlap4.hs:7:3: Number of parameters must match family declaration; expected 2 - In the equations for closed type family ‘F’ In the type family declaration for ‘F’ diff --git a/testsuite/tests/indexed-types/should_fail/Overlap5.stderr b/testsuite/tests/indexed-types/should_fail/Overlap5.stderr index 3adf2f3c3e..a889145036 100644 --- a/testsuite/tests/indexed-types/should_fail/Overlap5.stderr +++ b/testsuite/tests/indexed-types/should_fail/Overlap5.stderr @@ -1,5 +1,6 @@ Overlap5.hs:8:3: - Mismatched type names in closed type family declaration. - First name was F; this one is G - In the family declaration for ‘F’ + Mismatched type name in type family instance. + Expected: F + Actual: G + In the type family declaration for ‘F’ diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail1a.stderr b/testsuite/tests/indexed-types/should_fail/SimpleFail1a.stderr index 8318927522..f57af3908b 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail1a.stderr +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail1a.stderr @@ -1,4 +1,4 @@ SimpleFail1a.hs:4:1: - Couldn't match kind ‘* -> *’ against ‘*’ + Number of parameters must match family declaration; expected 2 In the data instance declaration for ‘T1’ diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail1b.stderr b/testsuite/tests/indexed-types/should_fail/SimpleFail1b.stderr index e1059a430b..3ecd31a003 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail1b.stderr +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail1b.stderr @@ -1,4 +1,4 @@ SimpleFail1b.hs:4:1: - Number of parameters must match family declaration; expected no more than 2 + Number of parameters must match family declaration; expected 2 In the data instance declaration for ‘T1’ diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail4.stderr b/testsuite/tests/indexed-types/should_fail/SimpleFail4.stderr index 91a3eb282a..8c4c743a56 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail4.stderr +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail4.stderr @@ -1,6 +1,6 @@ -SimpleFail4.hs:8:8: - Type indexes must match class instance head - Found ‘Int’ but expected ‘a’ - In the type synonym instance default declaration for ‘S2’ - In the class declaration for ‘C2’ +SimpleFail4.hs:8:11: + Unexpected type ‘Int’ + In the default declaration for ‘S2’ + A default declaration should have form + default S2 a = ... diff --git a/testsuite/tests/indexed-types/should_fail/T4246.hs b/testsuite/tests/indexed-types/should_fail/T4246.hs index b5c37a68e3..60b56405ad 100644 --- a/testsuite/tests/indexed-types/should_fail/T4246.hs +++ b/testsuite/tests/indexed-types/should_fail/T4246.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE TypeFamilies, FlexibleInstances, OverlappingInstances #-}
+{-# LANGUAGE TypeFamilies, FlexibleInstances #-}
module T4246 where
class Stupid a where
type F a
-instance Stupid a where
+instance {-# OVERLAPPABLE #-} Stupid a where
type F a = a
-instance Stupid Int where
+instance {-# OVERLAPPING #-} Stupid Int where
type F Int = Bool
type family G a :: *
diff --git a/testsuite/tests/indexed-types/should_fail/T4485.hs b/testsuite/tests/indexed-types/should_fail/T4485.hs index b48e8206f2..d7d4730362 100644 --- a/testsuite/tests/indexed-types/should_fail/T4485.hs +++ b/testsuite/tests/indexed-types/should_fail/T4485.hs @@ -11,7 +11,6 @@ {-# LANGUAGE TypeFamilies, MultiParamTypeClasses , FlexibleContexts, FlexibleInstances, UndecidableInstances , TypeSynonymInstances, GeneralizedNewtypeDeriving - , OverlappingInstances #-} module XMLGenerator where @@ -26,9 +25,9 @@ class Monad m => XMLGen m where class XMLGen m => EmbedAsChild m c where asChild :: c -> XMLGenT m [Child m] -instance (EmbedAsChild m c, m1 ~ m) => EmbedAsChild m (XMLGenT m1 c) +instance {-# OVERLAPPING #-} (EmbedAsChild m c, m1 ~ m) => EmbedAsChild m (XMLGenT m1 c) -instance (XMLGen m, XML m ~ x) => EmbedAsChild m x +instance {-# OVERLAPPABLE #-} (XMLGen m, XML m ~ x) => EmbedAsChild m x data Xml = Xml data IdentityT m a = IdentityT (m a) @@ -39,11 +38,11 @@ instance XMLGen (IdentityT m) where data Identity a = Identity a instance Monad Identity -instance EmbedAsChild (IdentityT IO) (XMLGenT Identity ()) +instance {-# OVERLAPPING #-} EmbedAsChild (IdentityT IO) (XMLGenT Identity ()) data FooBar = FooBar -instance EmbedAsChild (IdentityT IO) FooBar where +instance {-# OVERLAPPING #-} EmbedAsChild (IdentityT IO) FooBar where asChild b = asChild $ (genElement "foo") -- asChild :: FooBar -> XMLGenT (XMLGenT (IdentityT IO) [Child (IdentitiyT IO)]) diff --git a/testsuite/tests/indexed-types/should_fail/T4485.stderr b/testsuite/tests/indexed-types/should_fail/T4485.stderr index b2bd626d20..760cdf912d 100644 --- a/testsuite/tests/indexed-types/should_fail/T4485.stderr +++ b/testsuite/tests/indexed-types/should_fail/T4485.stderr @@ -1,15 +1,15 @@ -T4485.hs:47:15: +T4485.hs:46:15: Overlapping instances for EmbedAsChild (IdentityT IO) (XMLGenT m0 (XML m0)) arising from a use of ‘asChild’ Matching instances: - instance [overlap ok] (EmbedAsChild m c, m1 ~ m) => - EmbedAsChild m (XMLGenT m1 c) - -- Defined at T4485.hs:29:10 - instance [overlap ok] EmbedAsChild - (IdentityT IO) (XMLGenT Identity ()) - -- Defined at T4485.hs:42:10 + instance [overlapping] (EmbedAsChild m c, m1 ~ m) => + EmbedAsChild m (XMLGenT m1 c) + -- Defined at T4485.hs:28:30 + instance [overlapping] EmbedAsChild + (IdentityT IO) (XMLGenT Identity ()) + -- Defined at T4485.hs:41:30 (The choice depends on the instantiation of ‘m0’ To pick the first instance above, use IncoherentInstances when compiling the other instance declarations) @@ -18,12 +18,11 @@ T4485.hs:47:15: In an equation for ‘asChild’: asChild b = asChild $ (genElement "foo") -T4485.hs:47:26: +T4485.hs:46:26: No instance for (XMLGen m0) arising from a use of ‘genElement’ The type variable ‘m0’ is ambiguous Note: there is a potential instance available: - instance [overlap ok] XMLGen (IdentityT m) - -- Defined at T4485.hs:36:10 + instance XMLGen (IdentityT m) -- Defined at T4485.hs:35:10 In the second argument of ‘($)’, namely ‘(genElement "foo")’ In the expression: asChild $ (genElement "foo") In an equation for ‘asChild’: diff --git a/testsuite/tests/indexed-types/should_fail/T5439.hs b/testsuite/tests/indexed-types/should_fail/T5439.hs index 396a5436c4..dfcd399b4f 100644 --- a/testsuite/tests/indexed-types/should_fail/T5439.hs +++ b/testsuite/tests/indexed-types/should_fail/T5439.hs @@ -9,7 +9,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE UndecidableInstances #-} module Main where diff --git a/testsuite/tests/indexed-types/should_fail/T5439.stderr b/testsuite/tests/indexed-types/should_fail/T5439.stderr index 18af3fa7cf..19517cbf57 100644 --- a/testsuite/tests/indexed-types/should_fail/T5439.stderr +++ b/testsuite/tests/indexed-types/should_fail/T5439.stderr @@ -1,26 +1,26 @@ -
-T5439.hs:83:28:
- Couldn't match type ‘Attempt (HHead (HDrop n0 l0))
- -> Attempt (HElemOf l0)’
- with ‘Attempt (WaitOpResult (WaitOps rs))’
- Expected type: f (Attempt (HNth n0 l0) -> Attempt (HElemOf l0))
- Actual type: f (Attempt (WaitOpResult (WaitOps rs)))
- Relevant bindings include
- register :: Bool -> Peano n -> WaitOps (HDrop n rs) -> IO Bool
- (bound at T5439.hs:65:9)
- ev :: f (Attempt (WaitOpResult (WaitOps rs)))
- (bound at T5439.hs:62:22)
- ops :: WaitOps rs (bound at T5439.hs:62:18)
- registerWaitOp :: WaitOps rs
- -> f (Attempt (WaitOpResult (WaitOps rs))) -> IO Bool
- (bound at T5439.hs:62:3)
- In the first argument of ‘complete’, namely ‘ev’
- In the expression: complete ev
-
-T5439.hs:83:39:
- Couldn't match expected type ‘Peano n0’
- with actual type ‘Attempt α0’
- In the second argument of ‘($)’, namely
- ‘Failure (e :: SomeException)’
- In the second argument of ‘($)’, namely
- ‘inj $ Failure (e :: SomeException)’
+ +T5439.hs:82:28: + Couldn't match type ‘Attempt (HHead (HDrop n0 l0)) + -> Attempt (HElemOf l0)’ + with ‘Attempt (WaitOpResult (WaitOps rs))’ + Expected type: f (Attempt (HNth n0 l0) -> Attempt (HElemOf l0)) + Actual type: f (Attempt (WaitOpResult (WaitOps rs))) + Relevant bindings include + register :: Bool -> Peano n -> WaitOps (HDrop n rs) -> IO Bool + (bound at T5439.hs:64:9) + ev :: f (Attempt (WaitOpResult (WaitOps rs))) + (bound at T5439.hs:61:22) + ops :: WaitOps rs (bound at T5439.hs:61:18) + registerWaitOp :: WaitOps rs + -> f (Attempt (WaitOpResult (WaitOps rs))) -> IO Bool + (bound at T5439.hs:61:3) + In the first argument of ‘complete’, namely ‘ev’ + In the expression: complete ev + +T5439.hs:82:39: + Couldn't match expected type ‘Peano n0’ + with actual type ‘Attempt α0’ + In the second argument of ‘($)’, namely + ‘Failure (e :: SomeException)’ + In the second argument of ‘($)’, namely + ‘inj $ Failure (e :: SomeException)’ diff --git a/testsuite/tests/indexed-types/should_fail/T9357.hs b/testsuite/tests/indexed-types/should_fail/T9357.hs new file mode 100644 index 0000000000..29c57f4a5c --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T9357.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RankNTypes, MagicHash, TypeFamilies, PolyKinds #-} + +module T9357 where +import GHC.Exts + +type family F (a :: k1) :: k2 +type instance F Int# = Int +type instance F (forall a. a->a) = Int diff --git a/testsuite/tests/indexed-types/should_fail/T9357.stderr b/testsuite/tests/indexed-types/should_fail/T9357.stderr new file mode 100644 index 0000000000..4d97c31fd6 --- /dev/null +++ b/testsuite/tests/indexed-types/should_fail/T9357.stderr @@ -0,0 +1,8 @@ + +T9357.hs:7:15: + Illegal unlifted type: Int# + In the type instance declaration for ‘F’ + +T9357.hs:8:15: + Illegal polymorphic or qualified type: forall a. a -> a + In the type instance declaration for ‘F’ diff --git a/testsuite/tests/indexed-types/should_fail/all.T b/testsuite/tests/indexed-types/should_fail/all.T index 2c5ae68859..0851c086fb 100644 --- a/testsuite/tests/indexed-types/should_fail/all.T +++ b/testsuite/tests/indexed-types/should_fail/all.T @@ -124,3 +124,4 @@ test('T9167', normal, compile_fail, ['']) test('T9171', normal, compile_fail, ['']) test('T9097', normal, compile_fail, ['']) test('T9160', normal, compile_fail, ['']) +test('T9357', normal, compile_fail, ['']) diff --git a/testsuite/tests/module/all.T b/testsuite/tests/module/all.T index 926cbb5448..cb5ce2fe8d 100644 --- a/testsuite/tests/module/all.T +++ b/testsuite/tests/module/all.T @@ -91,7 +91,16 @@ test('mod69', normal, compile_fail, ['']) test('mod70', normal, compile_fail, ['']) test('mod71', normal, compile_fail, ['']) test('mod72', normal, compile_fail, ['']) -test('mod73', normal, compile_fail, ['']) + +# The order of suggestions in the output for test mod73 +# is subject to variation depending on the optimization level +# that GHC was built with (and probably minor changes to GHC too). +# This seems okay since there is unsafePerformIO under the hood +# in FastString. Allow any order with an extra normaliser. (See #9325.) +def normalise_mod73_error(x): + return x.replace('LT','XX',1).replace('EQ','XX',1).replace('GT','XX',1) +test('mod73', normalise_errmsg_fun(normalise_mod73_error), compile_fail, ['']) + test('mod74', normal, compile_fail, ['']) test('mod75', normal, compile, ['']) test('mod76', normal, compile_fail, ['']) diff --git a/testsuite/tests/module/base01/Makefile b/testsuite/tests/module/base01/Makefile index 815fbff1d4..6f77c09a36 100644 --- a/testsuite/tests/module/base01/Makefile +++ b/testsuite/tests/module/base01/Makefile @@ -9,6 +9,6 @@ clean: base01: rm -f GHC/*.o rm -f GHC/*.hi - '$(TEST_HC)' $(filter-out -fforce-recomp,$(TEST_HC_OPTS)) -XNoImplicitPrelude -package-name base -c GHC/Base.hs - '$(TEST_HC)' $(filter-out -fforce-recomp,$(TEST_HC_OPTS)) -XNoImplicitPrelude -package-name base --make GHC.Foo + '$(TEST_HC)' $(filter-out -fforce-recomp,$(TEST_HC_OPTS)) -XNoImplicitPrelude -this-package-key base -c GHC/Base.hs + '$(TEST_HC)' $(filter-out -fforce-recomp,$(TEST_HC_OPTS)) -XNoImplicitPrelude -this-package-key base --make GHC.Foo diff --git a/testsuite/tests/module/mod73.stderr b/testsuite/tests/module/mod73.stderr index 576b0e3a86..d19a032cef 100644 --- a/testsuite/tests/module/mod73.stderr +++ b/testsuite/tests/module/mod73.stderr @@ -2,6 +2,6 @@ mod73.hs:3:7: Not in scope: ‘Prelude.g’ Perhaps you meant one of these: - data constructor ‘Prelude.LT’ (imported from Prelude), + data constructor ‘Prelude.GT’ (imported from Prelude), data constructor ‘Prelude.EQ’ (imported from Prelude), - data constructor ‘Prelude.GT’ (imported from Prelude) + data constructor ‘Prelude.LT’ (imported from Prelude) diff --git a/testsuite/tests/numeric/should_run/.gitignore b/testsuite/tests/numeric/should_run/.gitignore deleted file mode 100644 index c484a26c83..0000000000 --- a/testsuite/tests/numeric/should_run/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -NumDecimals -T8726 diff --git a/testsuite/tests/package/Makefile b/testsuite/tests/package/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/package/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/package/all.T b/testsuite/tests/package/all.T new file mode 100644 index 0000000000..cb30949124 --- /dev/null +++ b/testsuite/tests/package/all.T @@ -0,0 +1,21 @@ +setTestOpts(only_compiler_types(['ghc'])) + +hide_all = '-hide-all-packages -XNoImplicitPrelude ' +incr_containers = '-package "containers (Data.Map as Map, Data.Set)" ' +inc_containers = '-package containers ' +incr_ghc = '-package "ghc (HsTypes as MyHsTypes, HsUtils)" ' +inc_ghc = '-package ghc ' +hide_ghc = '-hide-package ghc ' + +test('package01', normal, compile, [hide_all + incr_containers]) +test('package01e', normal, compile_fail, [hide_all + incr_containers]) +test('package02', normal, compile, [hide_all + inc_containers + incr_containers]) +test('package03', normal, compile, [hide_all + incr_containers + inc_containers]) +test('package04', normal, compile, [incr_containers]) +test('package05', normal, compile, [incr_ghc + inc_ghc]) +test('package06', normal, compile, [incr_ghc]) +test('package06e', normal, compile_fail, [incr_ghc]) +test('package07e', normal, compile_fail, [incr_ghc + inc_ghc + hide_ghc]) +test('package08e', normal, compile_fail, [incr_ghc + hide_ghc]) +test('package09e', normal, compile_fail, ['-package "containers (Data.Map as M, Data.Set as M)"']) +test('package10', normal, compile, ['-hide-all-packages -package "ghc (UniqFM as Prelude)" ']) diff --git a/testsuite/tests/package/package01.hs b/testsuite/tests/package/package01.hs new file mode 100644 index 0000000000..0fdd41146f --- /dev/null +++ b/testsuite/tests/package/package01.hs @@ -0,0 +1,3 @@ +module Package01 where +import Map +import Data.Set diff --git a/testsuite/tests/package/package01e.hs b/testsuite/tests/package/package01e.hs new file mode 100644 index 0000000000..946d400f78 --- /dev/null +++ b/testsuite/tests/package/package01e.hs @@ -0,0 +1,3 @@ +module Package01e where +import Data.Map +import Data.IntMap diff --git a/testsuite/tests/package/package01e.stderr b/testsuite/tests/package/package01e.stderr new file mode 100644 index 0000000000..232ec6ce2d --- /dev/null +++ b/testsuite/tests/package/package01e.stderr @@ -0,0 +1,10 @@ + +package01e.hs:2:1: + Failed to load interface for ‘Data.Map’ + It is a member of the hidden package ‘containers-0.5.5.1’. + Use -v to see a list of the files searched for. + +package01e.hs:3:1: + Failed to load interface for ‘Data.IntMap’ + It is a member of the hidden package ‘containers-0.5.5.1’. + Use -v to see a list of the files searched for. diff --git a/testsuite/tests/package/package02.hs b/testsuite/tests/package/package02.hs new file mode 100644 index 0000000000..ea06404935 --- /dev/null +++ b/testsuite/tests/package/package02.hs @@ -0,0 +1,5 @@ +module Package02 where +import Data.Map +import Map +import Data.Set +import Data.IntMap diff --git a/testsuite/tests/package/package03.hs b/testsuite/tests/package/package03.hs new file mode 100644 index 0000000000..d81dc3e037 --- /dev/null +++ b/testsuite/tests/package/package03.hs @@ -0,0 +1,5 @@ +module Package03 where +import Data.Map +import Map +import Data.Set +import Data.IntMap diff --git a/testsuite/tests/package/package04.hs b/testsuite/tests/package/package04.hs new file mode 100644 index 0000000000..85c2cae05a --- /dev/null +++ b/testsuite/tests/package/package04.hs @@ -0,0 +1,5 @@ +module Package04 where +import Data.Map +import Map +import Data.Set +import Data.IntMap diff --git a/testsuite/tests/package/package05.hs b/testsuite/tests/package/package05.hs new file mode 100644 index 0000000000..3b0069c5d5 --- /dev/null +++ b/testsuite/tests/package/package05.hs @@ -0,0 +1,4 @@ +module Package05 where +import HsTypes +import MyHsTypes +import HsUtils diff --git a/testsuite/tests/package/package06.hs b/testsuite/tests/package/package06.hs new file mode 100644 index 0000000000..096b81b7ba --- /dev/null +++ b/testsuite/tests/package/package06.hs @@ -0,0 +1,3 @@ +module Package06 where +import MyHsTypes +import HsUtils diff --git a/testsuite/tests/package/package06e.hs b/testsuite/tests/package/package06e.hs new file mode 100644 index 0000000000..6feaebda62 --- /dev/null +++ b/testsuite/tests/package/package06e.hs @@ -0,0 +1,3 @@ +module Package06e where +import HsTypes +import UniqFM diff --git a/testsuite/tests/package/package06e.stderr b/testsuite/tests/package/package06e.stderr new file mode 100644 index 0000000000..2d4945549e --- /dev/null +++ b/testsuite/tests/package/package06e.stderr @@ -0,0 +1,10 @@ + +package06e.hs:2:1: + Failed to load interface for ‘HsTypes’ + It is a member of the hidden package ‘ghc’. + Use -v to see a list of the files searched for. + +package06e.hs:3:1: + Failed to load interface for ‘UniqFM’ + It is a member of the hidden package ‘ghc’. + Use -v to see a list of the files searched for. diff --git a/testsuite/tests/package/package07e.hs b/testsuite/tests/package/package07e.hs new file mode 100644 index 0000000000..85bb723989 --- /dev/null +++ b/testsuite/tests/package/package07e.hs @@ -0,0 +1,5 @@ +module Package07e where +import MyHsTypes +import HsTypes +import HsUtils +import UniqFM diff --git a/testsuite/tests/package/package07e.stderr b/testsuite/tests/package/package07e.stderr new file mode 100644 index 0000000000..6a72a2e89c --- /dev/null +++ b/testsuite/tests/package/package07e.stderr @@ -0,0 +1,20 @@ + +package07e.hs:2:1: + Failed to load interface for ‘MyHsTypes’ + Perhaps you meant HsTypes (needs flag -package-key ghc) + Use -v to see a list of the files searched for. + +package07e.hs:3:1: + Failed to load interface for ‘HsTypes’ + It is a member of the hidden package ‘ghc’. + Use -v to see a list of the files searched for. + +package07e.hs:4:1: + Failed to load interface for ‘HsUtils’ + It is a member of the hidden package ‘ghc’. + Use -v to see a list of the files searched for. + +package07e.hs:5:1: + Failed to load interface for ‘UniqFM’ + It is a member of the hidden package ‘ghc’. + Use -v to see a list of the files searched for. diff --git a/testsuite/tests/package/package08e.hs b/testsuite/tests/package/package08e.hs new file mode 100644 index 0000000000..40f814449a --- /dev/null +++ b/testsuite/tests/package/package08e.hs @@ -0,0 +1,5 @@ +module Package08e where +import MyHsTypes +import HsTypes +import HsUtils +import UniqFM diff --git a/testsuite/tests/package/package08e.stderr b/testsuite/tests/package/package08e.stderr new file mode 100644 index 0000000000..a7e8433f7a --- /dev/null +++ b/testsuite/tests/package/package08e.stderr @@ -0,0 +1,20 @@ + +package08e.hs:2:1: + Failed to load interface for ‘MyHsTypes’ + Perhaps you meant HsTypes (needs flag -package-key ghc) + Use -v to see a list of the files searched for. + +package08e.hs:3:1: + Failed to load interface for ‘HsTypes’ + It is a member of the hidden package ‘ghc’. + Use -v to see a list of the files searched for. + +package08e.hs:4:1: + Failed to load interface for ‘HsUtils’ + It is a member of the hidden package ‘ghc’. + Use -v to see a list of the files searched for. + +package08e.hs:5:1: + Failed to load interface for ‘UniqFM’ + It is a member of the hidden package ‘ghc’. + Use -v to see a list of the files searched for. diff --git a/testsuite/tests/package/package09e.hs b/testsuite/tests/package/package09e.hs new file mode 100644 index 0000000000..8f08bbd5b2 --- /dev/null +++ b/testsuite/tests/package/package09e.hs @@ -0,0 +1,2 @@ +module Package09e where +import M diff --git a/testsuite/tests/package/package09e.stderr b/testsuite/tests/package/package09e.stderr new file mode 100644 index 0000000000..9cd00a2930 --- /dev/null +++ b/testsuite/tests/package/package09e.stderr @@ -0,0 +1,5 @@ + +package09e.hs:2:1: + Ambiguous interface for ‘M’: + it is bound as Data.Set by a package flag + it is bound as Data.Map by a package flag diff --git a/testsuite/tests/package/package10.hs b/testsuite/tests/package/package10.hs new file mode 100644 index 0000000000..6db31da664 --- /dev/null +++ b/testsuite/tests/package/package10.hs @@ -0,0 +1,2 @@ +module Package10 where +x = emptyUFM diff --git a/testsuite/tests/parser/should_fail/T8506.stderr b/testsuite/tests/parser/should_fail/T8506.stderr index b0e9fde84b..d7de4fe4e3 100644 --- a/testsuite/tests/parser/should_fail/T8506.stderr +++ b/testsuite/tests/parser/should_fail/T8506.stderr @@ -3,4 +3,4 @@ T8506.hs:3:16: Unexpected type ‘Int’ In the class declaration for ‘Shapable’ A class declaration should have form - class Shapable a b c where ... + class Shapable a where ... diff --git a/testsuite/tests/parser/should_fail/readFail025.stderr b/testsuite/tests/parser/should_fail/readFail025.stderr index da220cd0c3..5641642c99 100644 --- a/testsuite/tests/parser/should_fail/readFail025.stderr +++ b/testsuite/tests/parser/should_fail/readFail025.stderr @@ -3,4 +3,4 @@ readFail025.hs:5:8: Unexpected type ‘String’ In the data declaration for ‘T’ A data declaration should have form - data T a b c = ... + data T a = ... diff --git a/testsuite/tests/patsyn/should_compile/.gitignore b/testsuite/tests/patsyn/should_compile/.gitignore deleted file mode 100644 index 492f1e78dd..0000000000 --- a/testsuite/tests/patsyn/should_compile/.gitignore +++ /dev/null @@ -1,9 +0,0 @@ -.hpc.bidir -.hpc.ex -.hpc.ex-num -.hpc.ex-prov -.hpc.ex-view -.hpc.incomplete -.hpc.num -.hpc.overlap -.hpc.univ diff --git a/testsuite/tests/patsyn/should_run/.gitignore b/testsuite/tests/patsyn/should_run/.gitignore deleted file mode 100644 index e2087bd76a..0000000000 --- a/testsuite/tests/patsyn/should_run/.gitignore +++ /dev/null @@ -1,7 +0,0 @@ -eval -ex-prov -match -.hpc.eval -.hpc.ex-prov -.hpc.match -ex-prov-run diff --git a/testsuite/tests/patsyn/should_run/all.T b/testsuite/tests/patsyn/should_run/all.T index f5936c66c2..b3c6b74461 100644 --- a/testsuite/tests/patsyn/should_run/all.T +++ b/testsuite/tests/patsyn/should_run/all.T @@ -1,3 +1,5 @@ test('eval', normal, compile_and_run, ['']) test('match', normal, compile_and_run, ['']) test('ex-prov-run', normal, compile_and_run, ['']) +test('bidir-explicit', normal, compile_and_run, ['']) +test('bidir-explicit-scope', normal, compile_and_run, ['']) diff --git a/testsuite/tests/patsyn/should_run/bidir-explicit-scope.hs b/testsuite/tests/patsyn/should_run/bidir-explicit-scope.hs new file mode 100644 index 0000000000..390bbb0976 --- /dev/null +++ b/testsuite/tests/patsyn/should_run/bidir-explicit-scope.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PatternSynonyms #-} +module Main where + +pattern First x <- x:_ where + First x = foo [x, x, x] + +foo :: [a] -> [a] +foo xs@(First x) = replicate (length xs + 1) x + +main = mapM_ print $ First () diff --git a/testsuite/tests/patsyn/should_run/bidir-explicit-scope.stdout b/testsuite/tests/patsyn/should_run/bidir-explicit-scope.stdout new file mode 100644 index 0000000000..35735b4d3b --- /dev/null +++ b/testsuite/tests/patsyn/should_run/bidir-explicit-scope.stdout @@ -0,0 +1,4 @@ +() +() +() +() diff --git a/testsuite/tests/patsyn/should_run/bidir-explicit.hs b/testsuite/tests/patsyn/should_run/bidir-explicit.hs new file mode 100644 index 0000000000..d295191b26 --- /dev/null +++ b/testsuite/tests/patsyn/should_run/bidir-explicit.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +module Main where + +pattern First x <- x:_ where + First x = [x] + +main = mapM_ print $ First () diff --git a/testsuite/tests/patsyn/should_run/bidir-explicit.stdout b/testsuite/tests/patsyn/should_run/bidir-explicit.stdout new file mode 100644 index 0000000000..6a452c185a --- /dev/null +++ b/testsuite/tests/patsyn/should_run/bidir-explicit.stdout @@ -0,0 +1 @@ +() diff --git a/testsuite/tests/perf/compiler/T5321FD.hs b/testsuite/tests/perf/compiler/T5321FD.hs index 6e10939837..004f487098 100644 --- a/testsuite/tests/perf/compiler/T5321FD.hs +++ b/testsuite/tests/perf/compiler/T5321FD.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fcontext-stack=1000 #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, - MultiParamTypeClasses, OverlappingInstances, TypeSynonymInstances, + MultiParamTypeClasses, TypeSynonymInstances, TypeOperators, UndecidableInstances, TypeFamilies #-} module T5321FD where diff --git a/testsuite/tests/perf/compiler/T5321Fun.hs b/testsuite/tests/perf/compiler/T5321Fun.hs index efd7db770b..bf70ce5221 100644 --- a/testsuite/tests/perf/compiler/T5321Fun.hs +++ b/testsuite/tests/perf/compiler/T5321Fun.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fcontext-stack=1000 #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, - MultiParamTypeClasses, OverlappingInstances, TypeSynonymInstances, + MultiParamTypeClasses, TypeSynonymInstances, TypeOperators, UndecidableInstances, TypeFamilies #-} module T5321Fun where diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 56417ea808..ea62520b07 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -48,10 +48,11 @@ test('T1969', # 2013-02-10 5030080 (x86/Windows) # 2013-11-13 7295012 (x86/Windows, 64bit machine) # 2014-04-24 5719436 (x86/Windows, 64bit machine) - (wordsize(32), 6429864, 1), + (wordsize(32), 5949188, 1), # 6707308 (x86/OS X) # 2009-12-31 6149572 (x86/Linux) # 2014-01-22 6429864 (x86/Linux) + # 2014-06-29 5949188 (x86/Linux) (wordsize(64), 11000000, 20)]), # looks like the peak is around ~10M, but we're # unlikely to GC exactly on the peak. @@ -65,13 +66,14 @@ test('T1969', # 2013-02-10 310633884 (x86/Windows) # 2013-11-13 317975916 (x86/Windows, 64bit machine) # 2014-04-04 301784492 (x86/Windows, 64bit machine) - (wordsize(32), 316103268, 1), + (wordsize(32), 303300692, 1), # 221667908 (x86/OS X) # 274932264 (x86/Linux) # 2012-10-08 303930948 (x86/Linux, new codegen) # 2013-02-10 322937684 (x86/OSX) # 2014-01-22 316103268 (x86/Linux) - (wordsize(64), 660922376, 5)]), + # 2014-06-29 303300692 (x86/Linux) + (wordsize(64), 651626680, 5)]), # 17/11/2009 434845560 (amd64/Linux) # 08/12/2009 459776680 (amd64/Linux) # 17/05/2010 519377728 (amd64/Linux) @@ -87,6 +89,7 @@ test('T1969', # 17/1/13: 667160192 (x86_64/Linux) new demand analyser # 18/10/2013 698612512 (x86_64/Linux) fix for #8456 # 10/02/2014 660922376 (x86_64/Linux) call artiy analysis + # 17/07/2014 651626680 (x86_64/Linux) roundabout update only_ways(['normal']), extra_hc_opts('-dcore-lint -static') @@ -118,7 +121,7 @@ test('T3294', # 2013-02-10 20772984 (x86/OSX) # 2013-11-13 24009436 (x86/Windows, 64bit machine) # 2014-04-24 19882188 (x86/Windows, 64bit machine) - (wordsize(64), 43224080, 15)]), + (wordsize(64), 40000000, 15)]), # prev: 25753192 (amd64/Linux) # 29/08/2012: 37724352 (amd64/Linux) # (increase due to new codegen, see #7198) @@ -128,6 +131,8 @@ test('T3294', # (reason for decrease unknown) # 29/5/2013: 43224080 (amd64/Linux) # (reason for increase back to earlier value unknown) + # 2014-07-14: 36670800 (amd64/Linux) + # (reason unknown, setting expected value somewhere in between) compiler_stats_num_field('bytes allocated', [(wordsize(32), 1377050640, 5), @@ -137,7 +142,7 @@ test('T3294', # 2013-11-13: 1478325844 (x86/Windows, 64bit machine) # 2014-01-12: 1565185140 (x86/Linux) # 2013-04-04: 1377050640 (x86/Windows, 64bit machine) - (wordsize(64), 2705289664, 5)]), + (wordsize(64), 2671595512, 5)]), # old: 1357587088 (amd64/Linux) # 29/08/2012: 2961778696 (amd64/Linux) # (^ increase due to new codegen, see #7198) @@ -146,6 +151,7 @@ test('T3294', # 12/12/2013: 3083825616 (amd64/Linux) (reason unknown) # 18/02/2014: 2897630040 (amd64/Linux) (call arity improvements) # 12/03/2014: 2705289664 (amd64/Linux) (more call arity improvements) + # 2014-17-07: 2671595512 (amd64/Linux) (round-about update) conf_3294 ], compile, @@ -227,15 +233,16 @@ test('T3064', # 2012-10-30: 111189536 (x86/Windows) # 2013-11-13: 146626504 (x86/Windows, 64bit machine) # 2014-01-22: 162457940 (x86/Linux) - (wordsize(64), 324022680, 5)]), + (wordsize(64), 332702112, 5)]), # (amd64/Linux) (28/06/2011): 73259544 # (amd64/Linux) (07/02/2013): 224798696 # (amd64/Linux) (02/08/2013): 236404384, increase from roles # (amd64/Linux) (11/09/2013): 290165632, increase from AMP warnings # (amd64/Linux) (22/11/2013): 308300448, GND via Coercible and counters for constraints solving - # (amd64/Linux) (02/12/2013): 329795912, Coercible refactor + # (amd64/Linux) (02/12/2013): 329795912, Coercible refactor # (amd64/Linux) (11/02/2014): 308422280, optimize Coercions in simpleOptExpr # (amd64/Linux) (23/05/2014): 324022680, unknown cause + # (amd64/Linux) (2014-07-17): 332702112, general round of updates compiler_stats_num_field('max_bytes_used', [(wordsize(32), 11202304, 20), @@ -270,7 +277,7 @@ test('T5030', # previous: 196457520 # 2012-10-08: 259547660 (x86/Linux, new codegen) # 2013-11-21: 198573456 (x86 Windows, 64 bit machine) - (wordsize(64), 397672152, 10)]), + (wordsize(64), 409314320, 10)]), # Previously 530000000 (+/- 10%) # 17/1/13: 602993184 (x86_64/Linux) # (new demand analyser) @@ -280,6 +287,8 @@ test('T5030', # decrease from more aggressive coercion optimisations from roles # 2013-11-12 397672152 (amd64/Linux) # big decrease following better CSE and arity + # 2014-07-17 409314320 (amd64/Linux) + # general round of updates only_ways(['normal']) ], @@ -319,7 +328,7 @@ test('T783', # 2013-02-10: 329202116 (x86/Windows) # 2013-02-10: 338465200 (x86/OSX) # 2014-04-04: 319179104 (x86 Windows, 64 bit machine) - (wordsize(64), 654804144, 10)]), + (wordsize(64), 640031840, 10)]), # prev: 349263216 (amd64/Linux) # 07/08/2012: 384479856 (amd64/Linux) # 29/08/2012: 436927840 (amd64/Linux) @@ -330,6 +339,8 @@ test('T783', # (fix for #8456) # 24/10/2013: 654804144 (amd64/Linux) # (fix previous fix for #8456) + # 2014-07-17: 640031840 (amd64/Linux) + # (general round of updates) extra_hc_opts('-static') ], compile,['']) @@ -355,11 +366,13 @@ test('T5321Fun', test('T5321FD', [ only_ways(['normal']), # no optimisation for this one compiler_stats_num_field('bytes allocated', - [(wordsize(32), 240302920, 10), + [(wordsize(32), 211699816, 10), # prev: 213380256 # 2012-10-08: 240302920 (x86/Linux) # (increase due to new codegen) - (wordsize(64), 476497048, 10)]) + # 2014-07-31: 211699816 (Windows) (-11%) + # (due to better optCoercion, 5e7406d9, #9233) + (wordsize(64), 426960992, 10)]) # prev: 418306336 # 29/08/2012: 492905640 # (increase due to new codegen) @@ -367,6 +380,10 @@ test('T5321FD', # (reason for decrease unknown) # 08/06/2013: 476497048 # (reason for increase unknown) + # before 2014-07-17: 441997096 + # (with -8%, still in range, hence cause not known) + # 2014-07-17: 426960992 (-11% of previous value) + # (due to better optCoercion, 5e7406d9, #9233) ], compile,['']) @@ -375,7 +392,10 @@ test('T5642', compiler_stats_num_field('bytes allocated', [(wordsize(32), 650000000, 10), # sample from x86/Linux - (wordsize(64), 1300000000, 10)]) + (wordsize(64), 1402242360, 10)]) + # prev: 1300000000 + # 2014-07-17: 1358833928 (general round of updates) + # 2014-08-07: 1402242360 (caused by 1fc60ea) ], compile,['-O']) @@ -390,8 +410,8 @@ test('T5837', # 2012-10-02 81879216 # 2012-09-20 87254264 amd64/Linux # 2013-09-18 90587232 amd64/Linux - # 2013-11-21 86795752 amd64/Linux, GND via Coercible and counters - # for constraints solving + # 2013-11-21 86795752 amd64/Linux, GND via Coercible and counters + # for constraints solving ], compile_fail,['-ftype-function-depth=50']) @@ -402,19 +422,24 @@ test('T6048', # prev: 38000000 (x86/Linux) # 2012-10-08: 48887164 (x86/Linux) # 2014-04-04: 62618072 (x86 Windows, 64 bit machine) - (wordsize(64), 110646312, 10)]) - # 18/09/2012 97247032 amd64/Linux + (wordsize(64), 125431448, 12)]) + # 18/09/2012 97247032 amd64/Linux # 16/01/2014 108578664 amd64/Linux (unknown, likely foldl-via-foldr) - # 18/01/2014 95960720 amd64/Linux Call Arity improvements + # 18/01/2014 95960720 amd64/Linux Call Arity improvements # 28/02/2014 105556793 amd64/Linux (unknown, tweak in base/4d9e7c9e3 resulted in change) # 05/03/2014 110646312 amd64/Linux Call Arity became more elaborate + # 14/07/2014 125431448 amd64/Linux unknown reason. Even worse in GHC-7.8.3. *shurg* ], compile,['']) test('T9020', [ only_ways(['optasm']), compiler_stats_num_field('bytes allocated', - [(wordsize(32), 381360728, 10), - (wordsize(64), 795469104, 10)]) + [(wordsize(32), 343005716, 10), + # Original: 381360728 + # 2014-07-31: 343005716 (Windows) (general round of updates) + (wordsize(64), 728263536, 10)]) + # prev: 795469104 + # 2014-07-17: 728263536 (general round of updates) ], compile,['']) diff --git a/testsuite/tests/perf/haddock/all.T b/testsuite/tests/perf/haddock/all.T index 3ad24f17b5..1ef4fbc0d4 100644 --- a/testsuite/tests/perf/haddock/all.T +++ b/testsuite/tests/perf/haddock/all.T @@ -10,27 +10,30 @@ test('haddock.base', ,(platform('i386-unknown-mingw32'), 163, 10) # 2013-02-10: 133 (x86/Windows) # 2013-11-13: 163 (x86/Windows, 64bit machine) - ,(wordsize(32), 168, 1)]) + ,(wordsize(32), 156, 1)]) # 2012-08-14: 144 (x86/OSX) # 2012-10-30: 113 (x86/Windows) # 2013-02-10: 139 (x86/OSX) # 2014-01-22: 168 (x86/Linux - new haddock) + # 2014-06-29: 156 (x86/Linux) ,stats_num_field('max_bytes_used', - [(wordsize(64), 115113864, 10) - # 2012-08-14: 87374568 (amd64/Linux) - # 2012-08-21: 86428216 (amd64/Linux) - # 2012-09-20: 84794136 (amd64/Linux) - # 2012-11-12: 87265136 (amd64/Linux) - # 2013-01-29: 96022312 (amd64/Linux) + [(wordsize(64), 127954488, 10) + # 2012-08-14: 87374568 (amd64/Linux) + # 2012-08-21: 86428216 (amd64/Linux) + # 2012-09-20: 84794136 (amd64/Linux) + # 2012-11-12: 87265136 (amd64/Linux) + # 2013-01-29: 96022312 (amd64/Linux) # 2013-10-18: 115113864 (amd64/Linux) + # 2014-07-31: 127954488 (amd64/Linux), correlates with 1ae5fa45 ,(platform('i386-unknown-mingw32'), 58557136, 10) # 2013-02-10: 47988488 (x86/Windows) # 2013-11-13: 58557136 (x86/Windows, 64bit machine) - ,(wordsize(32), 62189068, 1)]) + ,(wordsize(32), 58243640, 1)]) # 2013-02-10: 52237984 (x86/OSX) # 2014-01-22: 62189068 (x86/Linux) + # 2014-06-29: 58243640 (x86/Linux) ,stats_num_field('bytes allocated', - [(wordsize(64), 7498123680, 5) + [(wordsize(64), 7946284944, 5) # 2012-08-14: 5920822352 (amd64/Linux) # 2012-09-20: 5829972376 (amd64/Linux) # 2012-10-08: 5902601224 (amd64/Linux) @@ -41,15 +44,20 @@ test('haddock.base', # 2013-11-21: 6756213256 (x86_64/Linux) # 2014-01-12: 7128342344 (x86_64/Linux) # 2014-06-12: 7498123680 (x86_64/Linux) + # 2014-08-05: 7992757384 (x86_64/Linux - bugfix for #314, Haddock now parses more URLs) + # 2014-08-08: 7946284944 (x86_64/Linux - Haddock updates to attoparsec-0.12.1.0) ,(platform('i386-unknown-mingw32'), 3548581572, 5) # 2013-02-10: 3358693084 (x86/Windows) # 2013-11-13: 3097751052 (x86/Windows, 64bit machine) # 2014-04-04: 3548581572 (x86/Windows, 64bit machine) - ,(wordsize(32), 3554624600, 1)]) + # 2014-08-05: XXX TODO UPDATE ME XXX + ,(wordsize(32), 3799130400, 1)]) # 2012-08-14: 3046487920 (x86/OSX) # 2012-10-30: 2955470952 (x86/Windows) # 2013-02-10: 3146596848 (x86/OSX) # 2014-02-22: 3554624600 (x86/Linux - new haddock) + # 2014-06-29: 3799130400 (x86/Linux) + # 2014-08-05: XXX TODO UPDATE ME XXX ], stats, ['../../../../libraries/base/dist-install/doc/html/base/base.haddock.t']) @@ -57,7 +65,7 @@ test('haddock.base', test('haddock.Cabal', [unless(in_tree_compiler(), skip) ,stats_num_field('peak_megabytes_allocated', - [(wordsize(64), 278, 10) + [(wordsize(64), 309, 10) # 2012-08-14: 202 (amd64/Linux) # 2012-08-29: 211 (amd64/Linux, new codegen) # 2012-09-20: 227 (amd64/Linux) @@ -65,33 +73,37 @@ test('haddock.Cabal', # 2013-06-07: 246 (amd64/Linux) (reason unknown) # 2013-11-21: 269 # 2013-11-22: 278 (amd64/Linux) (TH refactoring; weird) + # 2014-07-14: 309 (amd64/Linux) ,(platform('i386-unknown-mingw32'), 144, 10) # 2012-10-30: 83 (x86/Windows) # 2013-02-10: 116 (x86/Windows) # 2013-11-13: 129 (x86/Windows, 64bit machine) # 2014-01-28: 136 # 2014-04-04: 144 - ,(wordsize(32), 139, 1)]) + ,(wordsize(32), 147, 1)]) # 2012-08-14: 116 (x86/OSX) # 2013-02-10: 89 (x86/Windows) # 2014-01-22: 139 (x86/Linux - new haddock, but out of date before) + # 2014-06-29: 147 (x86/Linux) ,stats_num_field('max_bytes_used', - [(wordsize(64), 95356616, 15) - # 2012-08-14: 74119424 (amd64/Linux) - # 2012-08-29: 77992512 (amd64/Linux, new codegen) - # 2012-10-02: 91341568 (amd64/Linux) - # 2012-10-08: 80590280 (amd64/Linux) - # 2013-03-13: 95356616 (amd64/Linux) Cabal updated + [(wordsize(64), 113232208, 15) + # 2012-08-14: 74119424 (amd64/Linux) + # 2012-08-29: 77992512 (amd64/Linux, new codegen) + # 2012-10-02: 91341568 (amd64/Linux) + # 2012-10-08: 80590280 (amd64/Linux) + # 2013-03-13: 95356616 (amd64/Linux) Cabal updated + # 2014-07-14: 113232208 (amd64/Linux) ,(platform('i386-unknown-mingw32'), 63493200, 15) # 2012-10-30: 44224896 (x86/Windows) # 2013-11-13: 49391436 (x86/Windows, 64bit machine) # 2014-04-04: 63493200 (x86/Windows, 64bit machine) - ,(wordsize(32), 52718512, 1)]) + ,(wordsize(32), 66411508, 1)]) # 2012-08-14: 47461532 (x86/OSX) # 2013-02-10: 46563344 (x86/OSX) # 2014-01-22: 52718512 (x86/Linux) + # 2014-06-29: 66411508 (x86/Linux) ,stats_num_field('bytes allocated', - [(wordsize(64), 3979151552, 5) + [(wordsize(64), 4493770224, 5) # 2012-08-14: 3255435248 (amd64/Linux) # 2012-08-29: 3324606664 (amd64/Linux, new codegen) # 2012-10-08: 3373401360 (amd64/Linux) @@ -102,14 +114,19 @@ test('haddock.Cabal', # 2013-11-21: 3908586784 (amd64/Linux) Cabal updated # 2013-12-12: 3828567272 (amd64/Linux) # 2014-01-12: 3979151552 (amd64/Linux) new parser + # 2014-06-29: 4200993768 (amd64/Linux) + # 2014-08-05: 4493770224 (x86_64/Linux - bugfix for #314, Haddock now parses more URLs) ,(platform('i386-unknown-mingw32'), 2052220292, 5) # 2012-10-30: 1733638168 (x86/Windows) # 2013-02-10: 1906532680 (x86/Windows) # 2014-01-28: 1966911336 (x86/Windows) # 2014-04-24: 2052220292 (x86/Windows) - ,(wordsize(32), 1986290624, 1)]) + # 2014-08-05: XXX TODO UPDATE ME XXX + ,(wordsize(32), 2127198484, 1)]) # 2012-08-14: 1648610180 (x86/OSX) # 2014-01-22: 1986290624 (x86/Linux) + # 2014-06-29: 2127198484 (x86/Linux) + # 2014-08-05: XXX TODO UPDATE ME XXX ], stats, ['../../../../libraries/Cabal/Cabal/dist-install/doc/html/Cabal/Cabal.haddock.t']) @@ -129,10 +146,11 @@ test('haddock.compiler', # 2012-10-30: 606 (x86/Windows) # 2013-02-10: 653 (x86/Windows) # 2013-11-13: 735 (x86/Windows, 64bit machine) - ,(wordsize(32), 727, 1)]) + ,(wordsize(32), 771, 1)]) # 2012-08-14: 631 (x86/OSX) # 2013-02-10: 663 (x86/OSX) # 2014-01-22: 727 (x86/Linux - new haddock, but out of date before) + # 2014-06-29: 771 (x86/Linux) ,stats_num_field('max_bytes_used', [(wordsize(64), 541926264, 10) # 2012-08-14: 428775544 (amd64/Linux) @@ -148,24 +166,27 @@ test('haddock.compiler', # 2013-11-13: 269147084 (x86/Windows, 64bit machine) # 2014-01-28: 283814088 (x86/Windows) # 2014-04-04: 278706344 (x86/Windows) - ,(wordsize(32), 278124612, 1)]) + ,(wordsize(32), 284082916, 1)]) # 2012-08-14: 231064920 (x86/OSX) # 2013-02-10: 241785276 (x86/Windows) # 2014-01-22: 278124612 (x86/Linux - new haddock) + # 2014-06-29: 284082916 (x86/Linux) ,stats_num_field('bytes allocated', - [(wordsize(64), 28708374824, 10) + [(wordsize(64), 29809571376, 10) # 2012-08-14: 26070600504 (amd64/Linux) # 2012-08-29: 26353100288 (amd64/Linux, new CG) # 2012-09-18: 26882813032 (amd64/Linux) # 2012-11-12: 25990254632 (amd64/Linux) + # 2014-07-17: 29809571376 (amd64/Linux) general round of updates # 2012-11-27: 28708374824 (amd64/Linux) ,(platform('i386-unknown-mingw32'), 14328363592, 10) # 2012-10-30: 13773051312 (x86/Windows) # 2013-02-10: 14925262356 (x86/Windows) # 2013-11-13: 14328363592 (x86/Windows, 64bit machine) - ,(wordsize(32), 14581475024, 1)]) + ,(wordsize(32), 15110426000, 1)]) # 2012-08-14: 13471797488 (x86/OSX) # 2014-01-22: 14581475024 (x86/Linux - new haddock) + # 2014-06-29: 15110426000 (x86/Linux) ], stats, ['../../../../compiler/stage2/doc/html/ghc/ghc.haddock.t']) diff --git a/testsuite/tests/perf/should_run/.gitignore b/testsuite/tests/perf/should_run/.gitignore deleted file mode 100644 index 064aeba752..0000000000 --- a/testsuite/tests/perf/should_run/.gitignore +++ /dev/null @@ -1,8 +0,0 @@ -InlineArrayAlloc -InlineByteArrayAlloc -InlineCloneArrayAlloc -T4267 -T5949 -T7619 -T7850 -T7954 diff --git a/testsuite/tests/perf/should_run/T9339.hs b/testsuite/tests/perf/should_run/T9339.hs new file mode 100644 index 0000000000..96f5f7201a --- /dev/null +++ b/testsuite/tests/perf/should_run/T9339.hs @@ -0,0 +1,4 @@ +-- Tests that `last` successfully fuses. + +main :: IO () +main = print $ last $ filter odd $ [1::Int ..10000000] diff --git a/testsuite/tests/perf/should_run/T9339.stdout b/testsuite/tests/perf/should_run/T9339.stdout new file mode 100644 index 0000000000..e161ae3694 --- /dev/null +++ b/testsuite/tests/perf/should_run/T9339.stdout @@ -0,0 +1 @@ +9999999 diff --git a/testsuite/tests/perf/should_run/all.T b/testsuite/tests/perf/should_run/all.T index 94fd2a35b3..8b8547eae9 100644 --- a/testsuite/tests/perf/should_run/all.T +++ b/testsuite/tests/perf/should_run/all.T @@ -6,8 +6,9 @@ test('T3586', [stats_num_field('peak_megabytes_allocated', (17, 1)), # expected value: 17 (amd64/Linux) - stats_num_field('bytes allocated', (16835544, 5)), - # expected value: 16835544 (amd64/Linux) + stats_num_field('bytes allocated', (16102024, 5)), + # prev: 16835544 (amd64/Linux) + # 2014-07-17: 16102024 (amd64/Linux), general round of updates only_ways(['normal']) ], compile_and_run, @@ -60,9 +61,10 @@ test('T876', [(wordsize(64), 63216 , 5), # 2013-02-14: 1263712 (x86_64/Linux) # 2014-02-10: 63216 (x86_64/Linux), call arity analysis - (wordsize(32), 56820, 5) ]), + (wordsize(32), 53024, 5) ]), # some date: 663712 (Windows, 64-bit machine) # 2014-04-04: 56820 (Windows, 64-bit machine) + # 2014-06-29: 53024 (x86_64/Linux) only_ways(['normal']), extra_run_opts('10000') ], @@ -89,9 +91,10 @@ test('T3738', # expected value: 1 (amd64/Linux) stats_num_field('bytes allocated', [(wordsize(32), 45648, 5), - # expected value: 45648 (x86/Linux) + # expected value: 50520 (x86/Linux) (wordsize(64), 49400, 5)]), - # expected value: 49400 (amd64/Linux) + # prev: 49400 (amd64/Linux) + # 2014-07-17: 50520 (amd64/Linux) general round of updates only_ways(['normal']) ], compile_and_run, @@ -153,8 +156,9 @@ test('T5205', [stats_num_field('bytes allocated', [(wordsize(32), 47088, 5), # expected value: 47088 (x86/Darwin) - (wordsize(64), 51320, 5)]), + (wordsize(64), 52600, 5)]), # expected value: 51320 (amd64/Linux) + # 2014-07-17: 52600 (amd64/Linux) general round of updates only_ways(['normal', 'optasm']) ], compile_and_run, @@ -252,8 +256,9 @@ test('Conversions', # 2013-02-10: 77472 (x86/OSX) # 2013-02-10: 79276 (x86/Windows) # 2014-01-13: 76768 (x86/Linux) due to #8647 - (wordsize(64), 110632, 5)]), + (wordsize(64), 107544, 5)]), # 2012-12-18: 109608 (amd64/OS X) + # 2014-07-17: 107544 (amd64/Linux) only_ways(['normal']) ], @@ -374,3 +379,12 @@ test('T9203', only_ways(['normal'])], compile_and_run, ['-O2']) + +test('T9339', + [stats_num_field('bytes allocated', + [ (wordsize(64), 80050760, 5) ]), + # w/o fusing last: 320005080 + # 2014-07-22: 80050760 + only_ways(['normal'])], + compile_and_run, + ['-O2']) diff --git a/testsuite/tests/polykinds/Makefile b/testsuite/tests/polykinds/Makefile index aa8b482b73..8636bb959f 100644 --- a/testsuite/tests/polykinds/Makefile +++ b/testsuite/tests/polykinds/Makefile @@ -38,3 +38,9 @@ T8449: $(RM) -f T8449.hi T8449.o T8449a.hi T8449a.o '$(TEST_HC)' $(TEST_HC_OPTS) -c T8449a.hs '$(TEST_HC)' $(TEST_HC_OPTS) -c T8449.hs + +T9263: + $(RM) -f T9263.hi T9263.o T9263a.hi T9263a.o T9263b.hi T9263b.o + '$(TEST_HC)' $(TEST_HC_OPTS) -c T9263b.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -c T9263a.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -c T9263.hs diff --git a/testsuite/tests/polykinds/T7939a.stderr b/testsuite/tests/polykinds/T7939a.stderr index 09b818a5b5..22388ddca0 100644 --- a/testsuite/tests/polykinds/T7939a.stderr +++ b/testsuite/tests/polykinds/T7939a.stderr @@ -4,4 +4,4 @@ T7939a.hs:7:5: The first argument of ‘F’ should have kind ‘*’, but ‘Maybe’ has kind ‘* -> *’ In the type ‘Maybe’ - In the family declaration for ‘F’ + In the type family declaration for ‘F’ diff --git a/testsuite/tests/polykinds/T9063.hs b/testsuite/tests/polykinds/T9063.hs new file mode 100644 index 0000000000..007f475c06 --- /dev/null +++ b/testsuite/tests/polykinds/T9063.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DataKinds, PolyKinds, TypeFamilies, TypeOperators, + UndecidableInstances #-} + +module T9063 where + +import Data.Type.Equality +import Data.Proxy + +class kproxy ~ 'KProxy => PEq (kproxy :: KProxy a) where + type (:==) (x :: a) (y :: a) :: Bool + type x :== y = x == y + +instance PEq ('KProxy :: KProxy Bool) + +foo :: Proxy (True :== True) -> Proxy (True == True) +foo = id diff --git a/testsuite/tests/polykinds/T9222.hs b/testsuite/tests/polykinds/T9222.hs new file mode 100644 index 0000000000..df112519ac --- /dev/null +++ b/testsuite/tests/polykinds/T9222.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RankNTypes, GADTs, DataKinds, PolyKinds, TypeOperators, TypeFamilies #-} +module T9222 where + +import Data.Proxy + +data Want :: (i,j) -> * where + Want :: (a ~ '(b,c) => Proxy b) -> Want a diff --git a/testsuite/tests/polykinds/T9263.hs b/testsuite/tests/polykinds/T9263.hs new file mode 100644 index 0000000000..e913e1f653 --- /dev/null +++ b/testsuite/tests/polykinds/T9263.hs @@ -0,0 +1,2 @@ +module T9263 where + import T9263a diff --git a/testsuite/tests/polykinds/T9263a.hs b/testsuite/tests/polykinds/T9263a.hs new file mode 100644 index 0000000000..1cecabad38 --- /dev/null +++ b/testsuite/tests/polykinds/T9263a.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds, KindSignatures, TypeFamilies #-} +module T9263a where + +import T9263b +import Data.Proxy + +data Void + +instance PEq ('KProxy :: KProxy Void) diff --git a/testsuite/tests/polykinds/T9263b.hs b/testsuite/tests/polykinds/T9263b.hs new file mode 100644 index 0000000000..d267eaca79 --- /dev/null +++ b/testsuite/tests/polykinds/T9263b.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds, PolyKinds, TypeFamilies #-} +module T9263b where + +import Data.Proxy + +class kproxy ~ 'KProxy => PEq (kproxy :: KProxy a) where + type F (x :: a) :: Bool + type F (x :: a) = False diff --git a/testsuite/tests/polykinds/T9264.hs b/testsuite/tests/polykinds/T9264.hs new file mode 100644 index 0000000000..df75599e56 --- /dev/null +++ b/testsuite/tests/polykinds/T9264.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PolyKinds, TypeFamilies, ScopedTypeVariables #-} +module T9264 where + +class C (a :: k) where + type F (a :: k) + type F (a :: k) = Int diff --git a/testsuite/tests/polykinds/all.T b/testsuite/tests/polykinds/all.T index 09c72545a0..22a159d50e 100644 --- a/testsuite/tests/polykinds/all.T +++ b/testsuite/tests/polykinds/all.T @@ -102,3 +102,7 @@ test('T8705', normal, compile, ['']) test('T8985', normal, compile, ['']) test('T9106', normal, compile_fail, ['']) test('T9144', normal, compile_fail, ['']) +test('T9222', normal, compile, ['']) +test('T9264', normal, compile, ['']) +test('T9263', normal, run_command, ['$MAKE -s --no-print-directory T9263']) +test('T9063', normal, compile, ['']) diff --git a/testsuite/tests/primops/should_run/.gitignore b/testsuite/tests/primops/should_run/.gitignore deleted file mode 100644 index 184e53b8e4..0000000000 --- a/testsuite/tests/primops/should_run/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -T6135 -T7689 diff --git a/testsuite/tests/quasiquotation/.gitignore b/testsuite/tests/quasiquotation/.gitignore deleted file mode 100644 index d0d8953362..0000000000 --- a/testsuite/tests/quasiquotation/.gitignore +++ /dev/null @@ -1 +0,0 @@ -T7918 diff --git a/testsuite/tests/rename/prog006/Makefile b/testsuite/tests/rename/prog006/Makefile index fec1ce42d3..4124feccf0 100644 --- a/testsuite/tests/rename/prog006/Makefile +++ b/testsuite/tests/rename/prog006/Makefile @@ -28,11 +28,12 @@ rn.prog006: rm -f pkg.conf rm -f pwd pwd.exe pwd.exe.manifest pwd.hi pwd.o '$(TEST_HC)' $(TEST_HC_OPTS) --make pwd -v0 - '$(TEST_HC)' $(TEST_HC_OPTS) --make -package-name test-1.0 B.C -fforce-recomp -v0 $(RM_PROG006_EXTRA_FLAGS) + '$(TEST_HC)' $(TEST_HC_OPTS) --make -this-package-key test-1.0 B.C -fforce-recomp -v0 $(RM_PROG006_EXTRA_FLAGS) rm -f pkg.conf echo "name: test" >>pkg.conf echo "version: 1.0" >>pkg.conf echo "id: test-XXX" >>pkg.conf + echo "key: test-1.0" >>pkg.conf echo "import-dirs: `./pwd`" >>pkg.conf echo "exposed-modules: B.C" >>pkg.conf echo "[]" >$(LOCAL_PKGCONF) diff --git a/testsuite/tests/rename/should_compile/T3103/test.T b/testsuite/tests/rename/should_compile/T3103/test.T index d1e5b643f3..51ee2830bd 100644 --- a/testsuite/tests/rename/should_compile/T3103/test.T +++ b/testsuite/tests/rename/should_compile/T3103/test.T @@ -11,5 +11,5 @@ test('T3103', 'GHC/Unicode.o', 'GHC/Unicode.o-boot', 'GHC/Word.hi', 'GHC/Word.o'])], multimod_compile, - ['Foreign.Ptr', '-v0 -hide-all-packages -package ghc-prim -package integer-gmp -package-name base']) + ['Foreign.Ptr', '-v0 -hide-all-packages -package ghc-prim -package integer-gmp -this-package-key base']) diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T index 4ed92bd328..d104df4910 100644 --- a/testsuite/tests/rename/should_compile/all.T +++ b/testsuite/tests/rename/should_compile/all.T @@ -110,6 +110,8 @@ test('rn067', extra_clean(['Rn067_A.hi', 'Rn067_A.o']), multimod_compile, ['rn067', '-v0']) +test('rn068', normal, compile, ['']) + test('T1972', normal, compile, ['']) test('T2205', normal, compile, ['']) diff --git a/testsuite/tests/rename/should_compile/rn068.hs b/testsuite/tests/rename/should_compile/rn068.hs new file mode 100644 index 0000000000..83ed851ed8 --- /dev/null +++ b/testsuite/tests/rename/should_compile/rn068.hs @@ -0,0 +1,5 @@ +module Foo where + +data A = A1 { a, b :: Int } + | A2 { a, b :: Int } + | A3 { a, b :: Int } diff --git a/testsuite/tests/rename/should_fail/T9156.hs b/testsuite/tests/rename/should_fail/T9156.hs new file mode 100644 index 0000000000..f4ffd1a128 --- /dev/null +++ b/testsuite/tests/rename/should_fail/T9156.hs @@ -0,0 +1,4 @@ +module T9156 where + +data D = D1 { f1 :: Int } + | D2 { f1, f1 :: Int } diff --git a/testsuite/tests/rename/should_fail/T9156.stderr b/testsuite/tests/rename/should_fail/T9156.stderr new file mode 100644 index 0000000000..361ed379df --- /dev/null +++ b/testsuite/tests/rename/should_fail/T9156.stderr @@ -0,0 +1,5 @@ + +T9156.hs:4:19: + Multiple declarations of ‘f1’ + Declared at: T9156.hs:3:15 + T9156.hs:4:19 diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T index 0f60ff6175..d1bf2b6576 100644 --- a/testsuite/tests/rename/should_fail/all.T +++ b/testsuite/tests/rename/should_fail/all.T @@ -114,4 +114,5 @@ test('T8448', normal, compile_fail, ['']) test('T9006', extra_clean(['T9006a.hi', 'T9006a.o']), multimod_compile_fail, ['T9006', '-v0']) +test('T9156', normal, compile_fail, ['']) test('T9177', normal, compile_fail, ['']) diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr index d400b9190c..b53df162a8 100644 --- a/testsuite/tests/roles/should_compile/T8958.stderr +++ b/testsuite/tests/roles/should_compile/T8958.stderr @@ -12,9 +12,9 @@ TYPE CONSTRUCTORS COERCION AXIOMS axiom T8958.NTCo:Map :: Map k v = [(k, v)] INSTANCES + instance [incoherent] Nominal a -- Defined at T8958.hs:7:10 instance [incoherent] Representational a -- Defined at T8958.hs:10:10 - instance [incoherent] Nominal a -- Defined at T8958.hs:7:10 Dependent modules: [] Dependent packages: [base, ghc-prim, integer-gmp] diff --git a/testsuite/tests/rts/.gitignore b/testsuite/tests/rts/.gitignore deleted file mode 100644 index 1501ec6817..0000000000 --- a/testsuite/tests/rts/.gitignore +++ /dev/null @@ -1,13 +0,0 @@ -T3424 -T5435_dyn_asm -T5435_dyn_gcc -T5435_v_asm -T5435_v_gcc -T7919 -T8035 -T8124 -T8209 -T8242 -T9045 -T9078 -linker_unload diff --git a/testsuite/tests/rts/Makefile b/testsuite/tests/rts/Makefile index 180fe9b5ee..02a50a4644 100644 --- a/testsuite/tests/rts/Makefile +++ b/testsuite/tests/rts/Makefile @@ -108,7 +108,11 @@ BASE_DIR = $(shell $(LOCAL_GHC_PKG) field base library-dirs | sed 's/^.*: *//') BASE_LIB = $(shell $(LOCAL_GHC_PKG) field base hs-libraries | sed 's/^.*: *//') GHC_PRIM_DIR = $(shell $(LOCAL_GHC_PKG) field ghc-prim library-dirs | sed 's/^.*: *//') GHC_PRIM_LIB = $(shell $(LOCAL_GHC_PKG) field ghc-prim hs-libraries | sed 's/^.*: *//') -INTEGER_GMP_DIR = $(shell $(LOCAL_GHC_PKG) field integer-gmp library-dirs | sed 's/^.*: *//') +# We need to get first library directory here in order to get rid of +# system gmp library directory installation when ghc is configured +# with --with-gmp-libraries=<dir> parameter +INTEGER_GMP_DIR = $(shell $(LOCAL_GHC_PKG) field integer-gmp library-dirs \ + | sed 's/^.*: *//' | head -1) INTEGER_GMP_LIB = $(shell $(LOCAL_GHC_PKG) field integer-gmp hs-libraries | sed 's/^.*: *//') BASE = $(BASE_DIR)/lib$(BASE_LIB).a diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T index a56a3f39f0..d7c74c5847 100644 --- a/testsuite/tests/rts/all.T +++ b/testsuite/tests/rts/all.T @@ -230,3 +230,8 @@ test('T9045', [ omit_ways(['ghci']), extra_run_opts('10000 +RTS -A8k -RTS') ], c # I couldn't reproduce 9078 with the -threaded runtime, but could easily # with the non-threaded one. test('T9078', [ omit_ways(threaded_ways) ], compile_and_run, ['-with-rtsopts="-DS" -debug']) + +# 251 = RTS exit code for "out of memory" +test('overflow1', [ exit_code(251) ], compile_and_run, ['']) +test('overflow2', [ exit_code(251) ], compile_and_run, ['']) +test('overflow3', [ exit_code(251) ], compile_and_run, ['']) diff --git a/testsuite/tests/rts/linker_unload.c b/testsuite/tests/rts/linker_unload.c index 55870c348f..f1cc891df1 100644 --- a/testsuite/tests/rts/linker_unload.c +++ b/testsuite/tests/rts/linker_unload.c @@ -1,3 +1,4 @@ +#include "ghcconfig.h" #include <stdio.h> #include <stdlib.h> #include "Rts.h" diff --git a/testsuite/tests/rts/overflow1.hs b/testsuite/tests/rts/overflow1.hs new file mode 100644 index 0000000000..63ed5a4e02 --- /dev/null +++ b/testsuite/tests/rts/overflow1.hs @@ -0,0 +1,11 @@ +module Main where + +import Data.Array.IO +import Data.Word + +-- Try to overflow BLOCK_ROUND_UP in the computation of req_blocks in allocate() +-- Here we invoke allocate() via newByteArray# and the array package. +-- Request a number of bytes close to HS_WORD_MAX, +-- subtracting a few words for overhead in newByteArray#. +-- Allocate Word32s (rather than Word8s) to get around bounds-checking in array. +main = newArray (0,maxBound `div` 4 - 10) 0 :: IO (IOUArray Word Word32) diff --git a/testsuite/tests/rts/overflow1.stderr b/testsuite/tests/rts/overflow1.stderr new file mode 100644 index 0000000000..734ca954ca --- /dev/null +++ b/testsuite/tests/rts/overflow1.stderr @@ -0,0 +1 @@ +overflow1: out of memory diff --git a/testsuite/tests/rts/overflow2.hs b/testsuite/tests/rts/overflow2.hs new file mode 100644 index 0000000000..ac72158f45 --- /dev/null +++ b/testsuite/tests/rts/overflow2.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Main where + +import Foreign + +-- Test allocate(), the easy way. +data Cap = Cap +foreign import ccall "rts_unsafeGetMyCapability" myCapability :: IO (Ptr Cap) +foreign import ccall "allocate" allocate :: Ptr Cap -> Word -> IO (Ptr ()) + +-- Number of words n such that n * sizeof(W_) exactly overflows a word +-- (2^30 on a 32-bit system, 2^61 on a 64-bit system) +overflowWordCount :: Word +overflowWordCount = fromInteger $ + (fromIntegral (maxBound :: Word) + 1) `div` + fromIntegral (sizeOf (undefined :: Word)) + +main = do + cap <- myCapability + allocate cap (overflowWordCount - 1) diff --git a/testsuite/tests/rts/overflow2.stderr b/testsuite/tests/rts/overflow2.stderr new file mode 100644 index 0000000000..be65509ea9 --- /dev/null +++ b/testsuite/tests/rts/overflow2.stderr @@ -0,0 +1 @@ +overflow2: out of memory diff --git a/testsuite/tests/rts/overflow3.hs b/testsuite/tests/rts/overflow3.hs new file mode 100644 index 0000000000..31dfd5db53 --- /dev/null +++ b/testsuite/tests/rts/overflow3.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Main where + +import Foreign + +-- Test allocate(), the easy way. +data Cap = Cap +foreign import ccall "rts_unsafeGetMyCapability" myCapability :: IO (Ptr Cap) +foreign import ccall "allocate" allocate :: Ptr Cap -> Word -> IO (Ptr ()) + +-- Number of words n such that n * sizeof(W_) exactly overflows a word +-- (2^30 on a 32-bit system, 2^61 on a 64-bit system) +overflowWordCount :: Word +overflowWordCount = fromInteger $ + (fromIntegral (maxBound :: Word) + 1) `div` + fromIntegral (sizeOf (undefined :: Word)) + +main = do + cap <- myCapability + allocate cap (overflowWordCount + 1) diff --git a/testsuite/tests/rts/overflow3.stderr b/testsuite/tests/rts/overflow3.stderr new file mode 100644 index 0000000000..6c804e5048 --- /dev/null +++ b/testsuite/tests/rts/overflow3.stderr @@ -0,0 +1 @@ +overflow3: out of memory diff --git a/testsuite/tests/safeHaskell/check/pkg01/ImpSafeOnly07.stderr b/testsuite/tests/safeHaskell/check/pkg01/ImpSafeOnly07.stderr index a22386b7a8..43306a9eb7 100644 --- a/testsuite/tests/safeHaskell/check/pkg01/ImpSafeOnly07.stderr +++ b/testsuite/tests/safeHaskell/check/pkg01/ImpSafeOnly07.stderr @@ -3,4 +3,4 @@ The package (base) is required to be trusted but it isn't! <no location info>: - The package (bytestring-0.10.1.0) is required to be trusted but it isn't! + The package (bytestring-0.10.4.0) is required to be trusted but it isn't! diff --git a/testsuite/tests/safeHaskell/check/pkg01/ImpSafeOnly08.stderr b/testsuite/tests/safeHaskell/check/pkg01/ImpSafeOnly08.stderr index a22386b7a8..43306a9eb7 100644 --- a/testsuite/tests/safeHaskell/check/pkg01/ImpSafeOnly08.stderr +++ b/testsuite/tests/safeHaskell/check/pkg01/ImpSafeOnly08.stderr @@ -3,4 +3,4 @@ The package (base) is required to be trusted but it isn't! <no location info>: - The package (bytestring-0.10.1.0) is required to be trusted but it isn't! + The package (bytestring-0.10.4.0) is required to be trusted but it isn't! diff --git a/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout b/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout index 1308a31284..a37dfa55a3 100644 --- a/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout +++ b/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout @@ -25,21 +25,21 @@ require own pkg trusted: True M_SafePkg5 package dependencies: base* ghc-prim integer-gmp -trusted: safe-inferred +trusted: safe require own pkg trusted: True M_SafePkg6 -package dependencies: array-0.4.0.1 base* bytestring-0.10.1.0* +package dependencies: array-0.5.0.0@array_H3W2D8UaI9TKGEhUuQHax2 trusted: trustworthy require own pkg trusted: False M_SafePkg7 -package dependencies: array-0.4.0.1 base* bytestring-0.10.1.0* +package dependencies: array-0.5.0.0@array_H3W2D8UaI9TKGEhUuQHax2 trusted: safe require own pkg trusted: False M_SafePkg8 -package dependencies: array-0.4.0.1 base bytestring-0.10.1.0* +package dependencies: array-0.5.0.0@array_H3W2D8UaI9TKGEhUuQHax2 trusted: trustworthy require own pkg trusted: False diff --git a/testsuite/tests/safeHaskell/ghci/p13.script b/testsuite/tests/safeHaskell/ghci/p13.script index 4e96c844ed..950f95ab67 100644 --- a/testsuite/tests/safeHaskell/ghci/p13.script +++ b/testsuite/tests/safeHaskell/ghci/p13.script @@ -1,12 +1,11 @@ -- Test restricted functionality: Overlapping :unset +s :set -XSafe -:set -XOverlappingInstances :set -XFlexibleInstances :l P13_A -instance Pos [Int] where { res _ = error "This curry is poisoned!" } +instance {-# OVERLAPPING #-} Pos [Int] where { res _ = error "This curry is poisoned!" } res [1::Int, 2::Int] -- res 'c' diff --git a/testsuite/tests/safeHaskell/ghci/p13.stderr b/testsuite/tests/safeHaskell/ghci/p13.stderr index edf5e1eb91..7a743f18eb 100644 --- a/testsuite/tests/safeHaskell/ghci/p13.stderr +++ b/testsuite/tests/safeHaskell/ghci/p13.stderr @@ -1,10 +1,13 @@ -<interactive>:12:1: +P13_A.hs:1:14: Warning: + -XOverlappingInstances is deprecated: instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS + +<interactive>:11:1: Unsafe overlapping instances for Pos [Int] arising from a use of ‘res’ The matching instance is: - instance [overlap ok] [safe] Pos [Int] - -- Defined at <interactive>:10:10 + instance [overlapping] [safe] Pos [Int] + -- Defined at <interactive>:9:30 It is compiled in a Safe module and as such can only overlap instances from the same module, however it overlaps the following instances from different modules: diff --git a/testsuite/tests/safeHaskell/ghci/p15.stderr b/testsuite/tests/safeHaskell/ghci/p15.stderr index 19684b3937..55b5d4beae 100644 --- a/testsuite/tests/safeHaskell/ghci/p15.stderr +++ b/testsuite/tests/safeHaskell/ghci/p15.stderr @@ -8,7 +8,9 @@ Top level: Warning: Deprecated: "Use Data.Typeable.Internal instead" <interactive>:14:10: - Can't create hand written instances of Typeable in Safe Haskell! Can only derive them + Typeable instances can only be derived in Safe Haskell. + Replace the following instance: + instance [safe] Typeable G <interactive>:22:22: No instance for (Typeable G) arising from a use of ‘cast’ diff --git a/testsuite/tests/safeHaskell/ghci/p6.stderr b/testsuite/tests/safeHaskell/ghci/p6.stderr index 9b6c0cfdb4..ec7cd64bb3 100644 --- a/testsuite/tests/safeHaskell/ghci/p6.stderr +++ b/testsuite/tests/safeHaskell/ghci/p6.stderr @@ -1,7 +1,7 @@ <interactive>:12:1: - Unacceptable result type in foreign declaration: Double - Safe Haskell is on, all FFI imports must be in the IO monad + Unacceptable result type in foreign declaration: + Safe Haskell is on, all FFI imports must be in the IO monad When checking declaration: foreign import ccall safe "static sin" c_sin :: Double -> Double diff --git a/testsuite/tests/safeHaskell/safeInfered/SafeInfered05.hs b/testsuite/tests/safeHaskell/safeInfered/SafeInfered05.hs new file mode 100644 index 0000000000..0b42002b25 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/SafeInfered05.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | +-- This module should actually fail to compile since we have the instances C +-- [Int] from the -XSafe module SafeInfered05_A overlapping as the most +-- specific instance the other instance C [a] from this module. This is in +-- violation of our single-origin-policy. +-- +-- Right now though, the above actually compiles fine but *this is a bug*. +-- Compiling module SafeInfered05_A with -XSafe has the right affect of causing +-- the compilation of module SafeInfered05 to then subsequently fail. So we +-- have a discrepancy between a safe-inferred module and a -XSafe module, which +-- there should not be. +-- +-- It does raise a question of if this bug should be fixed. Right now we've +-- designed Safe Haskell to be completely opt-in, even with safe-inference. +-- Fixing this of course changes this, causing safe-inference to alter the +-- compilation success of some cases. How common it is to have overlapping +-- declarations without -XOverlappingInstances specified needs to be tested. +-- +module SafeInfered05 where + +import safe SafeInfered05_A + +instance C [a] where + f _ = "[a]" + +test2 :: String +test2 = f ([1,2,3,4] :: [Int]) + diff --git a/testsuite/tests/safeHaskell/safeInfered/SafeInfered05_A.hs b/testsuite/tests/safeHaskell/safeInfered/SafeInfered05_A.hs new file mode 100644 index 0000000000..a1e12a6526 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/SafeInfered05_A.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE FlexibleInstances #-} +module SafeInfered05_A where + +class C a where + f :: a -> String + +instance C [Int] where + f _ = "[Int]" + diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered08_A.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered08_A.hs index 13f22ce3d7..4cd276fafd 100644 --- a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered08_A.hs +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered08_A.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS_GHC -w #-} -- Turn off deprecation for OverlappingInstances -- | Unsafe as uses overlapping instances -- Although it isn't defining any so can we mark safe -- still? diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered13.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered13.hs new file mode 100644 index 0000000000..defc3a5243 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered13.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -fwarn-unsafe -Werror #-} +{-# LANGUAGE FlexibleInstances #-} +module UnsafeInfered13 where + +class C a where + f :: a -> String + +instance {-# OVERLAPS #-} C a where + f _ = "a" + diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered13.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered13.stderr new file mode 100644 index 0000000000..c545d40308 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered13.stderr @@ -0,0 +1,7 @@ + +UnsafeInfered13.hs:1:16: Warning: + ‘UnsafeInfered13’ has been inferred as unsafe! + Reason: + +<no location info>: +Failing due to -Werror. diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.hs new file mode 100644 index 0000000000..5b9f64210f --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -fwarn-unsafe -Werror #-} +{-# LANGUAGE FlexibleInstances #-} +module UnsafeInfered14 where + +class C a where + f :: a -> String + +instance {-# OVERLAPPABLE #-} C a where + f _ = "a" + diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.stderr new file mode 100644 index 0000000000..b7c41ac6c3 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered14.stderr @@ -0,0 +1,7 @@ + +UnsafeInfered14.hs:1:16: Warning: + ‘UnsafeInfered14’ has been inferred as unsafe! + Reason: + +<no location info>: +Failing due to -Werror. diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.hs b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.hs new file mode 100644 index 0000000000..427c97b0ac --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -fwarn-unsafe -Werror #-} +{-# LANGUAGE FlexibleInstances #-} +module UnsafeInfered15 where + +class C a where + f :: a -> String + +instance {-# OVERLAPPING #-} C a where + f _ = "a" + diff --git a/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.stderr b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.stderr new file mode 100644 index 0000000000..dbf20949f7 --- /dev/null +++ b/testsuite/tests/safeHaskell/safeInfered/UnsafeInfered15.stderr @@ -0,0 +1,7 @@ + +UnsafeInfered15.hs:1:16: Warning: + ‘UnsafeInfered15’ has been inferred as unsafe! + Reason: + +<no location info>: +Failing due to -Werror. diff --git a/testsuite/tests/safeHaskell/safeInfered/all.T b/testsuite/tests/safeHaskell/safeInfered/all.T index 47e9656279..a995c76c6d 100644 --- a/testsuite/tests/safeHaskell/safeInfered/all.T +++ b/testsuite/tests/safeHaskell/safeInfered/all.T @@ -21,6 +21,11 @@ test('SafeInfered04', [ extra_clean(['SafeInfered04_A.hi', 'SafeInfered04_A.o']) ], multimod_compile, ['SafeInfered04', '']) +# Test should fail, tests an earlier bug in 7.8 +# test('SafeInfered05', +# [ extra_clean(['SafeInfered05_A.hi', 'SafeInfered05_A.o']) ], +# multimod_compile_fail, ['SafeInfered05', '']) + # Tests that should fail to compile as they should be infered unsafe test('UnsafeInfered01', [ extra_clean(['UnsafeInfered01_A.hi', 'UnsafeInfered01_A.o']) ], @@ -56,8 +61,11 @@ test('UnsafeInfered11', [ extra_clean(['UnsafeInfered11_A.hi', 'UnsafeInfered11_A.o']) ], multimod_compile_fail, ['UnsafeInfered11', '']) -# test should fail as unsafe and we made warn unsafe + -Werror +# Test should fail as unsafe and we made warn unsafe + -Werror test('UnsafeInfered12', normal, compile_fail, ['']) +test('UnsafeInfered13', normal, compile_fail, ['']) +test('UnsafeInfered14', normal, compile_fail, ['']) +test('UnsafeInfered15', normal, compile_fail, ['']) # Mixed tests test('Mixed01', normal, compile_fail, ['']) diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang08.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang08.stderr index 7785b2459e..7d06e2f11c 100644 --- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang08.stderr +++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang08.stderr @@ -1,7 +1,7 @@ SafeLang08.hs:9:1: - Unacceptable result type in foreign declaration: Double - Safe Haskell is on, all FFI imports must be in the IO monad + Unacceptable result type in foreign declaration: + Safe Haskell is on, all FFI imports must be in the IO monad When checking declaration: foreign import ccall safe "static SafeLang08_A" c_sin :: CDouble -> CDouble diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stderr index 83c79da75f..d0c5c68d6a 100644 --- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stderr +++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stderr @@ -6,8 +6,8 @@ SafeLang10.hs:8:13: Unsafe overlapping instances for Pos [Int] arising from a use of ‘res’ The matching instance is: - instance [overlap ok] [safe] Pos [Int] - -- Defined at SafeLang10_B.hs:14:10 + instance [overlapping] [safe] Pos [Int] + -- Defined at SafeLang10_B.hs:13:30 It is compiled in a Safe module and as such can only overlap instances from the same module, however it overlaps the following instances from different modules: diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang10_B.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang10_B.hs index 5b9954c12e..d9a8f63f50 100644 --- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang10_B.hs +++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang10_B.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE Safe #-} -- Untrusted plugin! Don't wan't it changing behaviour of our @@ -8,10 +7,10 @@ module SafeLang10_B where import SafeLang10_A -instance Pos a where +instance {-# OVERLAPPABLE #-} Pos a where res _ = False -instance Pos [Int] where +instance {-# OVERLAPPING #-} Pos [Int] where res _ = error "This curry is poisoned!" function :: Int diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang14.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang14.stderr index af8dca390d..c0f94d5490 100644 --- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang14.stderr +++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang14.stderr @@ -2,7 +2,11 @@ [2 of 2] Compiling Main ( SafeLang14.hs, SafeLang14.o ) SafeLang14.hs:14:10: - Can't create hand written instances of Typeable in Safe Haskell! Can only derive them + Typeable instances can only be derived in Safe Haskell. + Replace the following instance: + instance [safe] Typeable G SafeLang14.hs:17:10: - Can't create hand written instances of Typeable in Safe Haskell! Can only derive them + Typeable instances can only be derived in Safe Haskell. + Replace the following instance: + instance [safe] Typeable P diff --git a/testsuite/tests/safeHaskell/unsafeLibs/BadImport03.stderr b/testsuite/tests/safeHaskell/unsafeLibs/BadImport03.stderr index 03b8028671..d32e33f78f 100644 --- a/testsuite/tests/safeHaskell/unsafeLibs/BadImport03.stderr +++ b/testsuite/tests/safeHaskell/unsafeLibs/BadImport03.stderr @@ -2,4 +2,6 @@ [2 of 2] Compiling Main ( BadImport03.hs, BadImport03.o ) BadImport03.hs:16:10: - Can't create hand written instances of Typeable in Safe Haskell! Can only derive them + Typeable instances can only be derived in Safe Haskell. + Replace the following instance: + instance [safe] Typeable NInt diff --git a/testsuite/tests/simplCore/should_compile/Makefile b/testsuite/tests/simplCore/should_compile/Makefile index ca0d552355..605d3a598a 100644 --- a/testsuite/tests/simplCore/should_compile/Makefile +++ b/testsuite/tests/simplCore/should_compile/Makefile @@ -17,12 +17,12 @@ T3055: T5658b: $(RM) -f T5658b.o T5658b.hi - '$(TEST_HC)' $(TEST_HC_OPTS) -O -c T5658b.hs -ddump-simpl | grep --count indexIntArray + '$(TEST_HC)' $(TEST_HC_OPTS) -O -c T5658b.hs -ddump-simpl | grep -c indexIntArray # Trac 5658 meant that there were three calls to indexIntArray instead of two T5776: $(RM) -f T5776.o T5776.hi - '$(TEST_HC)' $(TEST_HC_OPTS) -O -c T5776.hs -ddump-rules | grep --count dEq + '$(TEST_HC)' $(TEST_HC_OPTS) -O -c T5776.hs -ddump-rules | grep -c dEq T3772: $(RM) -f T3772*.hi T3772*.o diff --git a/testsuite/tests/simplCore/should_compile/T4398.stderr b/testsuite/tests/simplCore/should_compile/T4398.stderr index 63d1ab3042..2f1f567d49 100644 --- a/testsuite/tests/simplCore/should_compile/T4398.stderr +++ b/testsuite/tests/simplCore/should_compile/T4398.stderr @@ -1,3 +1,22 @@ - -T4398.hs:5:11: Warning: - Forall'd constraint ‘Ord a’ is not bound in RULE lhs f @ a x y +
+T4398.hs:5:11: Warning:
+ Forall'd constraint ‘Ord a’ is not bound in RULE lhs
+ Orig bndrs: [a, $dOrd, x, y]
+ Orig lhs: let {
+ $dEq :: Eq a
+ [LclId, Str=DmdType]
+ $dEq = GHC.Classes.$p1Ord @ a $dOrd } in
+ f @ a
+ ((\ ($dOrd :: Ord a) ->
+ let {
+ $dEq :: Eq a
+ [LclId, Str=DmdType]
+ $dEq = GHC.Classes.$p1Ord @ a $dOrd } in
+ let {
+ $dEq :: Eq a
+ [LclId, Str=DmdType]
+ $dEq = GHC.Classes.$p1Ord @ a $dOrd } in
+ x)
+ $dOrd)
+ y
+ optimised lhs: f @ a x y
diff --git a/testsuite/tests/simplCore/should_compile/T5359b.hs b/testsuite/tests/simplCore/should_compile/T5359b.hs index 6348defdd1..f1ce2091a9 100644 --- a/testsuite/tests/simplCore/should_compile/T5359b.hs +++ b/testsuite/tests/simplCore/should_compile/T5359b.hs @@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} diff --git a/testsuite/tests/simplCore/should_compile/T5359b.stderr b/testsuite/tests/simplCore/should_compile/T5359b.stderr index 75dde28fcc..2802476a2d 100644 --- a/testsuite/tests/simplCore/should_compile/T5359b.stderr +++ b/testsuite/tests/simplCore/should_compile/T5359b.stderr @@ -1,3 +1,3 @@ -T5359b.hs:62:1: Warning: +T5359b.hs:61:1: Warning: SPECIALISE pragma on INLINE function probably won't fire: ‘genum’ diff --git a/testsuite/tests/simplCore/should_compile/T8331.hs b/testsuite/tests/simplCore/should_compile/T8331.hs new file mode 100644 index 0000000000..04cb1aff73 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T8331.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleInstances, RankNTypes #-} + +module Main ( main, useAbstractMonad ) where + +import Control.Monad +import Control.Monad.ST +import Control.Applicative + +newtype ReaderT r m a = ReaderT { + -- | The underlying computation, as a function of the environment. + runReaderT :: r -> m a + } + +instance (Applicative m) => Applicative (ReaderT r m) where + pure = liftReaderT . pure + f <*> v = ReaderT $ \ r -> runReaderT f r <*> runReaderT v r + +instance (Functor m) => Functor (ReaderT r m) where + fmap f = mapReaderT (fmap f) + +instance (Monad m) => Monad (ReaderT r m) where + return x = ReaderT (\_ -> return x) + m >>= k = ReaderT $ \ r -> do + a <- runReaderT m r + runReaderT (k a) r + fail msg = ReaderT (\_ -> fail msg) + +mapReaderT :: (m a -> n b) -> ReaderT r m a -> ReaderT r n b +mapReaderT f m = ReaderT $ f . runReaderT m + +liftReaderT :: m a -> ReaderT r m a +liftReaderT m = ReaderT (const m) + +ask :: (Monad m) => ReaderT r m r +ask = ReaderT return + +class (Applicative m, Functor m , Monad m) => MonadAbstractIOST m where + addstuff :: Int -> m Int + +type ReaderST s = ReaderT (Int) (ST s) + +instance MonadAbstractIOST (ReaderST s) where + addstuff a = return . (a +) =<< ask + +runAbstractST :: (forall s. ReaderST s a) -> a +runAbstractST f = runST $ runReaderT f 99 + +{-# SPECIALIZE useAbstractMonad :: Int -> ReaderST s Int #-} +-- Note the polymorphism +useAbstractMonad :: MonadAbstractIOST m => Int -> m Int +useAbstractMonad n = foldM (\a b -> a `seq` return . (a +) =<< (addstuff b)) 0 [1..n] + +-- useConcreteMonad :: Int -> ReaderST s Int +-- useConcreteMonad = foldM (\a b -> a `seq` return . (a +) =<< (addstuff b)) 0 [1..n] + +main :: IO () +main = do + let st = runAbstractST (useAbstractMonad 5000000) + putStrLn . show $ st diff --git a/testsuite/tests/simplCore/should_compile/T8331.stderr b/testsuite/tests/simplCore/should_compile/T8331.stderr new file mode 100644 index 0000000000..1b3c21eaea --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T8331.stderr @@ -0,0 +1,9 @@ + +==================== Tidy Core rules ==================== +"SPEC useAbstractMonad" [ALWAYS] + forall (@ s) + ($dMonadAbstractIOST :: MonadAbstractIOST (ReaderT Int (ST s))). + useAbstractMonad @ (ReaderT Int (ST s)) $dMonadAbstractIOST + = useAbstractMonad_$suseAbstractMonad @ s + + diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 616b6cc359..f9a5846eac 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -95,7 +95,7 @@ test('EvalTest', test('T3831', normal, compile, ['']) test('T4345', normal, compile, ['']) -test('T4398', normal, compile, ['']) +test('T4398', normal, compile, ['-dsuppress-uniques']) test('T4903', extra_clean(['T4903a.hi', 'T4903a.o']), @@ -198,8 +198,9 @@ test('T5996', ['$MAKE -s --no-print-directory T5996']) test('T8537', normal, compile, ['']) test('T8832', - extra_clean(['T8832.hi', 'T8832a.o']), + [when(wordsize(32), expect_fail), extra_clean(['T8832.hi', 'T8832a.o'])], run_command, ['$MAKE -s --no-print-directory T8832']) test('T8848', only_ways(['optasm']), compile, ['-ddump-rule-firings']) test('T8848a', only_ways(['optasm']), compile, ['-ddump-rules']) +test('T8331', only_ways(['optasm']), compile, ['-ddump-rules']) diff --git a/testsuite/tests/simplCore/should_compile/simpl007.hs b/testsuite/tests/simplCore/should_compile/simpl007.hs index 2b42cc29ee..c7277b7f66 100644 --- a/testsuite/tests/simplCore/should_compile/simpl007.hs +++ b/testsuite/tests/simplCore/should_compile/simpl007.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverlappingInstances, UndecidableInstances, +{-# LANGUAGE UndecidableInstances, ExistentialQuantification, FlexibleInstances #-} -- module Formula where @@ -186,7 +186,7 @@ class AddT a where addT :: a -> Formula -> Maybe Formula addT _ _ = Nothing -instance (FORMULA a) => AddT a where {} +instance {-# OVERLAPPABLE #-} (FORMULA a) => AddT a where {} instance AddT Formula where addT (Formula f) = addT f diff --git a/testsuite/tests/simplCore/should_compile/simpl016.stderr b/testsuite/tests/simplCore/should_compile/simpl016.stderr index 2ac4e4f95b..e08b16db8d 100644 --- a/testsuite/tests/simplCore/should_compile/simpl016.stderr +++ b/testsuite/tests/simplCore/should_compile/simpl016.stderr @@ -1,4 +1,10 @@ - -simpl016.hs:5:1: Warning: - Forall'd constraint ‘Num b’ is not bound in RULE lhs - delta' @ Int @ b $dEq +
+simpl016.hs:5:1: Warning:
+ Forall'd constraint ‘Num b’ is not bound in RULE lhs
+ Orig bndrs: [b, $dNum]
+ Orig lhs: let {
+ $dEq :: Eq Int
+ [LclId, Str=DmdType]
+ $dEq = GHC.Classes.$fEqInt } in
+ delta' @ Int @ b $dEq
+ optimised lhs: delta' @ Int @ b $dEq
diff --git a/testsuite/tests/simplCore/should_run/.gitignore b/testsuite/tests/simplCore/should_run/.gitignore deleted file mode 100644 index 2399b83105..0000000000 --- a/testsuite/tests/simplCore/should_run/.gitignore +++ /dev/null @@ -1,4 +0,0 @@ -T2110 -T457 -runST -simplrun011 diff --git a/testsuite/tests/simplCore/should_run/T9390.hs b/testsuite/tests/simplCore/should_run/T9390.hs new file mode 100644 index 0000000000..04b4da0e4d --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T9390.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +module Main(main ) where + +import GHC.IO (IO (..)) +import GHC.Prim + +writeB :: MutableArray# RealWorld Char -> IO () +writeB arr# = IO $ \s0# -> (# writeArray# arr# 0# 'B' s0#, () #) + +inlineWriteB :: MutableArray# RealWorld Char -> () +inlineWriteB arr# = + case f realWorld# of + (# _, x #) -> x + where + IO f = writeB arr# + +test :: IO Char +test = IO $ \s0# -> + case newArray# 1# 'A' s0# of + (# s1#, arr# #) -> + case seq# (inlineWriteB arr#) s1# of + (# s2#, () #) -> + readArray# arr# 0# s2# + +main :: IO () +main = test >>= print + diff --git a/testsuite/tests/simplCore/should_run/T9390.stdout b/testsuite/tests/simplCore/should_run/T9390.stdout new file mode 100644 index 0000000000..69349b451d --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T9390.stdout @@ -0,0 +1 @@ +'B' diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T index e36fb00f0f..93dc4c66f9 100644 --- a/testsuite/tests/simplCore/should_run/all.T +++ b/testsuite/tests/simplCore/should_run/all.T @@ -67,3 +67,4 @@ test('T7924', exit_code(1), compile_and_run, ['']) test('T457', [ only_ways(['normal','optasm']), exit_code(1) ], compile_and_run, ['']) test('T9128', normal, compile_and_run, ['']) +test('T9390', normal, compile_and_run, ['']) diff --git a/testsuite/tests/stranal/should_run/T8425/.gitignore b/testsuite/tests/stranal/should_run/T8425/.gitignore deleted file mode 100644 index 881fef889a..0000000000 --- a/testsuite/tests/stranal/should_run/T8425/.gitignore +++ /dev/null @@ -1 +0,0 @@ -T8425 diff --git a/testsuite/tests/stranal/should_run/T9254.hs b/testsuite/tests/stranal/should_run/T9254.hs new file mode 100644 index 0000000000..279eb5c1ec --- /dev/null +++ b/testsuite/tests/stranal/should_run/T9254.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +module Main where +import GHC.Exts + +f :: (() -> (# Int#, () #)) -> () +{-# NOINLINE f #-} +-- Strictness signature was (7.8.2) +-- <C(S(LS)), 1*C1(U(A,1*U()))> +-- I.e. calls k, but discards first component of result +f k = case k () of (# _, r #) -> r + +g :: Int -> () +g y = f (\n -> (# case y of I# y2 -> h (h (h (h (h (h (h y2)))))), n #)) + -- RHS is big enough to force worker/wrapper + +{-# NOINLINE h #-} +h :: Int# -> Int# +h n = n +# 1# + +main = print (g 1) diff --git a/testsuite/tests/stranal/should_run/T9254.stdout b/testsuite/tests/stranal/should_run/T9254.stdout new file mode 100644 index 0000000000..6a452c185a --- /dev/null +++ b/testsuite/tests/stranal/should_run/T9254.stdout @@ -0,0 +1 @@ +() diff --git a/testsuite/tests/stranal/should_run/all.T b/testsuite/tests/stranal/should_run/all.T index 0c43aac8c4..2ca65b5110 100644 --- a/testsuite/tests/stranal/should_run/all.T +++ b/testsuite/tests/stranal/should_run/all.T @@ -7,3 +7,4 @@ test('strun003', normal, compile_and_run, ['']) test('strun004', normal, compile_and_run, ['']) test('T2756b', normal, compile_and_run, ['']) test('T7649', normal, compile_and_run, ['']) +test('T9254', normal, compile_and_run, ['']) diff --git a/testsuite/tests/th/.gitignore b/testsuite/tests/th/.gitignore deleted file mode 100644 index 86cbf4705e..0000000000 --- a/testsuite/tests/th/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -T8186 -T8633 diff --git a/testsuite/tests/th/T4135a.hs b/testsuite/tests/th/T4135a.hs index 41549cad40..d78de088a0 100644 --- a/testsuite/tests/th/T4135a.hs +++ b/testsuite/tests/th/T4135a.hs @@ -1,5 +1,5 @@ {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeFamilies, - FlexibleInstances, OverlappingInstances #-} + FlexibleInstances #-} module T4135a where diff --git a/testsuite/tests/typecheck/should_compile/.gitignore b/testsuite/tests/typecheck/should_compile/.gitignore deleted file mode 100644 index 396a094472..0000000000 --- a/testsuite/tests/typecheck/should_compile/.gitignore +++ /dev/null @@ -1 +0,0 @@ -tc263 diff --git a/testsuite/tests/typecheck/should_compile/FD4.hs b/testsuite/tests/typecheck/should_compile/FD4.hs index 5d5869ca01..dcf25f7293 100644 --- a/testsuite/tests/typecheck/should_compile/FD4.hs +++ b/testsuite/tests/typecheck/should_compile/FD4.hs @@ -2,7 +2,6 @@ MultiParamTypeClasses,
FunctionalDependencies,
UndecidableInstances,
- OverlappingInstances,
FlexibleInstances,
EmptyDataDecls #-}
diff --git a/testsuite/tests/typecheck/should_compile/LoopOfTheDay3.hs b/testsuite/tests/typecheck/should_compile/LoopOfTheDay3.hs index dce1601a70..f1c1b49839 100644 --- a/testsuite/tests/typecheck/should_compile/LoopOfTheDay3.hs +++ b/testsuite/tests/typecheck/should_compile/LoopOfTheDay3.hs @@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, - OverlappingInstances, UndecidableInstances #-} + UndecidableInstances #-} -- Instances compile fine but instance selection loops in GHC 6.2. -- try: :t foo (T1a 1) diff --git a/testsuite/tests/typecheck/should_compile/Makefile b/testsuite/tests/typecheck/should_compile/Makefile index 518f923689..e361556f8f 100644 --- a/testsuite/tests/typecheck/should_compile/Makefile +++ b/testsuite/tests/typecheck/should_compile/Makefile @@ -9,8 +9,8 @@ tc170: tc173: $(RM) Tc173a.o Tc173a.hi Tc173b.o Tc173b.hi - '$(TEST_HC)' $(TEST_HC_OPTS) -c -XFlexibleInstances -XTypeSynonymInstances -XUndecidableInstances -XOverlappingInstances Tc173a.hs - '$(TEST_HC)' $(TEST_HC_OPTS) -c -XUndecidableInstances -XOverlappingInstances Tc173b.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -c Tc173a.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -c Tc173b.hs T2412: $(RM) -f T2412.hi-boot T2412.o-boot T2412A.hi T2412A.o T2412.hi T2412.o diff --git a/testsuite/tests/typecheck/should_compile/T1470.hs b/testsuite/tests/typecheck/should_compile/T1470.hs index d466e487e9..2482696452 100644 --- a/testsuite/tests/typecheck/should_compile/T1470.hs +++ b/testsuite/tests/typecheck/should_compile/T1470.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, OverlappingInstances, UndecidableInstances, KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, KindSignatures #-} -- Trac #1470 @@ -15,10 +15,9 @@ data FooD a = FooD instance Foo t => Sat (FooD t) -instance Data FooD a => Foo a - - -instance Foo a => Foo [a] +instance {-# OVERLAPPABLE #-} Data FooD a => Foo a +instance {-# OVERLAPS #-} Foo a => Foo [a] +instance {-# OVERLAPPING #-} Foo [Char] {- Given: Foo a, and its superclasses: Data FooD a @@ -35,4 +34,3 @@ instance Foo a => Foo [a] BUT THIS INSTANCE OVERLAPS -} -instance Foo [Char] diff --git a/testsuite/tests/typecheck/should_compile/T3018.hs b/testsuite/tests/typecheck/should_compile/T3018.hs index a0868afa24..443d73a17a 100644 --- a/testsuite/tests/typecheck/should_compile/T3018.hs +++ b/testsuite/tests/typecheck/should_compile/T3018.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverlappingInstances , UndecidableInstances, EmptyDataDecls #-} +{-# LANGUAGE UndecidableInstances, EmptyDataDecls #-} {-# LANGUAGE RankNTypes, KindSignatures, MultiParamTypeClasses, FlexibleInstances #-} -- Works with new constraint solver diff --git a/testsuite/tests/typecheck/should_compile/T3108.hs b/testsuite/tests/typecheck/should_compile/T3108.hs index 774d5f3801..2adaa1aef7 100644 --- a/testsuite/tests/typecheck/should_compile/T3108.hs +++ b/testsuite/tests/typecheck/should_compile/T3108.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverlappingInstances, UndecidableInstances, MultiParamTypeClasses, +{-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} module T3108 where @@ -10,9 +10,9 @@ class C0 x m0 :: x -> () m0 = const undefined -instance (C0 x, C0 y) => C0 (x,y) -instance C0 Bool -instance C0 (x,Bool) => C0 x +instance {-# OVERLAPPING #-} (C0 x, C0 y) => C0 (x,y) +instance {-# OVERLAPPING #-} C0 Bool +instance {-# OVERLAPPABLE #-} C0 (x,Bool) => C0 x foo :: () foo = m0 (1::Int) @@ -25,9 +25,9 @@ class C1 x m1 :: x -> () m1 = const undefined -instance (C1 x, C1 y) => C1 (x,y) -instance C1 Bool -instance (C2 x y, C1 (y,Bool)) => C1 x +instance {-# OVERLAPPING #-} (C1 x, C1 y) => C1 (x,y) +instance {-# OVERLAPPING #-} C1 Bool +instance {-# OVERLAPPABLE #-} (C2 x y, C1 (y,Bool)) => C1 x class C2 x y | x -> y instance C2 Int Int diff --git a/testsuite/tests/typecheck/should_compile/T5481.stderr b/testsuite/tests/typecheck/should_compile/T5481.stderr index df5d23b360..719c4ce5c7 100644 --- a/testsuite/tests/typecheck/should_compile/T5481.stderr +++ b/testsuite/tests/typecheck/should_compile/T5481.stderr @@ -1,8 +1,4 @@ -T5481.hs:6:5: - The RHS of an associated type declaration mentions type variable ‘b’ - All such variables must be bound on the LHS +T5481.hs:6:16: Not in scope: type variable ‘b’ -T5481.hs:8:5: - The RHS of an associated type declaration mentions type variable ‘a’ - All such variables must be bound on the LHS +T5481.hs:8:16: Not in scope: type variable ‘a’ diff --git a/testsuite/tests/typecheck/should_compile/Tc173a.hs b/testsuite/tests/typecheck/should_compile/Tc173a.hs index c8a589d2b3..f3704ccd9a 100644 --- a/testsuite/tests/typecheck/should_compile/Tc173a.hs +++ b/testsuite/tests/typecheck/should_compile/Tc173a.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, UndecidableInstances #-} module Tc173a where class FormValue value where @@ -8,10 +9,10 @@ class FormTextField value instance FormTextField String -instance FormTextField value => FormTextFieldIO value +instance {-# OVERLAPPABLE #-} FormTextField value => FormTextFieldIO value class FormTextFieldIO value instance FormTextFieldIO value => FormValue value -instance FormTextFieldIO value => FormTextFieldIO (Maybe value) +instance {-# OVERLAPPING #-} FormTextFieldIO value => FormTextFieldIO (Maybe value) diff --git a/testsuite/tests/typecheck/should_compile/Tc173b.hs b/testsuite/tests/typecheck/should_compile/Tc173b.hs index c98c57acd8..d14663d866 100644 --- a/testsuite/tests/typecheck/should_compile/Tc173b.hs +++ b/testsuite/tests/typecheck/should_compile/Tc173b.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances #-} module Tc173b where import Tc173a diff --git a/testsuite/tests/typecheck/should_compile/tc176.hs b/testsuite/tests/typecheck/should_compile/tc176.hs index d05ccdbe29..94fdcb2227 100644 --- a/testsuite/tests/typecheck/should_compile/tc176.hs +++ b/testsuite/tests/typecheck/should_compile/tc176.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, OverlappingInstances #-} +{-# LANGUAGE FlexibleInstances #-} {- With "hugs -98 +o test.hs" gives me: ERROR "test.hs":8 - Cannot justify constraints in instance member binding @@ -29,8 +29,8 @@ class FromStr a where typeError :: FromStr a => a -> a typeError t = error "type error" -instance FromStr [a] where +instance {-# OVERLAPPABLE #-} FromStr [a] where fromStr _ = typeError undefined -- line 8 -instance FromStr [(String,a)] where -- line 10 +instance {-# OVERLAPPING #-} FromStr [(String,a)] where -- line 10 fromStr _ = typeError undefined -- line 11 diff --git a/testsuite/tests/typecheck/should_compile/tc179.hs b/testsuite/tests/typecheck/should_compile/tc179.hs index 110950587d..62db4726a0 100644 --- a/testsuite/tests/typecheck/should_compile/tc179.hs +++ b/testsuite/tests/typecheck/should_compile/tc179.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE ExistentialQuantification, FlexibleInstances, - OverlappingInstances, UndecidableInstances #-} +{-# LANGUAGE ExistentialQuantification, FlexibleInstances, UndecidableInstances #-} -- Tests context reduction for existentials @@ -7,9 +6,9 @@ module TestWrappedNode where class Foo a where { op :: a -> Int } -instance Foo a => Foo [a] where -- NB overlap +instance {-# OVERLAPPABLE #-} Foo a => Foo [a] where -- NB overlap op (x:xs) = op x -instance Foo [Int] where -- NB overlap +instance {-# OVERLAPPING #-} Foo [Int] where -- NB overlap op x = 1 data T = forall a. Foo a => MkT a diff --git a/testsuite/tests/typecheck/should_compile/tc253.hs b/testsuite/tests/typecheck/should_compile/tc253.hs index 4771b82435..3ce439e4f2 100644 --- a/testsuite/tests/typecheck/should_compile/tc253.hs +++ b/testsuite/tests/typecheck/should_compile/tc253.hs @@ -4,8 +4,11 @@ module ShouldCompile where class Cls a where type Fam a b :: * -- Multiple defaults! - type Fam a Bool = Maybe a - type Fam a Int = (String, a) + type Fam a x = FamHelper a x + +type family FamHelper a x +type instance FamHelper a Bool = Maybe a +type instance FamHelper a Int = (String, a) instance Cls Int where -- Gets type family from default diff --git a/testsuite/tests/typecheck/should_fail/AssocTyDef02.stderr b/testsuite/tests/typecheck/should_fail/AssocTyDef02.stderr index 9b3ac0e364..b310a79a6f 100644 --- a/testsuite/tests/typecheck/should_fail/AssocTyDef02.stderr +++ b/testsuite/tests/typecheck/should_fail/AssocTyDef02.stderr @@ -1,6 +1,6 @@ -AssocTyDef02.hs:6:10: - Type indexes must match class instance head - Found ‘[b]’ but expected ‘a’ - In the type synonym instance default declaration for ‘Typ’ - In the class declaration for ‘Cls’ +AssocTyDef02.hs:6:14: + Unexpected type ‘[b]’ + In the default declaration for ‘Typ’ + A default declaration should have form + default Typ a = ... diff --git a/testsuite/tests/typecheck/should_fail/AssocTyDef03.stderr b/testsuite/tests/typecheck/should_fail/AssocTyDef03.stderr index e62a2afcc5..c0950bcc74 100644 --- a/testsuite/tests/typecheck/should_fail/AssocTyDef03.stderr +++ b/testsuite/tests/typecheck/should_fail/AssocTyDef03.stderr @@ -1,5 +1,5 @@ - -AssocTyDef03.hs:6:5: - Wrong category of family instance; declaration was for a data type - In the type instance declaration for ‘Typ’ - In the class declaration for ‘Cls’ +
+AssocTyDef03.hs:6:5:
+ Wrong category of family instance; declaration was for a data type
+ In the default type instance declaration for ‘Typ’
+ In the class declaration for ‘Cls’
diff --git a/testsuite/tests/typecheck/should_fail/AssocTyDef04.stderr b/testsuite/tests/typecheck/should_fail/AssocTyDef04.stderr index 550d09895f..4fbaaef199 100644 --- a/testsuite/tests/typecheck/should_fail/AssocTyDef04.stderr +++ b/testsuite/tests/typecheck/should_fail/AssocTyDef04.stderr @@ -1,7 +1,7 @@ - -AssocTyDef04.hs:6:18: - Expecting one more argument to ‘Maybe’ - Expected kind ‘*’, but ‘Maybe’ has kind ‘* -> *’ - In the type ‘Maybe’ - In the type instance declaration for ‘Typ’ - In the class declaration for ‘Cls’ +
+AssocTyDef04.hs:6:18:
+ Expecting one more argument to ‘Maybe’
+ Expected kind ‘*’, but ‘Maybe’ has kind ‘* -> *’
+ In the type ‘Maybe’
+ In the default type instance declaration for ‘Typ’
+ In the class declaration for ‘Cls’
diff --git a/testsuite/tests/typecheck/should_fail/AssocTyDef05.stderr b/testsuite/tests/typecheck/should_fail/AssocTyDef05.stderr index 8f5b5a5316..660d081ca3 100644 --- a/testsuite/tests/typecheck/should_fail/AssocTyDef05.stderr +++ b/testsuite/tests/typecheck/should_fail/AssocTyDef05.stderr @@ -1,5 +1,5 @@ - -AssocTyDef05.hs:6:10: - Number of parameters must match family declaration; expected 1 - In the type synonym instance default declaration for ‘Typ’ - In the class declaration for ‘Cls’ +
+AssocTyDef05.hs:6:5:
+ Number of parameters must match family declaration; expected 1
+ In the default type instance declaration for ‘Typ’
+ In the class declaration for ‘Cls’
diff --git a/testsuite/tests/typecheck/should_fail/AssocTyDef06.stderr b/testsuite/tests/typecheck/should_fail/AssocTyDef06.stderr index 29db541832..665ad223d2 100644 --- a/testsuite/tests/typecheck/should_fail/AssocTyDef06.stderr +++ b/testsuite/tests/typecheck/should_fail/AssocTyDef06.stderr @@ -1,5 +1,6 @@ - -AssocTyDef06.hs:6:10: - Number of parameters must match family declaration; expected no more than 1 - In the type instance declaration for ‘Typ’ - In the class declaration for ‘Cls’ +
+AssocTyDef06.hs:6:16:
+ Unexpected type ‘Int’
+ In the default declaration for ‘Typ’
+ A default declaration should have form
+ default Typ a b = ...
diff --git a/testsuite/tests/typecheck/should_fail/LongWayOverlapping.hs b/testsuite/tests/typecheck/should_fail/LongWayOverlapping.hs index 4a79e69ed6..663143ceb4 100644 --- a/testsuite/tests/typecheck/should_fail/LongWayOverlapping.hs +++ b/testsuite/tests/typecheck/should_fail/LongWayOverlapping.hs @@ -1,7 +1,6 @@ {-# LANGUAGE TypeFamilies, MultiParamTypeClasses
, FlexibleContexts, FlexibleInstances, UndecidableInstances
, TypeSynonymInstances, GeneralizedNewtypeDeriving
- , OverlappingInstances
#-}
module LongWayOverlapping where
diff --git a/testsuite/tests/typecheck/should_fail/LongWayOverlapping.stderr b/testsuite/tests/typecheck/should_fail/LongWayOverlapping.stderr index 753ee0f2af..f1eb2db530 100644 --- a/testsuite/tests/typecheck/should_fail/LongWayOverlapping.stderr +++ b/testsuite/tests/typecheck/should_fail/LongWayOverlapping.stderr @@ -1,5 +1,5 @@ -LongWayOverlapping.hs:23:11: +LongWayOverlapping.hs:22:11: No instance for (EmbAsChild [Char] Char) arising from a use of ‘emb’ In the expression: emb 'c' diff --git a/testsuite/tests/typecheck/should_fail/T2307.hs b/testsuite/tests/typecheck/should_fail/T2307.hs index 321c2d5641..ea0c335a96 100644 --- a/testsuite/tests/typecheck/should_fail/T2307.hs +++ b/testsuite/tests/typecheck/should_fail/T2307.hs @@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, - OverlappingInstances, UndecidableInstances, + UndecidableInstances, IncoherentInstances, FlexibleInstances #-} diff --git a/testsuite/tests/typecheck/should_fail/T5051.hs b/testsuite/tests/typecheck/should_fail/T5051.hs index 6c5faf9170..e3278d83d3 100644 --- a/testsuite/tests/typecheck/should_fail/T5051.hs +++ b/testsuite/tests/typecheck/should_fail/T5051.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE FlexibleInstances, OverlappingInstances #-} +{-# LANGUAGE FlexibleInstances #-} -- A very delicate interaction of overlapping instances module T5051 where data T = T deriving( Eq, Ord ) -instance Eq [T] +instance {-# OVERLAPPING #-} Eq [T] foo :: Ord a => [a] -> Bool foo x = x >= x diff --git a/testsuite/tests/typecheck/should_fail/T5051.stderr b/testsuite/tests/typecheck/should_fail/T5051.stderr index f6225ea406..3fc46f9e98 100644 --- a/testsuite/tests/typecheck/should_fail/T5051.stderr +++ b/testsuite/tests/typecheck/should_fail/T5051.stderr @@ -3,7 +3,7 @@ T5051.hs:11:11: Overlapping instances for Eq [a] arising from a use of ‘>=’ Matching instances: instance Eq a => Eq [a] -- Defined in ‘GHC.Classes’ - instance [overlap ok] Eq [T] -- Defined at T5051.hs:8:10 + instance [overlapping] Eq [T] -- Defined at T5051.hs:8:30 (The choice depends on the instantiation of ‘a’ To pick the first instance above, use IncoherentInstances when compiling the other instance declarations) diff --git a/testsuite/tests/typecheck/should_fail/T5095.hs b/testsuite/tests/typecheck/should_fail/T5095.hs index 80e080802e..7942a87433 100644 --- a/testsuite/tests/typecheck/should_fail/T5095.hs +++ b/testsuite/tests/typecheck/should_fail/T5095.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE FlexibleInstances, OverlappingInstances, UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} module Test where -instance Show a => Eq a where +instance {-# OVERLAPPABLE #-} Show a => Eq a where x == y = length (show x) == length (show y) f :: Show a => a -> a -> Bool diff --git a/testsuite/tests/typecheck/should_fail/T5095.stderr b/testsuite/tests/typecheck/should_fail/T5095.stderr index 614c99cb11..a572c07788 100644 --- a/testsuite/tests/typecheck/should_fail/T5095.stderr +++ b/testsuite/tests/typecheck/should_fail/T5095.stderr @@ -2,7 +2,7 @@ T5095.hs:9:11: Overlapping instances for Eq a arising from a use of ‘==’ Matching instances: - instance [overlap ok] Show a => Eq a -- Defined at T5095.hs:5:10 + instance [overlappable] Show a => Eq a -- Defined at T5095.hs:5:31 instance Eq a => Eq (GHC.Real.Ratio a) -- Defined in ‘GHC.Real’ instance Eq () -- Defined in ‘GHC.Classes’ instance (Eq a, Eq b) => Eq (a, b) -- Defined in ‘GHC.Classes’ diff --git a/testsuite/tests/typecheck/should_fail/T9305.hs b/testsuite/tests/typecheck/should_fail/T9305.hs new file mode 100644 index 0000000000..b6ad3b780e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T9305.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DeriveFunctor#-} +module Main where + +data Event a b = Event a deriving (Functor) + +newtype F f = F (f (F f)) + +data EventF a = EventF (F (Event a)) deriving (Functor) diff --git a/testsuite/tests/typecheck/should_fail/T9305.stderr b/testsuite/tests/typecheck/should_fail/T9305.stderr new file mode 100644 index 0000000000..16104237b9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T9305.stderr @@ -0,0 +1,8 @@ + +T9305.hs:8:48: + No instance for (Functor Event) + arising from the first field of ‘EventF’ (type ‘F (Event a)’) + Possible fix: + use a standalone 'deriving instance' declaration, + so you can specify the instance context yourself + When deriving the instance for (Functor EventF) diff --git a/testsuite/tests/typecheck/should_fail/T9323.hs b/testsuite/tests/typecheck/should_fail/T9323.hs new file mode 100644 index 0000000000..1aea288bbe --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T9323.hs @@ -0,0 +1,7 @@ +module T9323 where + +broken :: [Int] +broken = () + +ambiguous :: a -> String +ambiguous _ = show 0 diff --git a/testsuite/tests/typecheck/should_fail/T9323.stderr b/testsuite/tests/typecheck/should_fail/T9323.stderr new file mode 100644 index 0000000000..f98ce7bafe --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T9323.stderr @@ -0,0 +1,5 @@ + +T9323.hs:4:10: + Couldn't match expected type ‘[Int]’ with actual type ‘()’ + In the expression: () + In an equation for ‘broken’: broken = () diff --git a/testsuite/tests/typecheck/should_fail/Tcfail218_Help.hs b/testsuite/tests/typecheck/should_fail/Tcfail218_Help.hs deleted file mode 100644 index e5ee76d755..0000000000 --- a/testsuite/tests/typecheck/should_fail/Tcfail218_Help.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} - -module Tcfail218_Help where - -class C a b where foo :: (a,b) - -instance C [Int] b where foo = undefined diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index a1dab9df0f..b528047411 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -243,10 +243,7 @@ test('tcfail214', normal, compile_fail, ['']) test('tcfail215', normal, compile_fail, ['']) test('tcfail216', normal, compile_fail, ['']) test('tcfail217', normal, compile_fail, ['']) -test('tcfail218', - extra_clean(['Tcfail218_Help.o','Tcfail218_Help.hi']), - multimod_compile_fail, ['tcfail218','-v0']) - +test('tcfail218', normal, compile_fail, ['']) test('SilentParametersOverlapping', normal, compile_fail, ['']) test('FailDueToGivenOverlapping', normal, compile_fail, ['']) test('LongWayOverlapping', normal, compile_fail, ['']) @@ -334,4 +331,5 @@ test('T8912', normal, compile_fail, ['']) test('T9033', normal, compile_fail, ['']) test('T8883', normal, compile_fail, ['']) test('T9196', normal, compile_fail, ['']) - +test('T9305', normal, compile_fail, ['']) +test('T9323', normal, compile_fail, ['']) diff --git a/testsuite/tests/typecheck/should_fail/tcfail121.hs b/testsuite/tests/typecheck/should_fail/tcfail121.hs index 86c2a92c5c..84966c4e7e 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail121.hs +++ b/testsuite/tests/typecheck/should_fail/tcfail121.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE OverlappingInstances, FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} module ShouldFail where class Foo a where op :: a -> a -instance Foo a => Foo [a] -instance Foo [Int] +instance {-# OVERLAPPABLE #-} Foo a => Foo [a] +instance {-# OVERLAPPING #-} Foo [Int] foo :: Foo a => [a] -> [a] foo x = op x diff --git a/testsuite/tests/typecheck/should_fail/tcfail121.stderr b/testsuite/tests/typecheck/should_fail/tcfail121.stderr index bc71d5e79f..dc0679edca 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail121.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail121.stderr @@ -2,9 +2,9 @@ tcfail121.hs:13:9: Overlapping instances for Foo [a] arising from a use of ‘op’ Matching instances: - instance [overlap ok] Foo a => Foo [a] - -- Defined at tcfail121.hs:9:10 - instance [overlap ok] Foo [Int] -- Defined at tcfail121.hs:10:10 + instance [overlappable] Foo a => Foo [a] + -- Defined at tcfail121.hs:9:31 + instance [overlapping] Foo [Int] -- Defined at tcfail121.hs:10:30 (The choice depends on the instantiation of ‘a’ To pick the first instance above, use IncoherentInstances when compiling the other instance declarations) diff --git a/testsuite/tests/typecheck/should_fail/tcfail202.hs b/testsuite/tests/typecheck/should_fail/tcfail202.hs index 7565755218..6878e4ece6 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail202.hs +++ b/testsuite/tests/typecheck/should_fail/tcfail202.hs @@ -2,7 +2,7 @@ -- This was accepted due to a bug in GHC {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, - OverlappingInstances, UndecidableInstances, IncoherentInstances, + UndecidableInstances, IncoherentInstances, FlexibleInstances #-} module Foo where diff --git a/testsuite/tests/typecheck/should_fail/tcfail218.hs b/testsuite/tests/typecheck/should_fail/tcfail218.hs index ed054596c0..9a5f4ce7d2 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail218.hs +++ b/testsuite/tests/typecheck/should_fail/tcfail218.hs @@ -1,12 +1,22 @@ -{-# LANGUAGE IncoherentInstances, MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} -import Tcfail218_Help +module Tcfail218 where -instance C [a] b where foo = undefined -instance C a Int where foo = undefined +class C a b where foo :: (a,b) --- Should fail, as a more specific, unifying but not matching, non-incoherent instance exists. -x :: ([a],b) +instance C [Int] Bool where foo = undefined +instance C [a] b where foo = undefined +instance {-# INCOHERENT #-} C a Int where foo = undefined + + +x :: ([a],Bool) +-- Needs C [a] b. +-- Should fail, as a more specific, unifying but not matching +-- non-incoherent instance exists, namely C [Int] Bool x = foo -main = return () +-- Needs C [a] Int. +-- Should succeed, because two instances match, but one is incoherent +y :: ([a],Int) +y = foo + diff --git a/testsuite/tests/typecheck/should_fail/tcfail218.stderr b/testsuite/tests/typecheck/should_fail/tcfail218.stderr index 7978004387..efb6c4c9d3 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail218.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail218.stderr @@ -1,10 +1,10 @@ -tcfail218.hs:10:5: - Overlapping instances for C [a] b arising from a use of ‘foo’ +tcfail218.hs:16:5: + Overlapping instances for C [a] Bool arising from a use of ‘foo’ Matching instances: - instance [incoherent] C [a] b -- Defined at tcfail218.hs:5:10 - instance C [Int] b -- Defined at Tcfail218_Help.hs:7:10 - (The choice depends on the instantiation of ‘a, b’ + instance C [a] b -- Defined at tcfail218.hs:8:29 + instance C [Int] Bool -- Defined at tcfail218.hs:7:29 + (The choice depends on the instantiation of ‘a’ To pick the first instance above, use IncoherentInstances when compiling the other instance declarations) In the expression: foo diff --git a/testsuite/tests/typecheck/should_run/.gitignore b/testsuite/tests/typecheck/should_run/.gitignore deleted file mode 100644 index d9ee251388..0000000000 --- a/testsuite/tests/typecheck/should_run/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -T8492 -T8739 -TcTypeNatSimpleRun diff --git a/testsuite/tests/typecheck/should_run/TcNullaryTC.hs b/testsuite/tests/typecheck/should_run/TcNullaryTC.hs index a94d3058b0..17e3f4c425 100644 --- a/testsuite/tests/typecheck/should_run/TcNullaryTC.hs +++ b/testsuite/tests/typecheck/should_run/TcNullaryTC.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NullaryTypeClasses #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Main where diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T index de37d13713..760d5e1452 100755 --- a/testsuite/tests/typecheck/should_run/all.T +++ b/testsuite/tests/typecheck/should_run/all.T @@ -12,6 +12,8 @@ test('tcrun003', normal, compile_and_run, ['']) test('tcrun004', normal, compile_and_run, ['']) test('tcrun005', normal, compile_and_run, ['']) test('Defer01', normal, compile_and_run, ['']) +test('TcNullaryTC', when(compiler_lt('ghc', '7.7'), skip), compile_and_run, ['']) +test('TcCoercible', when(compiler_lt('ghc', '7.7'), skip), compile_and_run, ['']) # ----------------------------------------------------------------------------- # Skip everything else if fast is on @@ -105,10 +107,8 @@ test('T6117', normal, compile_and_run, ['']) test('T5751', normal, compile_and_run, ['']) test('T5913', normal, compile_and_run, ['']) test('T7748', normal, compile_and_run, ['']) -test('TcNullaryTC', when(compiler_lt('ghc', '7.7'), skip), compile_and_run, ['']) test('T7861', exit_code(1), compile_and_run, ['']) test('TcTypeNatSimpleRun', normal, compile_and_run, ['']) -test('TcCoercible', when(compiler_lt('ghc', '7.7'), skip), compile_and_run, ['']) test('T8119', normal, ghci_script, ['T8119.script']) test('T8492', normal, compile_and_run, ['']) test('T8739', normal, compile_and_run, ['']) diff --git a/utils/ghc-cabal/Main.hs b/utils/ghc-cabal/Main.hs index d33652fe96..47eb1de4fd 100644 --- a/utils/ghc-cabal/Main.hs +++ b/utils/ghc-cabal/Main.hs @@ -260,7 +260,7 @@ updateInstallDirTemplates relocatableBuild myPrefix myLibdir myDocdir idts if relocatableBuild then "$topdir" else myLibdir, - libsubdir = toPathTemplate "$pkgid", + libsubdir = toPathTemplate "$pkgkey", docdir = toPathTemplate $ if relocatableBuild then "$topdir/../doc/html/libraries/$pkgid" @@ -356,6 +356,7 @@ generate directory distdir dll0Modules config_args writeFileAtomic (distdir </> "inplace-pkg-config") (BS.pack $ toUTF8 content) let + comp = compiler lbi libBiModules lib = (libBuildInfo lib, libModules lib) exeBiModules exe = (buildInfo exe, ModuleName.main : exeModules exe) biModuless = (maybeToList $ fmap libBiModules $ library pd) @@ -398,10 +399,25 @@ generate directory distdir dll0Modules config_args dep_ids = map snd (externalPackageDeps lbi) deps = map display dep_ids + dep_keys + | packageKeySupported comp + = map (display + . Installed.packageKey + . fromMaybe (error "ghc-cabal: dep_keys failed") + . PackageIndex.lookupInstalledPackageId + (installedPkgs lbi) + . fst) + . externalPackageDeps + $ lbi + | otherwise = deps depNames = map (display . packageName) dep_ids transitive_dep_ids = map Installed.sourcePackageId dep_pkgs transitiveDeps = map display transitive_dep_ids + transitiveDepKeys + | packageKeySupported comp + = map (display . Installed.packageKey) dep_pkgs + | otherwise = transitiveDeps transitiveDepNames = map (display . packageName) transitive_dep_ids libraryDirs = forDeps Installed.libraryDirs @@ -420,13 +436,16 @@ generate directory distdir dll0Modules config_args otherMods = map display (otherModules bi) allMods = mods ++ otherMods let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)), + variablePrefix ++ "_PACKAGE_KEY = " ++ display (pkgKey lbi), variablePrefix ++ "_MODULES = " ++ unwords mods, variablePrefix ++ "_HIDDEN_MODULES = " ++ unwords otherMods, variablePrefix ++ "_SYNOPSIS =" ++ synopsis pd, variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi), variablePrefix ++ "_DEPS = " ++ unwords deps, + variablePrefix ++ "_DEP_KEYS = " ++ unwords dep_keys, variablePrefix ++ "_DEP_NAMES = " ++ unwords depNames, variablePrefix ++ "_TRANSITIVE_DEPS = " ++ unwords transitiveDeps, + variablePrefix ++ "_TRANSITIVE_DEP_KEYS = " ++ unwords transitiveDepKeys, variablePrefix ++ "_TRANSITIVE_DEP_NAMES = " ++ unwords transitiveDepNames, variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi), variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi), diff --git a/utils/ghc-cabal/ghc-cabal.cabal b/utils/ghc-cabal/ghc-cabal.cabal index 0f13b9dcf4..2641f19568 100644 --- a/utils/ghc-cabal/ghc-cabal.cabal +++ b/utils/ghc-cabal/ghc-cabal.cabal @@ -6,8 +6,7 @@ License: BSD3 Author: XXX Maintainer: XXX Synopsis: XXX -Description: - XXX +Description: XXX Category: Development build-type: Simple cabal-version: >=1.10 @@ -18,7 +17,7 @@ Executable ghc-cabal Build-Depends: base >= 3 && < 5, bytestring >= 0.10 && < 0.11, - Cabal >= 1.20 && < 1.21, + Cabal >= 1.20 && < 1.22, directory >= 1.1 && < 1.3, filepath >= 1.2 && < 1.4 diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 290fb82a22..970ab67083 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -16,6 +16,7 @@ import Distribution.ModuleName hiding (main) import Distribution.InstalledPackageInfo import Distribution.Compat.ReadP import Distribution.ParseUtils +import Distribution.ModuleExport import Distribution.Package hiding (depends) import Distribution.Text import Distribution.Version @@ -32,6 +33,8 @@ import System.Console.GetOpt import qualified Control.Exception as Exception import Data.Maybe +import qualified Data.Set as Set + import Data.Char ( isSpace, toLower ) import Data.Ord (comparing) import Control.Applicative (Applicative(..)) @@ -111,9 +114,11 @@ data Flag | FlagVersion | FlagConfig FilePath | FlagGlobalConfig FilePath + | FlagUserConfig FilePath | FlagForce | FlagForceFiles | FlagAutoGHCiLibs + | FlagMultiInstance | FlagExpandEnvVars | FlagExpandPkgroot | FlagNoExpandPkgroot @@ -122,6 +127,7 @@ data Flag | FlagIgnoreCase | FlagNoUserDb | FlagVerbosity (Maybe String) + | FlagIPId deriving Eq flags :: [OptDescr Flag] @@ -138,6 +144,8 @@ flags = [ "location of the global package database", Option [] ["no-user-package-db"] (NoArg FlagNoUserDb) "never read the user package database", + Option [] ["user-package-db"] (ReqArg FlagUserConfig "DIR") + "location of the user package database (use instead of default)", Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb) "never read the user package database (DEPRECATED)", Option [] ["force"] (NoArg FlagForce) @@ -146,6 +154,8 @@ flags = [ "ignore missing directories and libraries only", Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs) "automatically build libs for GHCi (with register)", + Option [] ["enable-multi-instance"] (NoArg FlagMultiInstance) + "allow registering multiple instances of the same package version", Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars) "expand environment variables (${name}-style) in input package descriptions", Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot) @@ -162,6 +172,8 @@ flags = [ "only print package names, not versions; can only be used with list --simple-output", Option [] ["ignore-case"] (NoArg FlagIgnoreCase) "ignore case for substring matching", + Option [] ["ipid"] (NoArg FlagIPId) + "interpret package arguments as installed package IDs", Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity") "verbosity level (0-2, default 1)" ] @@ -270,7 +282,8 @@ usageHeader prog = substProg prog $ "\n" ++ " Substring matching is supported for {module} in find-module and\n" ++ " for {pkg} in list, describe, and field, where a '*' indicates\n" ++ - " open substring ends (prefix*, *suffix, *infix*).\n" ++ + " open substring ends (prefix*, *suffix, *infix*). Use --ipid to\n" ++ + " match against the installed package ID instead.\n" ++ "\n" ++ " When asked to modify a database (register, unregister, update,\n"++ " hide, expose, and also check), ghc-pkg modifies the global database by\n"++ @@ -297,7 +310,17 @@ substProg prog (c:xs) = c : substProg prog xs data Force = NoForce | ForceFiles | ForceAll | CannotForce deriving (Eq,Ord) -data PackageArg = Id PackageIdentifier | Substring String (String->Bool) +-- | Represents how a package may be specified by a user on the command line. +data PackageArg + -- | A package identifier foo-0.1; the version might be a glob. + = Id PackageIdentifier + -- | An installed package ID foo-0.1-HASH. This is guaranteed to uniquely + -- match a single entry in the package database. + | IPId InstalledPackageId + -- | A glob against the package name. The first string is the literal + -- glob, the second is a function which returns @True@ if the the argument + -- matches. + | Substring String (String->Bool) runit :: Verbosity -> [Flag] -> [String] -> IO () runit verbosity cli nonopts = do @@ -308,7 +331,9 @@ runit verbosity cli nonopts = do | FlagForce `elem` cli = ForceAll | FlagForceFiles `elem` cli = ForceFiles | otherwise = NoForce + as_ipid = FlagIPId `elem` cli auto_ghci_libs = FlagAutoGHCiLibs `elem` cli + multi_instance = FlagMultiInstance `elem` cli expand_env_vars= FlagExpandEnvVars `elem` cli mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli where accumExpandPkgroot _ FlagExpandPkgroot = Just True @@ -319,6 +344,28 @@ runit verbosity cli nonopts = do where splitComma "" = Nothing splitComma fs = Just $ break (==',') (tail fs) + -- | Parses a glob into a predicate which tests if a string matches + -- the glob. Returns Nothing if the string in question is not a glob. + -- At the moment, we only support globs at the beginning and/or end of + -- strings. This function respects case sensitivity. + -- + -- >>> fromJust (substringCheck "*") "anything" + -- True + -- + -- >>> fromJust (substringCheck "string") "string" + -- True + -- + -- >>> fromJust (substringCheck "*bar") "foobar" + -- True + -- + -- >>> fromJust (substringCheck "foo*") "foobar" + -- True + -- + -- >>> fromJust (substringCheck "*ooba*") "foobar" + -- True + -- + -- >>> fromJust (substringCheck "f*bar") "foobar" + -- False substringCheck :: String -> Maybe (String -> Bool) substringCheck "" = Nothing substringCheck "*" = Just (const True) @@ -355,32 +402,35 @@ runit verbosity cli nonopts = do initPackageDB filename verbosity cli ["register", filename] -> registerPackage filename verbosity cli - auto_ghci_libs expand_env_vars False force + auto_ghci_libs multi_instance + expand_env_vars False force ["update", filename] -> registerPackage filename verbosity cli - auto_ghci_libs expand_env_vars True force - ["unregister", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - unregisterPackage pkgid verbosity cli force - ["expose", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - exposePackage pkgid verbosity cli force - ["hide", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - hidePackage pkgid verbosity cli force - ["trust", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - trustPackage pkgid verbosity cli force - ["distrust", pkgid_str] -> do - pkgid <- readGlobPkgId pkgid_str - distrustPackage pkgid verbosity cli force + auto_ghci_libs multi_instance + expand_env_vars True force + ["unregister", pkgarg_str] -> do + pkgarg <- readPackageArg as_ipid pkgarg_str + unregisterPackage pkgarg verbosity cli force + ["expose", pkgarg_str] -> do + pkgarg <- readPackageArg as_ipid pkgarg_str + exposePackage pkgarg verbosity cli force + ["hide", pkgarg_str] -> do + pkgarg <- readPackageArg as_ipid pkgarg_str + hidePackage pkgarg verbosity cli force + ["trust", pkgarg_str] -> do + pkgarg <- readPackageArg as_ipid pkgarg_str + trustPackage pkgarg verbosity cli force + ["distrust", pkgarg_str] -> do + pkgarg <- readPackageArg as_ipid pkgarg_str + distrustPackage pkgarg verbosity cli force ["list"] -> do listPackages verbosity cli Nothing Nothing - ["list", pkgid_str] -> - case substringCheck pkgid_str of - Nothing -> do pkgid <- readGlobPkgId pkgid_str - listPackages verbosity cli (Just (Id pkgid)) Nothing - Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing + ["list", pkgarg_str] -> + case substringCheck pkgarg_str of + Nothing -> do pkgarg <- readPackageArg as_ipid pkgarg_str + listPackages verbosity cli (Just pkgarg) Nothing + Just m -> listPackages verbosity cli + (Just (Substring pkgarg_str m)) Nothing ["dot"] -> do showPackageDot verbosity cli ["find-module", moduleName] -> do @@ -391,13 +441,13 @@ runit verbosity cli nonopts = do latestPackage verbosity cli pkgid ["describe", pkgid_str] -> do pkgarg <- case substringCheck pkgid_str of - Nothing -> liftM Id (readGlobPkgId pkgid_str) + Nothing -> readPackageArg as_ipid pkgid_str Just m -> return (Substring pkgid_str m) describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot) ["field", pkgid_str, fields] -> do pkgarg <- case substringCheck pkgid_str of - Nothing -> liftM Id (readGlobPkgId pkgid_str) + Nothing -> readPackageArg as_ipid pkgid_str Just m -> return (Substring pkgid_str m) describeField verbosity cli pkgarg (splitFields fields) (fromMaybe True mexpand_pkgroot) @@ -433,6 +483,11 @@ parseGlobPackageId = _ <- string "-*" return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion })) +readPackageArg :: Bool -> String -> IO PackageArg +readPackageArg True str = + parseCheck (IPId `fmap` parse) str "installed package id" +readPackageArg False str = Id `fmap` readGlobPkgId str + -- globVersion means "all versions" globVersion :: Version globVersion = Version{ versionBranch=[], versionTags=["*"] } @@ -515,16 +570,18 @@ getPkgDatabases verbosity modify use_cache expand_vars my_flags = do e_appdir <- tryIO $ getAppUserDataDirectory "ghc" mb_user_conf <- - if no_user_db then return Nothing else - case e_appdir of - Left _ -> return Nothing - Right appdir -> do - let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version - dir = appdir </> subdir - r <- lookForPackageDBIn dir - case r of - Nothing -> return (Just (dir </> "package.conf.d", False)) - Just f -> return (Just (f, True)) + case [ f | FlagUserConfig f <- my_flags ] of + _ | no_user_db -> return Nothing + [] -> case e_appdir of + Left _ -> return Nothing + Right appdir -> do + let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version + dir = appdir </> subdir + r <- lookForPackageDBIn dir + case r of + Nothing -> return (Just (dir </> "package.conf.d", False)) + Just f -> return (Just (f, True)) + fs -> return (Just (last fs, True)) -- If the user database doesn't exist, and this command isn't a -- "modify" command, then we won't attempt to create or use it. @@ -585,6 +642,11 @@ getPkgDatabases verbosity modify use_cache expand_vars my_flags = do let flag_db_stack = [ db | db_name <- flag_db_names, db <- db_stack, location db == db_name ] + when (verbosity > Normal) $ do + infoLn ("db stack: " ++ show (map location db_stack)) + infoLn ("modifying: " ++ show to_modify) + infoLn ("flag db stack: " ++ show (map location flag_db_stack)) + return (db_stack, to_modify, flag_db_stack) @@ -782,11 +844,13 @@ registerPackage :: FilePath -> Verbosity -> [Flag] -> Bool -- auto_ghci_libs + -> Bool -- multi_instance -> Bool -- expand_env_vars -> Bool -- update -> Force -> IO () -registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do +registerPackage input verbosity my_flags auto_ghci_libs multi_instance + expand_env_vars update force = do (db_stack, Just to_modify, _flag_dbs) <- getPkgDatabases verbosity True True False{-expand vars-} my_flags @@ -829,13 +893,23 @@ registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update f let truncated_stack = dropWhile ((/= to_modify).location) db_stack -- truncate the stack for validation, because we don't allow -- packages lower in the stack to refer to those higher up. - validatePackageConfig pkg_expanded verbosity truncated_stack auto_ghci_libs update force + validatePackageConfig pkg_expanded verbosity truncated_stack + auto_ghci_libs multi_instance update force + + -- postprocess the package + pkg' <- resolveReexports truncated_stack pkg + let + -- In the normal mode, we only allow one version of each package, so we + -- remove all instances with the same source package id as the one we're + -- adding. In the multi instance mode we don't do that, thus allowing + -- multiple instances with the same source package id. removes = [ RemovePackage p - | p <- packages db_to_operate_on, + | not multi_instance, + p <- packages db_to_operate_on, sourcePackageId p == sourcePackageId pkg ] -- - changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on + changeDB verbosity (removes ++ [AddPackage pkg']) db_to_operate_on parsePackageInfo :: String @@ -850,6 +924,47 @@ parsePackageInfo str = (Nothing, s) -> die s (Just l, s) -> die (show l ++ ": " ++ s) +-- | Takes the "reexported-modules" field of an InstalledPackageInfo +-- and resolves the references so they point to the original exporter +-- of a module (i.e. the module is in exposed-modules, not +-- reexported-modules). This is done by maintaining an invariant on +-- the installed package database that a reexported-module field always +-- points to the original exporter. +resolveReexports :: PackageDBStack + -> InstalledPackageInfo + -> IO InstalledPackageInfo +resolveReexports db_stack pkg = do + let dep_mask = Set.fromList (depends pkg) + deps = filter (flip Set.member dep_mask . installedPackageId) + (allPackagesInStack db_stack) + matchExposed pkg_dep m = map ((,) (installedPackageId pkg_dep)) + (filter (==m) (exposedModules pkg_dep)) + worker ModuleExport{ exportOrigPackageName = Just pnm } pkg_dep + | pnm /= packageName (sourcePackageId pkg_dep) = [] + -- Now, either the package matches, *or* we were asked to search the + -- true location ourselves. + worker ModuleExport{ exportOrigName = m } pkg_dep = + matchExposed pkg_dep m ++ + map (fromMaybe (error $ "Impossible! Missing true location in " ++ + display (installedPackageId pkg_dep)) + . exportCachedTrueOrig) + (filter ((==m) . exportName) (reexportedModules pkg_dep)) + self_reexports ModuleExport{ exportOrigPackageName = Just pnm } + | pnm /= packageName (sourcePackageId pkg) = [] + self_reexports ModuleExport{ exportName = m', exportOrigName = m } + -- Self-reexport without renaming doesn't make sense + | m == m' = [] + -- *Only* match against exposed modules! + | otherwise = matchExposed pkg m + + r <- forM (reexportedModules pkg) $ \me -> do + case nub (concatMap (worker me) deps ++ self_reexports me) of + [c] -> return me { exportCachedTrueOrig = Just c } + [] -> die $ "Couldn't resolve reexport " ++ display me + cs -> die $ "Found multiple possible ways to resolve reexport " ++ + display me ++ ": " ++ show cs + return (pkg { reexportedModules = r }) + -- ----------------------------------------------------------------------------- -- Making changes to a package database @@ -911,52 +1026,60 @@ updateDBCache verbosity db = do -- ----------------------------------------------------------------------------- -- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar -exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () +exposePackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO () exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True}) -hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () +hidePackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO () hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False}) -trustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () +trustPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO () trustPackage = modifyPackage (\p -> ModifyPackage p{trusted=True}) -distrustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () +distrustPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO () distrustPackage = modifyPackage (\p -> ModifyPackage p{trusted=False}) -unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () +unregisterPackage :: PackageArg -> Verbosity -> [Flag] -> Force -> IO () unregisterPackage = modifyPackage RemovePackage modifyPackage :: (InstalledPackageInfo -> DBOp) - -> PackageIdentifier + -> PackageArg -> Verbosity -> [Flag] -> Force -> IO () -modifyPackage fn pkgid verbosity my_flags force = do - (db_stack, Just _to_modify, _flag_dbs) <- +modifyPackage fn pkgarg verbosity my_flags force = do + (db_stack, Just _to_modify, flag_dbs) <- getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags - (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid) + -- Do the search for the package respecting flags... + (db, ps) <- fmap head $ findPackagesByDB flag_dbs pkgarg let db_name = location db pkgs = packages db - pids = map sourcePackageId ps + pks = map packageKey ps - cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ] + cmds = [ fn pkg | pkg <- pkgs, packageKey pkg `elem` pks ] new_db = updateInternalDB db cmds + -- ...but do consistency checks with regards to the full stack old_broken = brokenPackages (allPackagesInStack db_stack) rest_of_stack = filter ((/= db_name) . location) db_stack new_stack = new_db : rest_of_stack - new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack)) - newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken + new_broken = brokenPackages (allPackagesInStack new_stack) + newly_broken = filter ((`notElem` map packageKey old_broken) + . packageKey) new_broken -- + let displayQualPkgId pkg + | [_] <- filter ((== pkgid) . sourcePackageId) + (allPackagesInStack db_stack) + = display pkgid + | otherwise = display pkgid ++ "@" ++ display (packageKey pkg) + where pkgid = sourcePackageId pkg when (not (null newly_broken)) $ - dieOrForceAll force ("unregistering " ++ display pkgid ++ - " would break the following packages: " - ++ unwords (map display newly_broken)) + dieOrForceAll force ("unregistering would break the following packages: " + ++ unwords (map displayQualPkgId newly_broken)) changeDB verbosity cmds db @@ -998,7 +1121,10 @@ listPackages verbosity my_flags mPackageName mModuleName = do case pkgName p1 `compare` pkgName p2 of LT -> LT GT -> GT - EQ -> pkgVersion p1 `compare` pkgVersion p2 + EQ -> case pkgVersion p1 `compare` pkgVersion p2 of + LT -> LT + GT -> GT + EQ -> packageKey pkg1 `compare` packageKey pkg2 where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2) stack = reverse db_stack_sorted @@ -1006,7 +1132,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do match `exposedInPkg` pkg = any match (map display $ exposedModules pkg) pkg_map = allPackagesInStack db_stack - broken = map sourcePackageId (brokenPackages pkg_map) + broken = map packageKey (brokenPackages pkg_map) show_normal PackageDB{ location = db_name, packages = pkg_confs } = do hPutStrLn stdout (db_name ++ ":") @@ -1017,7 +1143,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do -- Sort using instance Ord PackageId pp_pkgs = map pp_pkg . sortBy (comparing installedPackageId) $ pkg_confs pp_pkg p - | sourcePackageId p `elem` broken = printf "{%s}" doc + | packageKey p `elem` broken = printf "{%s}" doc | exposed p = doc | otherwise = printf "(%s)" doc where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid @@ -1044,7 +1170,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do map (termText " " <#>) (map pp_pkg (packages db))) where pp_pkg p - | sourcePackageId p `elem` broken = withF Red doc + | packageKey p `elem` broken = withF Red doc | exposed p = doc | otherwise = withF Blue doc where doc | verbosity >= Verbose @@ -1096,6 +1222,8 @@ showPackageDot verbosity myflags = do -- ----------------------------------------------------------------------------- -- Prints the highest (hidden or exposed) version of a package +-- ToDo: This is no longer well-defined with package keys, because the +-- dependencies may be varying versions latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO () latestPackage verbosity my_flags pkgid = do (_, _, flag_db_stack) <- @@ -1155,6 +1283,7 @@ findPackagesByDB db_stack pkgarg ps -> return ps where pkg_msg (Id pkgid) = display pkgid + pkg_msg (IPId ipid) = display ipid pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat matches :: PackageIdentifier -> PackageIdentifier -> Bool @@ -1168,6 +1297,7 @@ realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool (Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg +(IPId ipid) `matchesPkg` pkg = ipid == installedPackageId pkg (Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg)) -- ----------------------------------------------------------------------------- @@ -1204,7 +1334,8 @@ checkConsistency verbosity my_flags = do let pkgs = allPackagesInStack db_stack checkPackage p = do - (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack False True + (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack + False True True if null es then do when (not simple_output) $ do _ <- reportValidateErrors [] ws "" Nothing @@ -1267,15 +1398,19 @@ type InstalledPackageInfoString = InstalledPackageInfo_ String convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString convertPackageInfoOut (pkgconf@(InstalledPackageInfo { exposedModules = e, + reexportedModules = r, hiddenModules = h })) = pkgconf{ exposedModules = map display e, + reexportedModules = map (fmap display) r, hiddenModules = map display h } convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo convertPackageInfoIn (pkgconf@(InstalledPackageInfo { exposedModules = e, + reexportedModules = r, hiddenModules = h })) = pkgconf{ exposedModules = map convert e, + reexportedModules = map (fmap convert) r, hiddenModules = map convert h } where convert = fromJust . simpleParse @@ -1354,11 +1489,15 @@ validatePackageConfig :: InstalledPackageInfo -> Verbosity -> PackageDBStack -> Bool -- auto-ghc-libs + -> Bool -- multi_instance -> Bool -- update, or check -> Force -> IO () -validatePackageConfig pkg verbosity db_stack auto_ghci_libs update force = do - (_,es,ws) <- runValidate $ checkPackageConfig pkg verbosity db_stack auto_ghci_libs update +validatePackageConfig pkg verbosity db_stack auto_ghci_libs + multi_instance update force = do + (_,es,ws) <- runValidate $ + checkPackageConfig pkg verbosity db_stack + auto_ghci_libs multi_instance update ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force) when (not ok) $ exitWith (ExitFailure 1) @@ -1366,12 +1505,15 @@ checkPackageConfig :: InstalledPackageInfo -> Verbosity -> PackageDBStack -> Bool -- auto-ghc-libs + -> Bool -- multi_instance -> Bool -- update, or check -> Validate () -checkPackageConfig pkg verbosity db_stack auto_ghci_libs update = do +checkPackageConfig pkg verbosity db_stack auto_ghci_libs + multi_instance update = do checkInstalledPackageId pkg db_stack update checkPackageId pkg - checkDuplicates db_stack pkg update + checkPackageKey pkg + checkDuplicates db_stack pkg multi_instance update mapM_ (checkDep db_stack) (depends pkg) checkDuplicateDepends (depends pkg) mapM_ (checkDir False "import-dirs") (importDirs pkg) @@ -1410,15 +1552,25 @@ checkPackageId ipi = [] -> verror CannotForce ("invalid package identifier: " ++ str) _ -> verror CannotForce ("ambiguous package identifier: " ++ str) -checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate () -checkDuplicates db_stack pkg update = do +checkPackageKey :: InstalledPackageInfo -> Validate () +checkPackageKey ipi = + let str = display (packageKey ipi) in + case [ x :: PackageKey | (x,ys) <- readP_to_S parse str, all isSpace ys ] of + [_] -> return () + [] -> verror CannotForce ("invalid package key: " ++ str) + _ -> verror CannotForce ("ambiguous package key: " ++ str) + +checkDuplicates :: PackageDBStack -> InstalledPackageInfo + -> Bool -> Bool-> Validate () +checkDuplicates db_stack pkg multi_instance update = do let pkgid = sourcePackageId pkg pkgs = packages (head db_stack) -- -- Check whether this package id already exists in this DB -- - when (not update && (pkgid `elem` map sourcePackageId pkgs)) $ + when (not update && not multi_instance + && (pkgid `elem` map sourcePackageId pkgs)) $ verror CannotForce $ "package " ++ display pkgid ++ " is already installed" @@ -1504,6 +1656,7 @@ doesFileExistOnPath filenames paths = go fullFilenames go ((p, fp) : xs) = do b <- doesFileExist fp if b then return (Just p) else go xs +-- XXX maybe should check reexportedModules too checkModules :: InstalledPackageInfo -> Validate () checkModules pkg = do mapM_ findModule (exposedModules pkg ++ hiddenModules pkg) diff --git a/utils/ghc-pkg/ghc-pkg.cabal b/utils/ghc-pkg/ghc-pkg.cabal index 574301086e..317aab7cfa 100644 --- a/utils/ghc-pkg/ghc-pkg.cabal +++ b/utils/ghc-pkg/ghc-pkg.cabal @@ -7,8 +7,7 @@ License: BSD3 Author: XXX Maintainer: cvs-fptools@haskell.org Synopsis: XXX -Description: - XXX +Description: XXX Category: Development build-type: Simple cabal-version: >=1.10 @@ -22,6 +21,7 @@ Executable ghc-pkg Build-Depends: base >= 4 && < 5, directory >= 1 && < 1.3, process >= 1 && < 1.3, + containers, filepath, Cabal, binary, diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 815cc7ca18..4a094f50a1 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -282,7 +282,7 @@ boundThings modname lbinding = PatBind { pat_lhs = lhs } -> patThings lhs [] VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)] AbsBinds { } -> [] -- nothing interesting in a type abstraction - PatSynBind { patsyn_id = id } -> [thing id] + PatSynBind PSB{ psb_id = id } -> [thing id] where thing = foundOfLName modname patThings lpat tl = let loc = startOfLocated lpat diff --git a/utils/ghctags/ghctags.cabal b/utils/ghctags/ghctags.cabal index 31e80b289b..cfa841dcb0 100644 --- a/utils/ghctags/ghctags.cabal +++ b/utils/ghctags/ghctags.cabal @@ -6,8 +6,7 @@ License: BSD3 Author: XXX Maintainer: XXX Synopsis: XXX -Description: - XXX +Description: XXX Category: Development build-type: Simple cabal-version: >=1.10 @@ -19,6 +18,6 @@ Executable ghctags Build-Depends: base >= 4 && < 5, containers, - Cabal >= 1.20 && <1.21, + Cabal >= 1.20 && <1.22, ghc diff --git a/utils/haddock b/utils/haddock -Subproject 1a3f8f74116d749a17467c79ee30c5efabd694d +Subproject d8f1c1cc4e8825f39ffc87fddfe6ff9c58f9ef8 diff --git a/utils/heap-view/Graph.lhs b/utils/heap-view/Graph.lhs deleted file mode 100644 index b8e08dbb9b..0000000000 --- a/utils/heap-view/Graph.lhs +++ /dev/null @@ -1,165 +0,0 @@ -Started 29/11/93: - -> module Main where -> import PreludeGlaST -> import LibSystem - -Program to draw a graph of last @n@ pieces of data from standard input -continuously. - -> n :: Int -> n = 40 - -> max_sample :: Int -> max_sample = 100 - -> screen_size :: Int -> screen_size = 200 - -Version of grapher that can handle the output of ghc's @+RTS -Sstderr@ -option. - -Nice variant would be to take a list of numbers from the commandline -and display several graphs at once. - -> main :: IO () -> main = -> getArgs >>= \ r -> -> case r of -> [select] -> -> let selection = read select -> in -> xInitialise [] screen_size screen_size >> -> hGetContents stdin >>= \ input -> -> graphloop2 (parseGCData selection input) [] -> _ -> -> error "usage: graph <number in range 0..17>\n" - -The format of glhc18's stderr stuff is: - --- start of example (view in 120 column window) -graph +RTS -Sstderr -H500 - -Collector: APPEL HeapSize: 500 (bytes) - - Alloc Collect Live Resid GC GC TOT TOT Page Flts No of Roots Caf Mut- Old Collec Resid - bytes bytes bytes ency user elap user elap GC MUT Astk Bstk Reg No able Gen tion %heap - 248 248 60 24.2% 0.00 0.04 0.05 0.23 1 1 1 0 0 1 0 0 Minor --- end of example - 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 - -That is: 6 header lines followed by 17-18 columns of integers, -percentages, floats and text. - -The scaling in the following is largely based on guesses about likely -values - needs tuned. - -@gcParsers@ is a list of functions which parse the corresponding -column and attempts to scale the numbers into the range $0.0 .. 1.0$. -(But may return a number avove $1.0$ which graphing part will scale to -fit screen...) - -(Obvious optimisation - replace by list of scaling information!) - -(Obvious improvement - return (x,y) pair based on elapsed (or user) time.) - -> gcParsers :: [ String -> Float ] -> gcParsers = [ heap, heap, heap, percent, time, time, time, time, flts, flts, stk, stk, reg, caf, caf, heap, text, percent ] -> where -> heap = scale 100000.0 . fromInt . check 0 . readDec -> stk = scale 25000.0 . fromInt . check 0 . readDec -> int = scale 1000.0 . fromInt . check 0 . readDec -> reg = scale 10.0 . fromInt . check 0 . readDec -> caf = scale 100.0 . fromInt . check 0 . readDec -> flts = scale 100.0 . fromInt . check 0 . readDec -> percent = scale 100.0 . check 0.0 . readFloat -> time = scale 20.0 . check 0.0 . readFloat -> text s = 0.0 - -> check :: a -> [(a,String)] -> a -> check error_value parses = -> case parses of -> [] -> error_value -> ((a,s):_) -> a - -> scale :: Float -> Float -> Float -> scale max n = n / max - -> parseGCData :: Int -> String -> [Float] -> parseGCData column input = -> map ((gcParsers !! column) . (!! column) . words) (drop 6 (lines input)) - -Hmmm, how to add logarithmic scaling neatly? Do I still need to? - -Note: unpleasant as it is, the code cannot be simplified to something -like the following. The problem is that the graph won't start to be -drawn until the first @n@ values are available. (Is there also a -danger of clearing the screen while waiting for the next input value?) -A possible alternative solution is to keep count of how many values -have actually been received. - -< graphloop2 :: [Float] -> [Float] -> IO () -< graphloop2 [] = -< return () -< graphloop2 ys = -< let ys' = take n ys -< m = maximum ys' -< y_scale = (floor m) + 1 -< y_scale' = fromInt y_scale -< in -< xCls >> -< drawScales y_scale >> -< draw x_coords [ x / y_scale' | x <- ys' ] >> -< xHandleEvent >> -< graphloop2 (tail ys) - - -> graphloop2 :: [Float] -> [Float] -> IO () -> graphloop2 (y:ys) xs = -> let xs' = take n (y:xs) -> m = maximum xs' -> y_scale = (floor m) + 1 -> y_scale' = fromInt y_scale -> in -> xCls >> -> drawScales y_scale >> -> draw x_coords [ x / y_scale' | x <- xs' ] >> -> xHandleEvent >> -> graphloop2 ys xs' -> graphloop2 [] xs = -> return () - -> x_coords :: [Float] -> x_coords = [ 0.0, 1 / (fromInt n) .. ] - -Draw lines specified by coordinates in range (0.0 .. 1.0) onto screen. - -> draw :: [Float] -> [Float] -> IO () -> draw xs ys = drawPoly (zip xs' (reverse ys')) -> where -> xs' = [ floor (x * sz) | x <- xs ] -> ys' = [ floor ((1.0 - y) * sz) | y <- ys ] -> sz = fromInt screen_size - -> drawPoly :: [(Int, Int)] -> IO () -> drawPoly ((x1,y1):(x2,y2):poly) = -> xDrawLine x1 y1 x2 y2 >> -> drawPoly ((x2,y2):poly) -> drawPoly _ = return () - -Draw horizontal line at major points on y-axis. - -> drawScales :: Int -> IO () -> drawScales y_scale = -> sequence (map drawScale ys) >> -> return () -> where -> ys = [ (fromInt i) / (fromInt y_scale) | i <- [1 .. y_scale - 1] ] - -> drawScale :: Float -> IO () -> drawScale y = -> let y' = floor ((1.0 - y) * (fromInt screen_size)) -> in -> xDrawLine 0 y' screen_size y' - ->#include "common-bits" diff --git a/utils/heap-view/HaskXLib.c b/utils/heap-view/HaskXLib.c deleted file mode 100644 index b6cf1f137c..0000000000 --- a/utils/heap-view/HaskXLib.c +++ /dev/null @@ -1,297 +0,0 @@ -/*----------------------------------------------------------------------* - * X from Haskell (PicoX) - * - * (c) 1993 Andy Gill - * - *----------------------------------------------------------------------*/ - -#include <X11/Xlib.h> -#include <X11/Xutil.h> -#include <X11/Xatom.h> -#include <stdio.h> -#include <strings.h> - -/*----------------------------------------------------------------------*/ - -/* First the X Globals */ - -Display *MyDisplay; -int MyScreen; -Window MyWindow; -XEvent MyWinEvent; -GC DrawGC; -GC UnDrawGC; - -/* and the Haskell globals */ - -typedef struct { - int HaskButtons[5]; - int HaskPointerX,HaskPointerY; - int PointMoved; -} HaskGlobType; - -HaskGlobType HaskGlob; - -/*----------------------------------------------------------------------*/ - -/* - * Now the access functions into the haskell globals - */ - -int haskGetButtons(int n) -{ - return(HaskGlob.HaskButtons[n]); -} - -int haskGetPointerX(void) -{ - return(HaskGlob.HaskPointerX); -} - -int haskGetPointerY(void) -{ - return(HaskGlob.HaskPointerY); -} - -/*----------------------------------------------------------------------*/ - -/* - *The (rather messy) initiualisation - */ - -haskXBegin(int x,int y,int sty) -{ - /* - * later include these via interface hacks - */ - - /* (int argc, char **argv) */ - int argc = 0; - char **argv = 0; - - XSizeHints XHints; - int MyWinFG, MyWinBG,tmp; - - if ((MyDisplay = XOpenDisplay("")) == NULL) { - fprintf(stderr, "Cannot connect to X server '%s'\n", XDisplayName("")); - exit(1); - } - - MyScreen = DefaultScreen(MyDisplay); - - MyWinBG = WhitePixel(MyDisplay, MyScreen); - MyWinFG = BlackPixel(MyDisplay, MyScreen); - - XHints.x = x; - XHints.y = y; - XHints.width = x; - XHints.height = y; - XHints.flags = PPosition | PSize; - - MyWindow = - XCreateSimpleWindow( - MyDisplay, - DefaultRootWindow(MyDisplay), - x,y, x, y, - 5, - MyWinFG, - MyWinBG - ); - - XSetStandardProperties( - MyDisplay, - MyWindow, - "XLib for Glasgow Haskell", - "XLib for Glasgow Haskell", - None, - argv, - argc, - &XHints - ); - - /* Create drawing and erasing GC */ - - DrawGC = XCreateGC(MyDisplay,MyWindow,0, 0); - XSetBackground(MyDisplay,DrawGC,MyWinBG); - XSetForeground(MyDisplay,DrawGC,MyWinFG); - - UnDrawGC = XCreateGC(MyDisplay,MyWindow,0, 0); - XSetBackground(MyDisplay,UnDrawGC,MyWinFG); - XSetForeground(MyDisplay,UnDrawGC,MyWinBG); - - XSetGraphicsExposures(MyDisplay,DrawGC,False); - XSetGraphicsExposures(MyDisplay,UnDrawGC,False); - XMapRaised(MyDisplay,MyWindow); - - /* the user should be able to choose which are tested for - */ - - XSelectInput( - MyDisplay, - MyWindow, - ButtonPressMask | ButtonReleaseMask | PointerMotionMask - ); - - /* later have more drawing styles - */ - - switch (sty) - { - case 0: - /* Andy, this used to be GXor not much use for Undrawing so I - changed it. (Not much use for colour either - see next - comment */ - XSetFunction(MyDisplay,DrawGC,GXcopy); - XSetFunction(MyDisplay,UnDrawGC,GXcopy); - break; - case 1: - /* Andy, this can have totally bogus results on a colour screen */ - XSetFunction(MyDisplay,DrawGC,GXxor); - XSetFunction(MyDisplay,UnDrawGC,GXxor); - break; - default: - /* Andy, is this really a good error message? */ - printf(stderr,"Wrong Argument to XSet function\n"); - } - /* - * reset the (Haskell) globals - */ - - for(tmp=0;tmp<5;tmp++) - { - HaskGlob.HaskButtons[tmp] = 0; - } - HaskGlob.HaskPointerX = 0; - HaskGlob.HaskPointerY = 0; - HaskGlob.PointMoved = 0; - - XFlush(MyDisplay); - -} - -/*----------------------------------------------------------------------*/ - -/* Boring X ``Do Something'' functions - */ - -haskXClose(void) -{ - XFreeGC( MyDisplay, DrawGC); - XFreeGC( MyDisplay, UnDrawGC); - XDestroyWindow( MyDisplay, MyWindow); - XCloseDisplay( MyDisplay); - return(0); -} - -haskXDraw(x,y,x1,y1) -int x,y,x1,y1; -{ - XDrawLine(MyDisplay, - MyWindow, - DrawGC, - x,y,x1,y1); - return(0); -} - - -haskXPlot(c,x,y) -int c; -int x,y; -{ - XDrawPoint(MyDisplay, - MyWindow, - (c?DrawGC:UnDrawGC), - x,y); - return(0); -} - -haskXFill(c,x,y,w,h) -int c; -int x, y; -int w, h; -{ - XFillRectangle(MyDisplay, - MyWindow, - (c?DrawGC:UnDrawGC), - x, y, w, h); - return(0); -} - -/*----------------------------------------------------------------------*/ - - /* This has to be called every time round the loop, - * it flushed the buffer and handles input from the user - */ - -haskHandleEvent() -{ - XFlush( MyDisplay); - while (XEventsQueued( MyDisplay, QueuedAfterReading) != 0) { - XNextEvent( MyDisplay, &MyWinEvent); - switch (MyWinEvent.type) { - case ButtonPress: - switch (MyWinEvent.xbutton.button) - { - case Button1: HaskGlob.HaskButtons[0] = 1; break; - case Button2: HaskGlob.HaskButtons[1] = 1; break; - case Button3: HaskGlob.HaskButtons[2] = 1; break; - case Button4: HaskGlob.HaskButtons[3] = 1; break; - case Button5: HaskGlob.HaskButtons[4] = 1; break; - } - break; - case ButtonRelease: - switch (MyWinEvent.xbutton.button) - { - case Button1: HaskGlob.HaskButtons[0] = 0; break; - case Button2: HaskGlob.HaskButtons[1] = 0; break; - case Button3: HaskGlob.HaskButtons[2] = 0; break; - case Button4: HaskGlob.HaskButtons[3] = 0; break; - case Button5: HaskGlob.HaskButtons[4] = 0; break; - } - break; - case MotionNotify: - HaskGlob.HaskPointerX = MyWinEvent.xmotion.x; - HaskGlob.HaskPointerY = MyWinEvent.xmotion.y; - HaskGlob.PointMoved = 1; - break; - default: - printf("UNKNOWN INTERUPT ???? (%d) \n",MyWinEvent.type); - break; - } /*switch*/ - } /*if*/ - return(0); -} - - -/*----------------------------------------------------------------------*/ - - /* A function to clear the screen - */ - -haskXCls(void) -{ - XClearWindow(MyDisplay,MyWindow); -} - -/*----------------------------------------------------------------------*/ - - /* A function to write a string - */ - -haskXDrawString(int x,int y,char *str) -{ - return(0); -/* printf("GOT HERE %s %d %d",str,x,y); - XDrawString(MyDisplay,MyWindow,DrawGC,x,y,str,strlen(str)); -*/ -} - -/*----------------------------------------------------------------------*/ - -extern int prog_argc; -extern char **prog_argv; - -haskArgs() -{ - return(prog_argc > 1 ? atoi(prog_argv[1]) : 0); -} diff --git a/utils/heap-view/HpView.lhs b/utils/heap-view/HpView.lhs deleted file mode 100644 index a7b4cbb78e..0000000000 --- a/utils/heap-view/HpView.lhs +++ /dev/null @@ -1,296 +0,0 @@ -> module Main where -> import PreludeGlaST -> import LibSystem - -> import Parse - -Program to interpret a heap profile. - -Started 28/11/93: parsing of profile -Tweaked 28/11/93: parsing fiddled till it worked and graphical backend added - -To be done: - -0) think about where I want to go with this -1) further processing... sorting, filtering, ... -2) get dynamic display -3) maybe use widgets - -Here's an example heap profile - - JOB "a.out -p" - DATE "Fri Apr 17 11:43:45 1992" - SAMPLE_UNIT "seconds" - VALUE_UNIT "bytes" - BEGIN_SAMPLE 0.00 - SYSTEM 24 - END_SAMPLE 0.00 - BEGIN_SAMPLE 1.00 - elim 180 - insert 24 - intersect 12 - disin 60 - main 12 - reduce 20 - SYSTEM 12 - END_SAMPLE 1.00 - MARK 1.50 - MARK 1.75 - MARK 1.80 - BEGIN_SAMPLE 2.00 - elim 192 - insert 24 - intersect 12 - disin 84 - main 12 - SYSTEM 24 - END_SAMPLE 2.00 - BEGIN_SAMPLE 2.82 - END_SAMPLE 2.82 - -By inspection, the format seems to be: - -profile :== header { sample } -header :== job date { unit } -job :== "JOB" command -date :== "DATE" dte -unit :== "SAMPLE_UNIT" string | "VALUE_UNIT" string - -sample :== samp | mark -samp :== "BEGIN_SAMPLE" time {pairs} "END_SAMPLE" time -pairs :== identifer count -mark :== "MARK" time - -command :== string -dte :== string -time :== float -count :== integer - -But, this doesn't indicate the line structure. The simplest way to do -this is to treat each line as a single token --- for which the -following parser is useful: - -Special purpose parser that recognises a string if it matches a given -prefix and returns the remainder. - -> prefixP :: String -> P String String -> prefixP p = -> itemP `thenP` \ a -> -> let (p',a') = splitAt (length p) a -> in if p == p' -> then unitP a' -> else zeroP - - -To begin with I want to parse a profile into a list of readings for -each identifier at each time. - -> type Sample = (Float, [(String, Int)]) - -> type Line = String - - -> profile :: P Line [Sample] -> profile = -> header `thenP_` -> zeroOrMoreP sample - -> header :: P Line () -> header = -> job `thenP_` -> date `thenP_` -> zeroOrMoreP unit `thenP_` -> unitP () - -> job :: P Line String -> job = prefixP "JOB " - -> date :: P Line String -> date = prefixP "DATE " - -> unit :: P Line String -> unit = -> ( prefixP "SAMPLE_UNIT " ) -> `plusP` -> ( prefixP "VALUE_UNIT " ) - -> sample :: P Line Sample -> sample = -> samp `plusP` mark - -> mark :: P Line Sample -> mark = -> prefixP "MARK " `thenP` \ time -> -> unitP (read time, []) - -ToDo: check that @time1 == time2@ - -> samp :: P Line Sample -> samp = -> prefixP "BEGIN_SAMPLE " `thenP` \ time1 -> -> zeroOrMoreP pair `thenP` \ pairs -> -> prefixP "END_SAMPLE " `thenP` \ time2 -> -> unitP (read time1, pairs) - -> pair :: P Line (String, Int) -> pair = -> prefixP " " `thenP` \ sample_line -> -> let [identifier,count] = words sample_line -> in unitP (identifier, read count) - -This test works fine - -> {- -> test :: String -> String -> test str = ppSamples (theP profile (lines str)) - -> test1 = test example - -> test2 :: String -> Dialogue -> test2 file = -> readFile file exit -> (\ hp -> appendChan stdout (test hp) exit -> done) -> -} - -Inefficient pretty-printer (uses ++ excessively) - -> ppSamples :: [ Sample ] -> String -> ppSamples = unlines . map ppSample - -> ppSample :: Sample -> String -> ppSample (time, samps) = -> (show time) ++ unwords (map ppSamp samps) - -> ppSamp :: (String, Int) -> String -> ppSamp (identifier, count) = identifier ++ ":" ++ show count - -To get the test1 to work in gofer, you need to fiddle with the input -a bit to get over Gofer's lack of string-parsing code. - -> example = -> "JOB \"a.out -p\"\n" ++ -> "DATE \"Fri Apr 17 11:43:45 1992\"\n" ++ -> "SAMPLE_UNIT \"seconds\"\n" ++ -> "VALUE_UNIT \"bytes\"\n" ++ -> "BEGIN_SAMPLE 0.00\n" ++ -> " SYSTEM 24\n" ++ -> "END_SAMPLE 0.00\n" ++ -> "BEGIN_SAMPLE 1.00\n" ++ -> " elim 180\n" ++ -> " insert 24\n" ++ -> " intersect 12\n" ++ -> " disin 60\n" ++ -> " main 12\n" ++ -> " reduce 20\n" ++ -> " SYSTEM 12\n" ++ -> "END_SAMPLE 1.00\n" ++ -> "MARK 1.50\n" ++ -> "MARK 1.75\n" ++ -> "MARK 1.80\n" ++ -> "BEGIN_SAMPLE 2.00\n" ++ -> " elim 192\n" ++ -> " insert 24\n" ++ -> " intersect 12\n" ++ -> " disin 84\n" ++ -> " main 12\n" ++ -> " SYSTEM 24\n" ++ -> "END_SAMPLE 2.00\n" ++ -> "BEGIN_SAMPLE 2.82\n" ++ -> "END_SAMPLE 2.82" - - - - -Hack to let me test this code... Gofer doesn't have integer parsing built in. - -> {- -> read :: String -> Int -> read s = 0 -> -} - -> screen_size = 200 - -ToDo: - -1) the efficiency of finding slices can probably be dramatically - improved... if it matters. - -2) the scaling should probably depend on the slices used - -3) labelling graphs, colour, ... - -4) responding to resize events - -> main :: IO () -> main = -> getArgs >>= \ r -> -> case r of -> filename:idents -> -> readFile filename >>= \ hp -> -> let samples = theP profile (lines hp) -> -> times = [ t | (t,ss) <- samples ] -> names = [ n | (t,ss) <- samples, (n,c) <- ss ] -> counts = [ c | (t,ss) <- samples, (n,c) <- ss ] -> -> time = maximum times -> x_scale = (fromInt screen_size) / time -> -> max_count = maximum counts -> y_scale = (fromInt screen_size) / (fromInt max_count) -> -> slices = map (slice samples) idents -> in -> xInitialise [] screen_size screen_size >> -> -- drawHeap x_scale y_scale samples >> -> sequence (map (drawSlice x_scale y_scale) slices) >> -> freeze -> _ -> error "usage: hpView filename identifiers\n" - -> freeze :: IO () -> freeze = -> xHandleEvent >> -> usleep 100 >> -> freeze - - -Slice drawing stuff... shows profile for each identifier - -> slice :: [Sample] -> String -> [(Float,Int)] -> slice samples ident = -> [ (t,c) | (t,ss) <- samples, c <- [lookupPairs ss ident 0] ] - -> lookupPairs :: Eq a => [(a, b)] -> a -> b -> b -> lookupPairs ((a', b') : hs) a b = -> if a == a' then b' else lookupPairs hs a b -> lookupPairs [] a b = b - -> drawSlice :: Float -> Float -> [(Float,Int)] -> IO () -> drawSlice x_scale y_scale slc = -> drawPoly -> [ (round (x*x_scale), screen_size - (round ((fromInt y)*y_scale))) | (x,y) <- slc ] - -> drawPoly :: [(Int, Int)] -> IO () -> drawPoly ((x1,y1):(x2,y2):poly) = -> xDrawLine x1 y1 x2 y2 >> -> drawPoly ((x2,y2):poly) -> drawPoly _ = return () - - -Very simple heap profiler... doesn't do a proper job at all. Good for -testing. - -> drawHeap :: Float -> Float -> [Sample] -> IO () -> drawHeap x_scale y_scale samples = -> sequence (map xBar -> [ (t*x_scale, (fromInt c)*y_scale) -> | (t,ss) <- samples, (n,c) <- ss ]) >> -> return () - -> xBar :: (Float, Float) -> IO () -> xBar (x, y) = -> let {x' = round x; y' = round y} -> in xDrawLine x' screen_size x' (screen_size - y') - ->#include "common-bits" diff --git a/utils/heap-view/HpView2.lhs b/utils/heap-view/HpView2.lhs deleted file mode 100644 index fa8044b8b4..0000000000 --- a/utils/heap-view/HpView2.lhs +++ /dev/null @@ -1,225 +0,0 @@ -> module Main where -> import PreludeGlaST -> import LibSystem - -> import Parse - -Program to do continuous heap profile. - -Bad News: - - The ghc runtime system writes its heap profile information to a - named file (<progname>.hp). The program merrily reads its input - from a named file but has no way of synchronising with the program - generating the file. - -Good News 0: - - You can save the heap profile to a file: - - <progname> <parameters> +RTS -h -i0.1 -RTS - - and then run: - - hpView2 <progname>.hp Main:<functionname> - - This is very like using hp2ps but much more exciting because you - never know what's going to happen next :-) - - -Good News 1: - - The prophet Stallman has blessed us with the shell command @mkfifo@ - (is there a standard Unix version?) which creates a named pipe. If we - instead run: - - mkfifo <progname>.hp - hpView2 <progname>.hp Main:<functionname> & - <progname> <parameters> +RTS -h -i0.1 -RTS - rm <progname>.hp - - Good Things happen. - - NB If you don't delete the pipe, Bad Things happen: the program - writes profiling info to the pipe until the pipe fills up then it - blocks... - - -Right, on with the program: - -Here's an example heap profile - - JOB "a.out -p" - DATE "Fri Apr 17 11:43:45 1992" - SAMPLE_UNIT "seconds" - VALUE_UNIT "bytes" - BEGIN_SAMPLE 0.00 - SYSTEM 24 - END_SAMPLE 0.00 - BEGIN_SAMPLE 1.00 - elim 180 - insert 24 - intersect 12 - disin 60 - main 12 - reduce 20 - SYSTEM 12 - END_SAMPLE 1.00 - MARK 1.50 - MARK 1.75 - MARK 1.80 - BEGIN_SAMPLE 2.00 - elim 192 - insert 24 - intersect 12 - disin 84 - main 12 - SYSTEM 24 - END_SAMPLE 2.00 - BEGIN_SAMPLE 2.82 - END_SAMPLE 2.82 - -In HpView.lhs, I had a fancy parser to handle all this - but it was -immensely inefficient. We can produce something a lot more efficient -and robust very easily by noting that the only lines we care about -have precisely two entries on them. - -> type Line = String -> type Word = String -> type Sample = (Float, [(String, Int)]) - -> parseProfile :: [[Word]] -> [Sample] -> parseProfile [] = [] -> parseProfile ([keyword, time]:lines) | keyword == "BEGIN_SAMPLE" = -> let (sample,rest) = parseSample lines -> in -> (read time, sample) : parseProfile rest -> parseProfile (_:xs) = parseProfile xs - -> parseSample :: [[Word]] -> ([(String,Int)],[[Word]]) -> parseSample ([word, count]:lines) = -> if word == "END_SAMPLE" -> then ([], lines) -> else let (samples, rest) = parseSample lines -> in ( (word, read count):samples, rest ) -> parseSample duff_lines = ([],duff_lines) - -> screen_size = 200 - -> main :: IO () -> main = -> getArgs >>= \ r -> -> case r of -> [filename, ident] -> -> xInitialise [] screen_size screen_size >> -> readFile filename >>= \ hp -> -> let samples = parseProfile (map words (lines hp)) -> totals = [ sum [ s | (_,s) <- ss ] | (t,ss) <- samples ] -> -> ts = map scale totals -> is = map scale (slice samples ident) -> in -> graphloop2 (is, []) (ts, []) -> _ -> error "usage: hpView2 file identifier\n" - -For the example I'm running this on, the following scale does nicely. - -> scale :: Int -> Float -> scale n = (fromInt n) / 10000.0 - -Slice drawing stuff... shows profile for each identifier (Ignores time -info in this version...) - -> slice :: [Sample] -> String -> [Int] -> slice samples ident = -> [ c | (t,ss) <- samples, c <- [lookupPairs ss ident 0] ] - -> lookupPairs :: Eq a => [(a, b)] -> a -> b -> b -> lookupPairs ((a', b') : hs) a b = -> if a == a' then b' else lookupPairs hs a b -> lookupPairs [] a b = b - -Number of samples to display on screen - -> n :: Int -> n = 40 - -Graph-drawing loop. Get's the data for the particular identifier and -the total usage, scales to get total to fit screen and draws them. - -> graphloop2 :: ([Float], [Float]) -> ([Float], [Float]) -> IO () -> graphloop2 (i:is,is') (t:ts, ts') = -> let is'' = take n (i:is') -> ts'' = take n (t:ts') -> -> -- scaling information: -> m = maximum ts'' -> y_scale = (floor m) + 1 -> y_scale' = fromInt y_scale -> in -> xCls >> -> drawScales y_scale >> -> draw x_coords [ x / y_scale' | x <- is'' ] >> -> draw x_coords [ x / y_scale' | x <- ts'' ] >> -> xHandleEvent >> -> graphloop2 (is,is'') (ts, ts'') -> graphloop2 _ _ = -> return () - -> x_coords :: [Float] -> x_coords = [ 0.0, 1 / (fromInt n) .. ] - -Note: unpleasant as it is, the code cannot be simplified to something -like the following (which has scope for changing draw to take a list -of pairs). The problem is that the graph won't start to be drawn -until the first @n@ values are available. (Is there also a danger of -clearing the screen while waiting for the next input value?) A -possible alternative solution is to keep count of how many values have -actually been received. - -< graphloop2 :: [Float] -> [Float] -> IO () -< graphloop2 [] = -< return () -< graphloop2 ys = -< let ys' = take n ys -< m = maximum ys' -< y_scale = (floor m) + 1 -< y_scale' = fromInt y_scale -< in -< xCls >> -< drawScales y_scale >> -< draw x_coords [ x / y_scale' | x <- ys' ] >> -< xHandleEvent >> -< graphloop2 (tail ys) - -Draw lines specified by coordinates in range (0.0 .. 1.0) onto screen. - -> draw :: [Float] -> [Float] -> IO () -> draw xs ys = drawPoly (zip xs' (reverse ys')) -> where -> xs' = [ floor (x * sz) | x <- xs ] -> ys' = [ floor ((1.0 - y) * sz) | y <- ys ] -> sz = fromInt screen_size - -> drawPoly :: [(Int, Int)] -> IO () -> drawPoly ((x1,y1):(x2,y2):poly) = -> xDrawLine x1 y1 x2 y2 >> -> drawPoly ((x2,y2):poly) -> drawPoly _ = return () - -Draw horizontal line at major points on y-axis. - -> drawScales :: Int -> IO () -> drawScales y_scale = -> sequence (map drawScale ys) >> -> return () -> where -> ys = [ (fromInt i) / (fromInt y_scale) | i <- [1 .. y_scale - 1] ] - -> drawScale :: Float -> IO () -> drawScale y = -> let y' = floor ((1.0 - y) * (fromInt screen_size)) -> in -> xDrawLine 0 y' screen_size y' - ->#include "common-bits" diff --git a/utils/heap-view/MAIL b/utils/heap-view/MAIL deleted file mode 100644 index 966fcdcfc7..0000000000 --- a/utils/heap-view/MAIL +++ /dev/null @@ -1,67 +0,0 @@ -To: partain@dcs.gla.ac.uk -cc: areid@dcs.gla.ac.uk, andy@dcs.gla.ac.uk -Subject: Heap profiling programs -Date: Thu, 09 Dec 93 17:33:09 +0000 -From: Alastair Reid <areid@dcs.gla.ac.uk> - - -I've hacked up a couple of programs which it might be worth putting in -the next ghc distribution. They are: - -graph: - - Draws a continuous graph of any one column of the statistics - produced using the "+RTS -Sstderr" option. - - I'm not convinced this is astonishingly useful since I'm yet to - learn anything useful from (manually) examining these statistics. - (Although I do vaguely remember asking Patrick if the heap profiler - could do stack profiles too.) - - A typical usage is: - - slife 2 Unis/gardenofeden +RTS -Sstderr -H1M -RTS |& graph 2 - - which draws a graph of the third column (ie column 2!) of the - stats. - - (btw is there a neater way of connecting stderr to graph's stdin?) - -hpView2: - - Draws a continuous graph of the statistics reported by the "+RTS -h" - option. - - Since I understand what the figures mean, this seems to be the more - useful program. - - A typical usage is: - - mkfifo slife.hp - hpView2 slife.hp Main:mkQuad & - slife 2 Unis/gardenofeden +RTS -h -i0.1 -RTS - rm slife.hp - - which draws a graph of the total heap usage and the usage for Main:mkQuad. - - -Minor problems: - -The code is a gross hack... but it works. (Maybe distribute in rot13 -format so that you don't get accidentally get exposed to obscene code -:-)) - -The code uses a variant of Andy's picoXlibrary (which he was talking -about releasing but maybe isn't ready to do yet.) - -Also, there are lots of obvious extensions etc which could be made but -haven't yet... (The major one is being able to set the initial -scale-factor for displaying the graphs or being able to graph several -stats at once without having to tee.) - - -Hope you find them interesting. - -Alastair - -ps Code is in ~areid/hask/Life and should be readable/executable. diff --git a/utils/heap-view/Makefile b/utils/heap-view/Makefile deleted file mode 100644 index e8fa8faf08..0000000000 --- a/utils/heap-view/Makefile +++ /dev/null @@ -1,31 +0,0 @@ -TOP=../.. -include $(TOP)/mk/boilerplate.mk - -PROGRAMS = graph hpView hpView2 - -SRC_HC_OPTS += -hi-diffs -fglasgow-exts -fhaskell-1.3 -O -L/usr/X11/lib -cpp -SRC_CC_OPTS += -ansi -I/usr/X11/include -# ToDo: use AC_PATH_X in configure to get lib/include dirs for X. - -OBJS_graph = Graph.o HaskXLib.o -OBJS_hpView = HpView.o Parse.o HaskXLib.o -OBJS_hpView2 = HpView2.o Parse.o HaskXLib.o - -all :: $(PROGRAMS) - -graph : $(OBJS_graph) - $(HC) -o $@ $(HC_OPTS) $(LD_OPTS) $(OBJS_graph) -lX11 - -hpView : $(OBJS_hpView) - $(HC) -o $@ $(HC_OPTS) $(LD_OPTS) $(OBJS_hpView) -lX11 - -hpView2 : $(OBJS_hpView2) - $(HC) -o $@ $(HC_OPTS) $(LD_OPTS) $(OBJS_hpView2) -lX11 - -HaskXLib.o : HaskXLib.c - $(CC) -c $(CC_OPTS) HaskXLib.c - -INSTALL_PROGS += $(PROGRAMS) -CLEAN_FILES += $(PROGRAMS) - -include $(TOP)/mk/target.mk diff --git a/utils/heap-view/Makefile.original b/utils/heap-view/Makefile.original deleted file mode 100644 index 1e35bc2e43..0000000000 --- a/utils/heap-view/Makefile.original +++ /dev/null @@ -1,48 +0,0 @@ -CC=gcc -GLHC18 = glhc18 -GLHC19 = /users/fp/partain/bin/sun4/glhc -HC= ghc -hi-diffs -fglasgow-exts -fhaskell-1.3 -HC_FLAGS = -O -prof -auto-all -#HC_FLAGS = -O -LIBS=-lX11 -FILES2 = Life2.o HaskXLib.o -FILESS = LifeWithStability.o HaskXLib.o -FILES = Life.o HaskXLib.o - -all : hpView hpView2 - -# ADR's heap profile viewer -hpView: HpView.o Parse.o HaskXLib.o - $(HC) -o hpView $(HC_FLAGS) HpView.o Parse.o HaskXLib.o $(LIBS) -L/usr/X11/lib -clean:: - rm -f hpView - -# ADR's continuous heap profile viewer (handles output of -p) -hpView2: HpView2.o Parse.o HaskXLib.o - $(HC) -o hpView2 $(HC_FLAGS) HpView2.o Parse.o HaskXLib.o $(LIBS) -L/usr/X11/lib -clean:: - rm -f hpView2 - - -# ADR's continuous graph program (handles output of -Sstderr) -graph: Graph.o HaskXLib.o - $(HC) -o graph $(HC_FLAGS) Graph.o HaskXLib.o $(LIBS) -L/usr/X11/lib -clean:: - rm -f graph - -# ADR's continuous graph program (part of heap profile viewer) that -# crashes the compiler -bugGraph: bugGraph.o HaskXLib.o - $(HC) -o bugGraph $(HC_FLAGS) bugGraph.o HaskXLib.o $(LIBS) -L/usr/X11/lib -clean:: - rm -f bugGraph - -%.o:%.c - $(CC) -c -ansi -traditional -g -I/usr/X11/include/ $< $(INC) - -%.o:%.lhs - $(HC) $(HC_FLAGS) -c $< $(INC) - -clean:: - rm -f core *.o *% #* - rm -f *.hc diff --git a/utils/heap-view/Parse.lhs b/utils/heap-view/Parse.lhs deleted file mode 100644 index 9d7652fdcc..0000000000 --- a/utils/heap-view/Parse.lhs +++ /dev/null @@ -1,92 +0,0 @@ -> module Parse where - -The Parser monad in "Comprehending Monads" - -> infixr 9 `thenP` -> infixr 9 `thenP_` -> infixr 9 `plusP` - -> type P t a = [t] -> [(a,[t])] - -> unitP :: a -> P t a -> unitP a = \i -> [(a,i)] - -> thenP :: P t a -> (a -> P t b) -> P t b -> m `thenP` k = \i0 -> [(b,i2) | (a,i1) <- m i0, (b,i2) <- k a i1] - -> thenP_ :: P t a -> P t b -> P t b -> m `thenP_` k = \i0 -> [(b,i2) | (a,i1) <- m i0, (b,i2) <- k i1] - -zeroP is the parser that always fails to parse its input - -> zeroP :: P t a -> zeroP = \i -> [] - -plusP combines two parsers in parallel -(called "alt" in "Comprehending Monads") - -> plusP :: P t a -> P t a -> P t a -> a1 `plusP` a2 = \i -> (a1 i) ++ (a2 i) - -itemP is the parser that parses a single token -(called "next" in "Comprehending Monads") - -> itemP :: P t t -> itemP = \i -> [(head i, tail i) | not (null i)] - -force successful parse - -> cutP :: P t a -> P t a -> cutP p = \u -> let l = p u in if null l then [] else [head l] - -find all complete parses of a given string - -> useP :: P t a -> [t] -> [a] -> useP m = \x -> [ a | (a,[]) <- m x ] - -find first complete parse - -> theP :: P t a -> [t] -> a -> theP m = head . (useP m) - - -Some standard parser definitions - -mapP applies f to all current parse trees - -> mapP :: (a -> b) -> P t a -> P t b -> f `mapP` m = m `thenP` (\a -> unitP (f a)) - -filter is the parser that parses a single token if it satisfies a -predicate and fails otherwise. - -> filterP :: (a -> Bool) -> P t a -> P t a -> p `filterP` m = m `thenP` (\a -> (if p a then unitP a else zeroP)) - -lit recognises literals - -> litP :: Eq t => t -> P t () -> litP t = ((==t) `filterP` itemP) `thenP` (\c -> unitP () ) - -> showP :: (Text a) => P t a -> [t] -> String -> showP m xs = show (theP m xs) - - -Simon Peyton Jones adds some useful operations: - -> zeroOrMoreP :: P t a -> P t [a] -> zeroOrMoreP p = oneOrMoreP p `plusP` unitP [] - -> oneOrMoreP :: P t a -> P t [a] -> oneOrMoreP p = seq p -> where seq p = p `thenP` (\a -> -> (seq p `thenP` (\as -> unitP (a:as))) -> `plusP` -> unitP [a] ) - -> oneOrMoreWithSepP :: P t a -> P t b -> P t [a] -> oneOrMoreWithSepP p1 p2 = seq1 p1 p2 -> where seq1 p1 p2 = p1 `thenP` (\a -> seq2 p1 p2 a `plusP` unitP [a]) -> seq2 p1 p2 a = p2 `thenP` (\_ -> -> seq1 p1 p2 `thenP` (\as -> unitP (a:as) )) - diff --git a/utils/heap-view/README b/utils/heap-view/README deleted file mode 100644 index db9503abc4..0000000000 --- a/utils/heap-view/README +++ /dev/null @@ -1,62 +0,0 @@ -@HpView.lhs@ is a very primitive heap profile viewer written in -Haskell. It feeds off the same files as hp2ps. It needs a lot of -tidying up and would be far more useful as a continuous display. -(It's in this directory `cos there happens to be a heap profile here -and I couldn't be bothered setting up a new directory, Makefile, etc.) - -@Graph.lhs@ is a continuous heap viewer that "parses" the output of -the +RTS -Sstderr option. Typical usage: - - slife 1 r4 +RTS -Sstderr |& graph 2 - -(You might also try - - cat data | graph 2 - - to see it in action on some sample data. -) - -Things to watch: - - 1) Scaling varies from column to column - consult the source. - - 2) The horizontal scale is not time - it is garbage collections. - - 3) The graph is of the (n+1)st column of the -Sstderr output. - - The data is not always incredibly useful: For example, when using - the (default) Appel 2-space garbage collector, the 3rd column - displays the amount of "live" data in the minor space. A program - with a constant data usage will appear to have a sawtooth usage - as minor data gradually transfers to the major space and then, - suddenly, all gets transferred back at major collections. - Decreasing heap size decreases the size of the minor collections - and increases major collections exaggerating the sawtooth. - - 4) The program is not as robust as it might be. - - -@HpView2.lhs@ is the result of a casual coupling of @Graph.lhs@ and -@HpView.lhs@ which draws continuous graphs of the heap consisting of: -total usage and usage by one particular cost centre. For example: - - mkfifo slife.hp - hpView2 slife.hp Main:mkQuad & - slife 2 Unis/gardenofeden +RTS -h -i0.1 -RTS - rm slife.hp - -draws a graph of total usage and usage by the function @mkQuad@. - -(You might also try - - hpView2 slife.old-hp Main:mkQuad - - to see it in action on some older data) - -The business with named pipes (mkfifo) is a little unfortunate - it -would be nicer if the Haskell runtime system could output to stderr -(say) which I could pipe into hpView which could just graph it's stdin -(like graph does). It's probably worth wrapping the whole thing up in -a little shell-script. - - diff --git a/utils/heap-view/common-bits b/utils/heap-view/common-bits deleted file mode 100644 index f41223b7f4..0000000000 --- a/utils/heap-view/common-bits +++ /dev/null @@ -1,35 +0,0 @@ - ----------------------------------------------------------------------------- - - xInitialise :: [String] -> Int -> Int -> IO () - xInitialise str x y = - _ccall_ haskXBegin x y (0::Int) `seqPrimIO` - return () - - xHandleEvent :: IO () - xHandleEvent = - _ccall_ haskHandleEvent `thenPrimIO` \ n -> - case (n::Int) of - 0 -> return () - _ -> error "Unknown Message back from Handle Event" - - xClose :: IO () - xClose = - _ccall_ haskXClose `seqPrimIO` - return () - - xCls :: IO () - xCls = - _ccall_ haskXCls `seqPrimIO` - return () - - xDrawLine :: Int -> Int -> Int -> Int -> IO () - xDrawLine x1 y1 x2 y2 = - _ccall_ haskXDraw x1 y1 x2 y2 `seqPrimIO` - return () - - ---------------------------------------------------------------- - - usleep :: Int -> IO () - usleep t = - _ccall_ usleep t `seqPrimIO` - return () diff --git a/utils/hp2ps/HpFile.c b/utils/hp2ps/HpFile.c index 5ee9cc259e..9459247a03 100644 --- a/utils/hp2ps/HpFile.c +++ b/utils/hp2ps/HpFile.c @@ -227,7 +227,7 @@ GetHpLine(FILE *infp) Error("%s, line %d: integer must follow identifier", hpfile, linenum); } - StoreSample(GetEntry(theident), nsamples, (floatish) theinteger); + StoreSample(GetEntry(theident), nsamples, thefloatish); GetHpTok(infp); break; @@ -358,8 +358,13 @@ GetNumber(FILE *infp) thefloatish = (floatish) atof(numberstring); return FLOAT_TOK; } else { - theinteger = atoi(numberstring); - return INTEGER_TOK; + theinteger = atoi(numberstring); + /* Set thefloatish too. + If this is an identifier line, the value might exceed + the size of 'int', and we are going to convert it to + a floatish anyways. */ + thefloatish = (floatish) atof(numberstring); + return INTEGER_TOK; } } diff --git a/utils/pvm/README b/utils/pvm/README deleted file mode 100644 index 5ab58ddec8..0000000000 --- a/utils/pvm/README +++ /dev/null @@ -1,4 +0,0 @@ -"debugger2" is our hacked version of the one that -comes with PVM 3.3.7. - -Less sure about "debugger.emacs"... diff --git a/utils/pvm/debugger.emacs b/utils/pvm/debugger.emacs deleted file mode 100644 index ee053ca7b4..0000000000 --- a/utils/pvm/debugger.emacs +++ /dev/null @@ -1,37 +0,0 @@ -#!/bin/csh -f -# -# debugger.csh -# -# this script is invoked by the pvmd when a task is spawned with -# the PvmTaskDebug flag set. it execs an xterm with script -# debugger2 running inside. -# -# 06 Apr 1993 Manchek -# - -if ($#argv < 1) then - echo "usage: debugger command [args]" - exit 1 -endif - -# scratch file for debugger commands - -set TEMPCMD=gdb$$.cmd -set TEMPLISP=gdb$$.el - -# default debugger and flags - -# -# run the debugger -# - -echo run $argv[2-] > $TEMPCMD -echo "(gdb "'"'"$argv[1] -q -x $TEMPCMD"'")' > $TEMPLISP - -emacs -l $TEMPLISP - -#rm -f $TEMPCMD $TEMPLISP - -exit 0 - - diff --git a/utils/pvm/debugger2 b/utils/pvm/debugger2 deleted file mode 100644 index 7cdf8b9a1a..0000000000 --- a/utils/pvm/debugger2 +++ /dev/null @@ -1,48 +0,0 @@ -#!/bin/csh -f -# -# debugger2.csh -# -# this script is invoked in an xterm by the generic debugger script. -# it starts the debugger and waits when it exits to prevent the -# window from closing. -# -# it expects the pvmd to set envar PVM_ARCH. -# -# 06 Apr 1993 Manchek -# - -set noglob - -# scratch file for debugger commands - -set TEMPCMD=/tmp/debugger2.$$ - -# default debugger and flags - -set DBCMD="gdb" -set DBFF="-q -x $TEMPCMD" - -# -# try to pick the debugger by arch name -# - -# -# run the debugger -# - -echo run $argv[2-] > $TEMPCMD -$DBCMD $DBFF $argv[1] - -#$DBCMD $argv[1] - -#rm -f $TEMPCMD - -# -# wait to go away -# - -#reset -#sleep 1 -rm -f $TEMPCMD -exit 0 - diff --git a/vagrant/bootstrap-deb.sh b/utils/vagrant/bootstrap-deb.sh index b9ba957b4a..b9ba957b4a 100755 --- a/vagrant/bootstrap-deb.sh +++ b/utils/vagrant/bootstrap-deb.sh diff --git a/vagrant/bootstrap-rhel.sh b/utils/vagrant/bootstrap-rhel.sh index 5086279dc6..5086279dc6 100755 --- a/vagrant/bootstrap-rhel.sh +++ b/utils/vagrant/bootstrap-rhel.sh @@ -22,9 +22,10 @@ Flags: --fast Omit dyn way, omit binary distribution --slow Build stage2 with -DDEBUG. 2008-07-01: 14% slower than the default. - --no-dph: Skip requiring libraries/dph. In --slow mode, these tests - can take a substantial amount of time, and on some platforms - with broken linkers, we don't want to try compiling it. + --no-dph: Skip building libraries/dph and running associated tests. + In --slow mode, these tests can take a substantial amount + of time, and on some platforms with broken linkers, we + don't want to try compiling it. --help shows this usage help. Set environment variable 'CPUS' to number of cores, to exploit @@ -135,6 +136,12 @@ echo "Validating=YES" > mk/are-validating.mk echo "ValidateSpeed=$speed" >> mk/are-validating.mk echo "ValidateHpc=$hpc" >> mk/are-validating.mk +if [ $skip_dph -eq 1 ]; then + echo "BUILD_DPH=NO" >> mk/are-validating.mk +else + echo "BUILD_DPH=YES" >> mk/are-validating.mk +fi + $make -j$threads # For a "debug make", add "--debug=b --debug=m" |