summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorAdam Gundry <adam@well-typed.com>2015-10-16 13:58:52 +0100
committerAdam Gundry <adam@well-typed.com>2015-10-16 13:58:52 +0100
commit5a1b4f814f74ec1c48152d97523744518e212777 (patch)
tree7c2207ecacbd37f12c78dbcf9d4334827164e0fb /compiler
parent6757950cdd8bb0af0355539987ee78401a6a8f6b (diff)
parent808bbdf08058785ae5bc59b5b4f2b04951d4cbbf (diff)
downloadhaskell-wip/orf-reboot.tar.gz
Merge remote-tracking branch 'origin/master' into wip/orf-rebootwip/orf-reboot
Conflicts: compiler/rename/RnNames.hs compiler/typecheck/TcRnMonad.hs utils/haddock
Diffstat (limited to 'compiler')
-rw-r--r--compiler/backpack/ShPackageKey.hs241
-rw-r--r--compiler/basicTypes/DataCon.hs2
-rw-r--r--compiler/basicTypes/Id.hs12
-rw-r--r--compiler/basicTypes/IdInfo.hs56
-rw-r--r--compiler/basicTypes/Lexeme.hs26
-rw-r--r--compiler/basicTypes/MkId.hs6
-rw-r--r--compiler/basicTypes/Module.hs180
-rw-r--r--compiler/basicTypes/Module.hs-boot6
-rw-r--r--compiler/basicTypes/Name.hs10
-rw-r--r--compiler/basicTypes/OccName.hs4
-rw-r--r--compiler/basicTypes/PatSyn.hs10
-rw-r--r--compiler/basicTypes/RdrName.hs2
-rw-r--r--compiler/cmm/CLabel.hs48
-rw-r--r--compiler/cmm/CmmParse.y4
-rw-r--r--compiler/codeGen/StgCmmCon.hs4
-rw-r--r--compiler/codeGen/StgCmmExtCode.hs6
-rw-r--r--compiler/codeGen/StgCmmHeap.hs2
-rw-r--r--compiler/codeGen/StgCmmLayout.hs4
-rw-r--r--compiler/codeGen/StgCmmMonad.hs2
-rw-r--r--compiler/codeGen/StgCmmProf.hs6
-rw-r--r--compiler/codeGen/StgCmmTicky.hs12
-rw-r--r--compiler/codeGen/StgCmmUtils.hs4
-rw-r--r--compiler/coreSyn/CoreFVs.hs19
-rw-r--r--compiler/coreSyn/CoreLint.hs10
-rw-r--r--compiler/coreSyn/CorePrep.hs6
-rw-r--r--compiler/coreSyn/CoreSeq.hs8
-rw-r--r--compiler/coreSyn/CoreSubst.hs14
-rw-r--r--compiler/coreSyn/CoreSyn.hs7
-rw-r--r--compiler/coreSyn/CoreUnfold.hs2
-rw-r--r--compiler/coreSyn/PprCore.hs2
-rw-r--r--compiler/deSugar/Coverage.hs8
-rw-r--r--compiler/deSugar/Desugar.hs6
-rw-r--r--compiler/deSugar/DsBinds.hs23
-rw-r--r--compiler/deSugar/DsExpr.hs4
-rw-r--r--compiler/deSugar/DsForeign.hs4
-rw-r--r--compiler/deSugar/DsMeta.hs2
-rw-r--r--compiler/deSugar/MatchLit.hs16
-rw-r--r--compiler/ghc.cabal.in5
-rw-r--r--compiler/ghc.mk8
-rw-r--r--compiler/ghci/ByteCodeItbls.hs10
-rw-r--r--compiler/ghci/ByteCodeLink.hs4
-rw-r--r--compiler/ghci/DebuggerUtils.hs2
-rw-r--r--compiler/ghci/Linker.hs35
-rw-r--r--compiler/hsSyn/Convert.hs4
-rw-r--r--compiler/iface/BinIface.hs4
-rw-r--r--compiler/iface/LoadIface.hs6
-rw-r--r--compiler/iface/MkIface.hs111
-rw-r--r--compiler/llvmGen/Llvm.hs3
-rw-r--r--compiler/llvmGen/Llvm/AbsSyn.hs42
-rw-r--r--compiler/llvmGen/Llvm/PpLlvm.hs46
-rw-r--r--compiler/llvmGen/Llvm/Types.hs5
-rw-r--r--compiler/llvmGen/LlvmCodeGen.hs13
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Base.hs20
-rw-r--r--compiler/llvmGen/LlvmCodeGen/CodeGen.hs378
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Ppr.hs2
-rw-r--r--compiler/main/CodeOutput.hs10
-rw-r--r--compiler/main/DriverMkDepend.hs13
-rw-r--r--compiler/main/DriverPipeline.hs336
-rw-r--r--compiler/main/DynFlags.hs82
-rw-r--r--compiler/main/Finder.hs46
-rw-r--r--compiler/main/GHC.hs17
-rw-r--r--compiler/main/GhcMake.hs12
-rw-r--r--compiler/main/HeaderInfo.hs10
-rw-r--r--compiler/main/Hooks.hs5
-rw-r--r--compiler/main/HscMain.hs336
-rw-r--r--compiler/main/HscTypes.hs63
-rw-r--r--compiler/main/InteractiveEval.hs2
-rw-r--r--compiler/main/PackageConfig.hs70
-rw-r--r--compiler/main/Packages.hs358
-rw-r--r--compiler/main/Packages.hs-boot4
-rw-r--r--compiler/main/SysTools.hs41
-rw-r--r--compiler/main/TidyPgm.hs6
-rw-r--r--compiler/nativeGen/AsmCodeGen.hs14
-rw-r--r--compiler/nativeGen/PPC/Instr.hs39
-rw-r--r--compiler/nativeGen/PPC/Ppr.hs68
-rw-r--r--compiler/nativeGen/PPC/Regs.hs14
-rw-r--r--compiler/nativeGen/X86/CodeGen.hs8
-rw-r--r--compiler/parser/Lexer.x2
-rw-r--r--compiler/parser/Parser.y33
-rw-r--r--compiler/prelude/ForeignCall.hs2
-rw-r--r--compiler/prelude/PrelNames.hs92
-rw-r--r--compiler/prelude/PrelRules.hs125
-rw-r--r--compiler/prelude/PrimOp.hs4
-rw-r--r--compiler/prelude/THNames.hs4
-rw-r--r--compiler/rename/RnNames.hs16
-rw-r--r--compiler/rename/RnSource.hs22
-rw-r--r--compiler/simplCore/OccurAnal.hs2
-rw-r--r--compiler/simplCore/SetLevels.hs2
-rw-r--r--compiler/simplCore/SimplCore.hs12
-rw-r--r--compiler/simplCore/SimplUtils.hs66
-rw-r--r--compiler/simplCore/Simplify.hs18
-rw-r--r--compiler/specialise/Rules.hs29
-rw-r--r--compiler/specialise/SpecConstr.hs20
-rw-r--r--compiler/specialise/Specialise.hs22
-rw-r--r--compiler/typecheck/Inst.hs19
-rw-r--r--compiler/typecheck/TcBinds.hs2
-rw-r--r--compiler/typecheck/TcClassDcl.hs73
-rw-r--r--compiler/typecheck/TcDeriv.hs67
-rw-r--r--compiler/typecheck/TcEnv.hs2
-rw-r--r--compiler/typecheck/TcErrors.hs101
-rw-r--r--compiler/typecheck/TcGenDeriv.hs38
-rw-r--r--compiler/typecheck/TcGenGenerics.hs159
-rw-r--r--compiler/typecheck/TcInstDcls.hs62
-rw-r--r--compiler/typecheck/TcMatches.hs2
-rw-r--r--compiler/typecheck/TcPatSyn.hs2
-rw-r--r--compiler/typecheck/TcRnDriver.hs16
-rw-r--r--compiler/typecheck/TcRnMonad.hs2
-rw-r--r--compiler/typecheck/TcRnTypes.hs21
-rw-r--r--compiler/typecheck/TcSimplify.hs147
-rw-r--r--compiler/typecheck/TcSplice.hs14
-rw-r--r--compiler/typecheck/TcType.hs29
-rw-r--r--compiler/typecheck/TcUnify.hs4
-rw-r--r--compiler/types/InstEnv.hs4
-rw-r--r--compiler/utils/Outputable.hs6
-rw-r--r--compiler/utils/Panic.hs16
115 files changed, 2093 insertions, 2194 deletions
diff --git a/compiler/backpack/ShPackageKey.hs b/compiler/backpack/ShPackageKey.hs
deleted file mode 100644
index f0d7c6575c..0000000000
--- a/compiler/backpack/ShPackageKey.hs
+++ /dev/null
@@ -1,241 +0,0 @@
-{-# LANGUAGE CPP #-}
-module ShPackageKey(
- ShFreeHoles,
- calcModuleFreeHoles,
-
- newPackageKey,
- newPackageKeyWithScope,
- lookupPackageKey,
-
- generalizeHoleModule,
- canonicalizeModule,
-
- pprPackageKey
-) where
-
-#include "HsVersions.h"
-
-import Module
-import Packages
-import Encoding
-import FastString
-import UniqFM
-import UniqSet
-import Outputable
-import Util
-import DynFlags
-
-import System.IO.Unsafe ( unsafePerformIO )
-import Control.Monad
-import Data.IORef
-import GHC.Fingerprint
-import Data.List
-import Data.Function
-
--- NB: didn't put this in Module, that seems a bit too low in the
--- hierarchy, need to refer to DynFlags
-
-{-
-************************************************************************
-* *
- Package Keys
-* *
-************************************************************************
--}
-
--- Note: [PackageKey cache]
--- ~~~~~~~~~~~~~~~~~~~~~~~~
--- The built-in PackageKey type (used by Module, Name, etc)
--- records the instantiation of the package as an MD5 hash
--- which is not reversible without some extra information.
--- However, the shape merging process requires us to be able
--- to substitute Module occurrences /inside/ the package key.
---
--- Thus, we maintain the invariant: for every PackageKey
--- in our system, either:
---
--- 1. It is in the installed package database (lookupPackage)
--- so we can lookup the recorded instantiatedWith
--- 2. We've recorded the associated mapping in the
--- PackageKeyCache.
---
--- A PackageKey can be expanded into a ShPackageKey which has
--- the instance mapping. In the mapping, we don't bother
--- expanding a 'Module'; depending on 'shPackageKeyFreeHoles',
--- it may not be necessary to do a substitution (you only
--- need to drill down when substituing HOLE:H if H is in scope.
-
--- Note: [Module name in scope set]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Similar to InScopeSet, ShFreeHoles is an optimization that
--- allows us to avoid expanding a PackageKey into an ShPackageKey
--- if there isn't actually anything in the module expression that
--- we can substitute.
-
--- | Given a Name or Module, the 'ShFreeHoles' contains the set
--- of free variables, i.e. HOLE:A modules, which may be substituted.
--- If this set is empty no substitutions are possible.
-type ShFreeHoles = UniqSet ModuleName
-
--- | Calculate the free holes of a 'Module'.
-calcModuleFreeHoles :: DynFlags -> Module -> IO ShFreeHoles
-calcModuleFreeHoles dflags m
- | modulePackageKey m == holePackageKey = return (unitUniqSet (moduleName m))
- | otherwise = do
- shpk <- lookupPackageKey dflags (modulePackageKey m)
- return $ case shpk of
- ShDefinitePackageKey{} -> emptyUniqSet
- ShPackageKey{ shPackageKeyFreeHoles = in_scope } -> in_scope
-
--- | Calculate the free holes of the hole map @[('ModuleName', 'Module')]@.
-calcInstsFreeHoles :: DynFlags -> [(ModuleName, Module)] -> IO ShFreeHoles
-calcInstsFreeHoles dflags insts =
- fmap unionManyUniqSets (mapM (calcModuleFreeHoles dflags . snd) insts)
-
--- | Given a 'UnitName', a 'LibraryName', and sorted mapping of holes to
--- their implementations, compute the 'PackageKey' associated with it, as well
--- as the recursively computed 'ShFreeHoles' of holes that may be substituted.
-newPackageKeyWithScope :: DynFlags
- -> UnitName
- -> LibraryName
- -> [(ModuleName, Module)]
- -> IO (PackageKey, ShFreeHoles)
-newPackageKeyWithScope dflags pn vh insts = do
- fhs <- calcInstsFreeHoles dflags insts
- pk <- newPackageKey' dflags (ShPackageKey pn vh insts fhs)
- return (pk, fhs)
-
--- | Given a 'UnitName' and sorted mapping of holes to
--- their implementations, compute the 'PackageKey' associated with it.
--- (Analogous to 'newGlobalBinder').
-newPackageKey :: DynFlags
- -> UnitName
- -> LibraryName
- -> [(ModuleName, Module)]
- -> IO PackageKey
-newPackageKey dflags pn vh insts = do
- (pk, _) <- newPackageKeyWithScope dflags pn vh insts
- return pk
-
--- | Given a 'ShPackageKey', compute the 'PackageKey' associated with it.
--- This function doesn't calculate the 'ShFreeHoles', because it is
--- provided with 'ShPackageKey'.
-newPackageKey' :: DynFlags -> ShPackageKey -> IO PackageKey
-newPackageKey' _ (ShDefinitePackageKey pk) = return pk
-newPackageKey' dflags
- shpk@(ShPackageKey pn vh insts fhs) = do
- ASSERTM( fmap (==fhs) (calcInstsFreeHoles dflags insts) )
- let pk = mkPackageKey pn vh insts
- pkt_var = pkgKeyCache dflags
- pk_cache <- readIORef pkt_var
- let consistent pk_cache = maybe True (==shpk) (lookupUFM pk_cache pk)
- MASSERT( consistent pk_cache )
- when (not (elemUFM pk pk_cache)) $
- atomicModifyIORef' pkt_var (\pk_cache ->
- -- Could race, but it's guaranteed to be the same
- ASSERT( consistent pk_cache ) (addToUFM pk_cache pk shpk, ()))
- return pk
-
--- | Given a 'PackageKey', reverse lookup the 'ShPackageKey' associated
--- with it. This only gives useful information for keys which are
--- created using 'newPackageKey' or the associated functions, or that are
--- already in the installed package database, since we generally cannot reverse
--- MD5 hashes.
-lookupPackageKey :: DynFlags
- -> PackageKey
- -> IO ShPackageKey
-lookupPackageKey dflags pk
- | pk `elem` wiredInPackageKeys
- || pk == mainPackageKey
- || pk == holePackageKey
- = return (ShDefinitePackageKey pk)
- | otherwise = do
- let pkt_var = pkgKeyCache dflags
- pk_cache <- readIORef pkt_var
- case lookupUFM pk_cache pk of
- Just r -> return r
- _ -> return (ShDefinitePackageKey pk)
-
-pprPackageKey :: PackageKey -> SDoc
-pprPackageKey pk = sdocWithDynFlags $ \dflags ->
- -- name cache is a memotable
- let shpk = unsafePerformIO (lookupPackageKey dflags pk)
- in case shpk of
- shpk@ShPackageKey{} ->
- ppr (shPackageKeyUnitName shpk) <>
- parens (hsep
- (punctuate comma [ ppUnless (moduleName m == modname)
- (ppr modname <+> text "->")
- <+> ppr m
- | (modname, m) <- shPackageKeyInsts shpk]))
- <> ifPprDebug (braces (ftext (packageKeyFS pk)))
- ShDefinitePackageKey pk -> ftext (packageKeyFS pk)
-
--- NB: newPackageKey and lookupPackageKey are mutually recursive; this
--- recursion is guaranteed to bottom out because you can't set up cycles
--- of PackageKeys.
-
-
-{-
-************************************************************************
-* *
- Package key hashing
-* *
-************************************************************************
--}
-
--- | Generates a 'PackageKey'. Don't call this directly; you probably
--- want to cache the result.
-mkPackageKey :: UnitName
- -> LibraryName
- -> [(ModuleName, Module)] -- hole instantiations
- -> PackageKey
-mkPackageKey (UnitName fsUnitName)
- (LibraryName fsLibraryName) unsorted_holes =
- -- NB: don't use concatFS here, it's not much of an improvement
- fingerprintPackageKey . fingerprintString $
- unpackFS fsUnitName ++ "\n" ++
- unpackFS fsLibraryName ++ "\n" ++
- concat [ moduleNameString m
- ++ " " ++ packageKeyString (modulePackageKey b)
- ++ ":" ++ moduleNameString (moduleName b) ++ "\n"
- | (m, b) <- sortBy (stableModuleNameCmp `on` fst) unsorted_holes]
-
--- | Generalize a 'Module' into one where all the holes are indefinite.
--- @p(A -> ...):C@ generalizes to @p(A -> HOLE:A):C@. Useful when
--- you need to figure out if you've already type-checked the generalized
--- version of this module, so you don't have to do the whole rigamarole.
-generalizeHoleModule :: DynFlags -> Module -> IO Module
-generalizeHoleModule dflags m = do
- pk <- generalizeHolePackageKey dflags (modulePackageKey m)
- return (mkModule pk (moduleName m))
-
--- | Generalize a 'PackageKey' into one where all the holes are indefinite.
--- @p(A -> q():A) generalizes to p(A -> HOLE:A)@.
-generalizeHolePackageKey :: DynFlags -> PackageKey -> IO PackageKey
-generalizeHolePackageKey dflags pk = do
- shpk <- lookupPackageKey dflags pk
- case shpk of
- ShDefinitePackageKey _ -> return pk
- ShPackageKey { shPackageKeyUnitName = pn,
- shPackageKeyLibraryName = vh,
- shPackageKeyInsts = insts0 }
- -> let insts = map (\(x, _) -> (x, mkModule holePackageKey x)) insts0
- in newPackageKey dflags pn vh insts
-
--- | Canonicalize a 'Module' so that it uniquely identifies a module.
--- For example, @p(A -> M):A@ canonicalizes to @M@. Useful for making
--- sure the interface you've loaded as the right @mi_module@.
-canonicalizeModule :: DynFlags -> Module -> IO Module
-canonicalizeModule dflags m = do
- let pk = modulePackageKey m
- shpk <- lookupPackageKey dflags pk
- return $ case shpk of
- ShPackageKey { shPackageKeyInsts = insts }
- | Just m' <- lookup (moduleName m) insts -> m'
- _ -> m
-
-fingerprintPackageKey :: Fingerprint -> PackageKey
-fingerprintPackageKey (Fingerprint a b)
- = stringToPackageKey (toBase62Padded a ++ toBase62Padded b)
- -- See Note [Base 62 encoding 128-bit integers]
diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs
index b4aaaa7dea..76bdaa0a80 100644
--- a/compiler/basicTypes/DataCon.hs
+++ b/compiler/basicTypes/DataCon.hs
@@ -1031,7 +1031,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 (packageKeyFS (modulePackageKey mod)) ++
+dataConIdentity dc = bytesFS (unitIdFS (moduleUnitId mod)) ++
fromIntegral (ord ':') : bytesFS (moduleNameFS (moduleName mod)) ++
fromIntegral (ord '.') : bytesFS (occNameFS (nameOccName name))
where name = dataConName dc
diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs
index 9dd6d12ec1..7b54baae15 100644
--- a/compiler/basicTypes/Id.hs
+++ b/compiler/basicTypes/Id.hs
@@ -573,17 +573,17 @@ setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id
-- See Note [Specialisations and RULES in IdInfo] in IdInfo.hs
-idSpecialisation :: Id -> SpecInfo
-idSpecialisation id = specInfo (idInfo id)
+idSpecialisation :: Id -> RuleInfo
+idSpecialisation id = ruleInfo (idInfo id)
idCoreRules :: Id -> [CoreRule]
-idCoreRules id = specInfoRules (idSpecialisation id)
+idCoreRules id = ruleInfoRules (idSpecialisation id)
idHasRules :: Id -> Bool
-idHasRules id = not (isEmptySpecInfo (idSpecialisation id))
+idHasRules id = not (isEmptyRuleInfo (idSpecialisation id))
-setIdSpecialisation :: Id -> SpecInfo -> Id
-setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
+setIdSpecialisation :: Id -> RuleInfo -> Id
+setIdSpecialisation id spec_info = modifyIdInfo (`setRuleInfo` spec_info) id
---------------------------------
-- CAF INFO
diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs
index 02910051a2..d8d0e7fcad 100644
--- a/compiler/basicTypes/IdInfo.hs
+++ b/compiler/basicTypes/IdInfo.hs
@@ -51,12 +51,12 @@ module IdInfo (
InsideLam, OneBranch,
insideLam, notInsideLam, oneBranch, notOneBranch,
- -- ** The SpecInfo type
- SpecInfo(..),
- emptySpecInfo,
- isEmptySpecInfo, specInfoFreeVars,
- specInfoRules, setSpecInfoHead,
- specInfo, setSpecInfo,
+ -- ** The RuleInfo type
+ RuleInfo(..),
+ emptyRuleInfo,
+ isEmptyRuleInfo, ruleInfoFreeVars,
+ ruleInfoRules, setRuleInfoHead,
+ ruleInfo, setRuleInfo,
-- ** The CAFInfo type
CafInfo(..),
@@ -83,7 +83,7 @@ import FastString
import Demand
-- infixl so you can say (id `set` a `set` b)
-infixl 1 `setSpecInfo`,
+infixl 1 `setRuleInfo`,
`setArityInfo`,
`setInlinePragInfo`,
`setUnfoldingInfo`,
@@ -195,7 +195,7 @@ pprIdDetails other = brackets (pp other)
data IdInfo
= IdInfo {
arityInfo :: !ArityInfo, -- ^ 'Id' arity
- specInfo :: SpecInfo, -- ^ Specialisations of the 'Id's function which exist
+ ruleInfo :: RuleInfo, -- ^ Specialisations of the 'Id's function which exist
-- See Note [Specialisations and RULES in IdInfo]
unfoldingInfo :: Unfolding, -- ^ The 'Id's unfolding
cafInfo :: CafInfo, -- ^ 'Id' CAF info
@@ -212,8 +212,8 @@ data IdInfo
-- Setters
-setSpecInfo :: IdInfo -> SpecInfo -> IdInfo
-setSpecInfo info sp = sp `seq` info { specInfo = sp }
+setRuleInfo :: IdInfo -> RuleInfo -> IdInfo
+setRuleInfo info sp = sp `seq` info { ruleInfo = sp }
setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo
setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }
setOccInfo :: IdInfo -> OccInfo -> IdInfo
@@ -255,7 +255,7 @@ vanillaIdInfo
= IdInfo {
cafInfo = vanillaCafInfo,
arityInfo = unknownArity,
- specInfo = emptySpecInfo,
+ ruleInfo = emptyRuleInfo,
unfoldingInfo = noUnfolding,
oneShotInfo = NoOneShotInfo,
inlinePragInfo = defaultInlinePragma,
@@ -333,13 +333,13 @@ pprStrictness sig = ppr sig
{-
************************************************************************
* *
- SpecInfo
+ RuleInfo
* *
************************************************************************
Note [Specialisations and RULES in IdInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Generally speaking, a GlobalIdshas an *empty* SpecInfo. All their
+Generally speaking, a GlobalIdshas an *empty* RuleInfo. All their
RULES are contained in the globally-built rule-base. In principle,
one could attach the to M.f the RULES for M.f that are defined in M.
But we don't do that for instance declarations and so we just treat
@@ -348,7 +348,7 @@ them all uniformly.
The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is
jsut for convenience really.
-However, LocalIds may have non-empty SpecInfo. We treat them
+However, LocalIds may have non-empty RuleInfo. We treat them
differently because:
a) they might be nested, in which case a global table won't work
b) the RULE might mention free variables, which we use to keep things alive
@@ -359,8 +359,8 @@ and put in the global list.
-- | Records the specializations of this 'Id' that we know about
-- in the form of rewrite 'CoreRule's that target them
-data SpecInfo
- = SpecInfo
+data RuleInfo
+ = RuleInfo
[CoreRule]
VarSet -- Locally-defined free vars of *both* LHS and RHS
-- of rules. I don't think it needs to include the
@@ -368,24 +368,24 @@ data SpecInfo
-- Note [Rule dependency info] in OccurAnal
-- | Assume that no specilizations exist: always safe
-emptySpecInfo :: SpecInfo
-emptySpecInfo = SpecInfo [] emptyVarSet
+emptyRuleInfo :: RuleInfo
+emptyRuleInfo = RuleInfo [] emptyVarSet
-isEmptySpecInfo :: SpecInfo -> Bool
-isEmptySpecInfo (SpecInfo rs _) = null rs
+isEmptyRuleInfo :: RuleInfo -> Bool
+isEmptyRuleInfo (RuleInfo rs _) = null rs
-- | Retrieve the locally-defined free variables of both the left and
-- right hand sides of the specialization rules
-specInfoFreeVars :: SpecInfo -> VarSet
-specInfoFreeVars (SpecInfo _ fvs) = fvs
+ruleInfoFreeVars :: RuleInfo -> VarSet
+ruleInfoFreeVars (RuleInfo _ fvs) = fvs
-specInfoRules :: SpecInfo -> [CoreRule]
-specInfoRules (SpecInfo rules _) = rules
+ruleInfoRules :: RuleInfo -> [CoreRule]
+ruleInfoRules (RuleInfo rules _) = rules
-- | Change the name of the function the rule is keyed on on all of the 'CoreRule's
-setSpecInfoHead :: Name -> SpecInfo -> SpecInfo
-setSpecInfoHead fn (SpecInfo rules fvs)
- = SpecInfo (map (setRuleIdName fn) rules) fvs
+setRuleInfoHead :: Name -> RuleInfo -> RuleInfo
+setRuleInfoHead fn (RuleInfo rules fvs)
+ = RuleInfo (map (setRuleIdName fn) rules) fvs
{-
************************************************************************
@@ -467,7 +467,7 @@ zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)})
zapFragileInfo :: IdInfo -> Maybe IdInfo
-- ^ Zap info that depends on free variables
zapFragileInfo info
- = Just (info `setSpecInfo` emptySpecInfo
+ = Just (info `setRuleInfo` emptyRuleInfo
`setUnfoldingInfo` noUnfolding
`setOccInfo` zapFragileOcc occ)
where
diff --git a/compiler/basicTypes/Lexeme.hs b/compiler/basicTypes/Lexeme.hs
index a2409614d1..2049e001bf 100644
--- a/compiler/basicTypes/Lexeme.hs
+++ b/compiler/basicTypes/Lexeme.hs
@@ -6,11 +6,11 @@
module Lexeme (
-- * Lexical characteristics of Haskell names
-
+
-- | Use these functions to figure what kind of name a 'FastString'
-- represents; these functions do /not/ check that the identifier
-- is valid.
-
+
isLexCon, isLexVar, isLexId, isLexSym,
isLexConId, isLexConSym, isLexVarId, isLexVarSym,
startsVarSym, startsVarId, startsConSym, startsConId,
@@ -33,6 +33,8 @@ import Util ((<||>))
import Data.Char
import qualified Data.Set as Set
+import GHC.Lexeme
+
{-
************************************************************************
@@ -86,22 +88,6 @@ isLexVarSym fs -- Infix identifiers e.g. "+"
(c:cs) -> startsVarSym c && all isVarSymChar cs
-- See Note [Classification of generated names]
--------------
-startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool
-startsVarSym c = startsVarSymASCII c || (ord c > 0x7f && isSymbol c) -- Infix Ids
-startsConSym c = c == ':' -- Infix data constructors
-startsVarId c = c == '_' || case generalCategory c of -- Ordinary Ids
- LowercaseLetter -> True
- OtherLetter -> True -- See #1103
- _ -> False
-startsConId c = isUpper c || c == '(' -- Ordinary type constructors and data constructors
-
-startsVarSymASCII :: Char -> Bool
-startsVarSymASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
-
-isVarSymChar :: Char -> Bool
-isVarSymChar c = c == ':' || startsVarSym c
-
{-
************************************************************************
@@ -113,7 +99,7 @@ isVarSymChar c = c == ':' || startsVarSym c
-}
----------------------
--- External interface
+-- External interface
----------------------
-- | Is this an acceptable variable name?
@@ -237,7 +223,7 @@ okSymChar c
ModifierSymbol -> True
OtherSymbol -> True
_ -> False
-
+
-- | All reserved identifiers. Taken from section 2.4 of the 2010 Report.
reservedIds :: Set.Set String
reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving"
diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index 6f812def6b..0fa0005462 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -295,7 +295,7 @@ mkDictSelId name clas
-- for why alwaysInlinePragma
| otherwise
- = base_info `setSpecInfo` mkSpecInfo [rule]
+ = base_info `setRuleInfo` mkRuleInfo [rule]
-- Add a magic BuiltinRule, but no unfolding
-- so that the rule is always available to fire.
-- See Note [ClassOp/DFun selection] in TcInstDcls
@@ -952,7 +952,7 @@ mkPrimOpId prim_op
id = mkGlobalId (PrimOpId prim_op) name ty info
info = noCafIdInfo
- `setSpecInfo` mkSpecInfo (maybeToList $ primOpRules name prim_op)
+ `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op)
`setArityInfo` arity
`setStrictnessInfo` strict_sig
`setInlinePragInfo` neverInlinePragma
@@ -1125,7 +1125,7 @@ seqId = pcMiscPrelId seqName ty info
where
info = noCafIdInfo `setInlinePragInfo` inline_prag
`setUnfoldingInfo` mkCompulsoryUnfolding rhs
- `setSpecInfo` mkSpecInfo [seq_cast_rule]
+ `setRuleInfo` mkRuleInfo [seq_cast_rule]
inline_prag = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter 0
-- Make 'seq' not inline-always, so that simpleOptExpr
diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs
index 7725633447..8015a254d0 100644
--- a/compiler/basicTypes/Module.hs
+++ b/compiler/basicTypes/Module.hs
@@ -25,32 +25,32 @@ module Module
mkModuleNameFS,
stableModuleNameCmp,
- -- * The PackageKey type
- PackageKey,
- fsToPackageKey,
- packageKeyFS,
- stringToPackageKey,
- packageKeyString,
- stablePackageKeyCmp,
-
- -- * Wired-in PackageKeys
+ -- * The UnitId type
+ UnitId,
+ fsToUnitId,
+ unitIdFS,
+ stringToUnitId,
+ unitIdString,
+ stableUnitIdCmp,
+
+ -- * Wired-in UnitIds
-- $wired_in_packages
- primPackageKey,
- integerPackageKey,
- basePackageKey,
- rtsPackageKey,
- thPackageKey,
- dphSeqPackageKey,
- dphParPackageKey,
- mainPackageKey,
- thisGhcPackageKey,
- holePackageKey, isHoleModule,
- interactivePackageKey, isInteractiveModule,
- wiredInPackageKeys,
+ primUnitId,
+ integerUnitId,
+ baseUnitId,
+ rtsUnitId,
+ thUnitId,
+ dphSeqUnitId,
+ dphParUnitId,
+ mainUnitId,
+ thisGhcUnitId,
+ holeUnitId, isHoleModule,
+ interactiveUnitId, isInteractiveModule,
+ wiredInUnitIds,
-- * The Module type
Module(Module),
- modulePackageKey, moduleName,
+ moduleUnitId, moduleName,
pprModule,
mkModule,
stableModuleCmp,
@@ -216,7 +216,7 @@ moduleNameString (ModuleName mod) = unpackFS mod
-- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal"
moduleStableString :: Module -> String
moduleStableString Module{..} =
- "$" ++ packageKeyString modulePackageKey ++ "$" ++ moduleNameString moduleName
+ "$" ++ unitIdString moduleUnitId ++ "$" ++ moduleNameString moduleName
mkModuleName :: String -> ModuleName
mkModuleName s = ModuleName (mkFastString s)
@@ -244,15 +244,15 @@ moduleNameColons = dots_to_colons . moduleNameString
************************************************************************
-}
--- | A Module is a pair of a 'PackageKey' and a 'ModuleName'.
+-- | A Module is a pair of a 'UnitId' and a 'ModuleName'.
data Module = Module {
- modulePackageKey :: !PackageKey, -- pkg-1.0
+ moduleUnitId :: !UnitId, -- pkg-1.0
moduleName :: !ModuleName -- A.B.C
}
deriving (Eq, Ord, Typeable)
instance Uniquable Module where
- getUnique (Module p n) = getUnique (packageKeyFS p `appendFS` moduleNameFS n)
+ getUnique (Module p n) = getUnique (unitIdFS p `appendFS` moduleNameFS n)
instance Outputable Module where
ppr = pprModule
@@ -272,25 +272,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 `stablePackageKeyCmp` p2) `thenCmp`
+ = (p1 `stableUnitIdCmp` p2) `thenCmp`
(n1 `stableModuleNameCmp` n2)
-mkModule :: PackageKey -> ModuleName -> Module
+mkModule :: UnitId -> ModuleName -> Module
mkModule = Module
pprModule :: Module -> SDoc
pprModule mod@(Module p n) =
pprPackagePrefix p mod <> pprModuleName n
-pprPackagePrefix :: PackageKey -> Module -> SDoc
+pprPackagePrefix :: UnitId -> Module -> SDoc
pprPackagePrefix p mod = getPprStyle doc
where
doc sty
| codeStyle sty =
- if p == mainPackageKey
+ if p == mainUnitId
then empty -- never qualify the main package in code
- else ztext (zEncodeFS (packageKeyFS p)) <> char '_'
- | qualModule sty mod = ppr (modulePackageKey mod) <> char ':'
+ else ztext (zEncodeFS (unitIdFS p)) <> char '_'
+ | qualModule sty mod = ppr (moduleUnitId mod) <> char ':'
-- the PrintUnqualified tells us which modules have to
-- be qualified with package names
| otherwise = empty
@@ -304,7 +304,7 @@ class HasModule m where
{-
************************************************************************
* *
-\subsection{PackageKey}
+\subsection{UnitId}
* *
************************************************************************
-}
@@ -313,56 +313,56 @@ class HasModule m where
-- 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 )
+newtype UnitId = PId FastString deriving( Eq, Typeable )
-- here to avoid module loops with PackageConfig
-instance Uniquable PackageKey where
- getUnique pid = getUnique (packageKeyFS pid)
+instance Uniquable UnitId where
+ getUnique pid = getUnique (unitIdFS pid)
-- Note: *not* a stable lexicographic ordering, a faster unique-based
-- ordering.
-instance Ord PackageKey where
+instance Ord UnitId where
nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2
-instance Data PackageKey where
+instance Data UnitId where
-- don't traverse?
- toConstr _ = abstractConstr "PackageKey"
+ toConstr _ = abstractConstr "UnitId"
gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNoRepType "PackageKey"
+ dataTypeOf _ = mkNoRepType "UnitId"
-stablePackageKeyCmp :: PackageKey -> PackageKey -> Ordering
+stableUnitIdCmp :: UnitId -> UnitId -> Ordering
-- ^ Compares package ids lexically, rather than by their 'Unique's
-stablePackageKeyCmp p1 p2 = packageKeyFS p1 `compare` packageKeyFS p2
+stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2
-instance Outputable PackageKey where
+instance Outputable UnitId where
ppr pk = getPprStyle $ \sty -> sdocWithDynFlags $ \dflags ->
- case packageKeyPackageIdString dflags pk of
- Nothing -> ftext (packageKeyFS pk)
+ case unitIdPackageIdString dflags pk of
+ Nothing -> ftext (unitIdFS pk)
Just pkg -> text pkg
-- Don't bother qualifying if it's wired in!
- <> (if qualPackage sty pk && not (pk `elem` wiredInPackageKeys)
- then char '@' <> ftext (packageKeyFS pk)
+ <> (if qualPackage sty pk && not (pk `elem` wiredInUnitIds)
+ then char '@' <> ftext (unitIdFS pk)
else empty)
-instance Binary PackageKey where
- put_ bh pid = put_ bh (packageKeyFS pid)
- get bh = do { fs <- get bh; return (fsToPackageKey fs) }
+instance Binary UnitId where
+ put_ bh pid = put_ bh (unitIdFS pid)
+ get bh = do { fs <- get bh; return (fsToUnitId fs) }
-instance BinaryStringRep PackageKey where
- fromStringRep = fsToPackageKey . mkFastStringByteString
- toStringRep = fastStringToByteString . packageKeyFS
+instance BinaryStringRep UnitId where
+ fromStringRep = fsToUnitId . mkFastStringByteString
+ toStringRep = fastStringToByteString . unitIdFS
-fsToPackageKey :: FastString -> PackageKey
-fsToPackageKey = PId
+fsToUnitId :: FastString -> UnitId
+fsToUnitId = PId
-packageKeyFS :: PackageKey -> FastString
-packageKeyFS (PId fs) = fs
+unitIdFS :: UnitId -> FastString
+unitIdFS (PId fs) = fs
-stringToPackageKey :: String -> PackageKey
-stringToPackageKey = fsToPackageKey . mkFastString
+stringToUnitId :: String -> UnitId
+stringToUnitId = fsToUnitId . mkFastString
-packageKeyString :: PackageKey -> String
-packageKeyString = unpackFS . packageKeyFS
+unitIdString :: UnitId -> String
+unitIdString = unpackFS . unitIdFS
-- -----------------------------------------------------------------------------
@@ -378,7 +378,7 @@ packageKeyString = unpackFS . packageKeyFS
-- 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 'PackageKey' below when referring to it,
+-- will use the unversioned 'UnitId' 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
@@ -386,49 +386,49 @@ packageKeyString = unpackFS . packageKeyFS
-- Make sure you change 'Packages.findWiredInPackages' if you add an entry here
-integerPackageKey, primPackageKey,
- basePackageKey, rtsPackageKey,
- thPackageKey, dphSeqPackageKey, dphParPackageKey,
- mainPackageKey, thisGhcPackageKey, interactivePackageKey :: PackageKey
-primPackageKey = fsToPackageKey (fsLit "ghc-prim")
-integerPackageKey = fsToPackageKey (fsLit n)
+integerUnitId, primUnitId,
+ baseUnitId, rtsUnitId,
+ thUnitId, dphSeqUnitId, dphParUnitId,
+ mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId
+primUnitId = fsToUnitId (fsLit "ghc-prim")
+integerUnitId = fsToUnitId (fsLit n)
where
n = case cIntegerLibraryType of
IntegerGMP -> "integer-gmp"
IntegerSimple -> "integer-simple"
-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")
+baseUnitId = fsToUnitId (fsLit "base")
+rtsUnitId = fsToUnitId (fsLit "rts")
+thUnitId = fsToUnitId (fsLit "template-haskell")
+dphSeqUnitId = fsToUnitId (fsLit "dph-seq")
+dphParUnitId = fsToUnitId (fsLit "dph-par")
+thisGhcUnitId = fsToUnitId (fsLit "ghc")
+interactiveUnitId = fsToUnitId (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.
-mainPackageKey = fsToPackageKey (fsLit "main")
+mainUnitId = fsToUnitId (fsLit "main")
-- | This is a fake package id used to provide identities to any un-implemented
-- signatures. The set of hole identities is global over an entire compilation.
-holePackageKey :: PackageKey
-holePackageKey = fsToPackageKey (fsLit "hole")
+holeUnitId :: UnitId
+holeUnitId = fsToUnitId (fsLit "hole")
isInteractiveModule :: Module -> Bool
-isInteractiveModule mod = modulePackageKey mod == interactivePackageKey
+isInteractiveModule mod = moduleUnitId mod == interactiveUnitId
isHoleModule :: Module -> Bool
-isHoleModule mod = modulePackageKey mod == holePackageKey
-
-wiredInPackageKeys :: [PackageKey]
-wiredInPackageKeys = [ primPackageKey,
- integerPackageKey,
- basePackageKey,
- rtsPackageKey,
- thPackageKey,
- thisGhcPackageKey,
- dphSeqPackageKey,
- dphParPackageKey ]
+isHoleModule mod = moduleUnitId mod == holeUnitId
+
+wiredInUnitIds :: [UnitId]
+wiredInUnitIds = [ primUnitId,
+ integerUnitId,
+ baseUnitId,
+ rtsUnitId,
+ thUnitId,
+ thisGhcUnitId,
+ dphSeqUnitId,
+ dphParUnitId ]
{-
************************************************************************
diff --git a/compiler/basicTypes/Module.hs-boot b/compiler/basicTypes/Module.hs-boot
index 8a73d38256..d8b7a61e11 100644
--- a/compiler/basicTypes/Module.hs-boot
+++ b/compiler/basicTypes/Module.hs-boot
@@ -2,7 +2,7 @@ module Module where
data Module
data ModuleName
-data PackageKey
+data UnitId
moduleName :: Module -> ModuleName
-modulePackageKey :: Module -> PackageKey
-packageKeyString :: PackageKey -> String
+moduleUnitId :: Module -> UnitId
+unitIdString :: UnitId -> String
diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs
index 46c23b91bf..c557889606 100644
--- a/compiler/basicTypes/Name.hs
+++ b/compiler/basicTypes/Name.hs
@@ -265,16 +265,16 @@ nameIsHomePackageImport this_mod
= \nm -> case nameModule_maybe nm of
Nothing -> False
Just nm_mod -> nm_mod /= this_mod
- && modulePackageKey nm_mod == this_pkg
+ && moduleUnitId nm_mod == this_pkg
where
- this_pkg = modulePackageKey this_mod
+ this_pkg = moduleUnitId this_mod
-- | Returns True if the Name comes from some other package: neither this
-- pacakge nor the interactive package.
-nameIsFromExternalPackage :: PackageKey -> Name -> Bool
+nameIsFromExternalPackage :: UnitId -> Name -> Bool
nameIsFromExternalPackage this_pkg name
| Just mod <- nameModule_maybe name
- , modulePackageKey mod /= this_pkg -- Not this package
+ , moduleUnitId mod /= this_pkg -- Not this package
, not (isInteractiveModule mod) -- Not the 'interactive' package
= True
| otherwise
@@ -557,7 +557,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 (modulePackageKey mod) <> colon -- Module not in
+ NameNotInScope2 -> ppr (moduleUnitId mod) <> colon -- Module not in
<> ppr (moduleName mod) <> dot -- scope either
NameUnqual -> empty -- In scope unqualified
diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs
index da0157193c..67942df518 100644
--- a/compiler/basicTypes/OccName.hs
+++ b/compiler/basicTypes/OccName.hs
@@ -617,12 +617,12 @@ mkMaxTagOcc = mk_simple_deriv varName "$maxtag_"
-- Generic deriving mechanism
-- | Generate a module-unique name, to be used e.g. while generating new names
--- for Generics types. We use module package key to avoid name clashes when
+-- for Generics types. We use module unit id to avoid name clashes when
-- package imports is used.
mkModPrefix :: Module -> String
mkModPrefix mod = pk ++ "_" ++ mn
where
- pk = packageKeyString (modulePackageKey mod)
+ pk = unitIdString (moduleUnitId mod)
mn = moduleNameString (moduleName mod)
mkGenD :: Module -> OccName -> OccName
diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs
index 081968aabd..503ebd87a4 100644
--- a/compiler/basicTypes/PatSyn.hs
+++ b/compiler/basicTypes/PatSyn.hs
@@ -13,7 +13,7 @@ module PatSyn (
-- ** Type deconstruction
patSynName, patSynArity, patSynIsInfix,
- patSynArgs, patSynTyDetails, patSynType,
+ patSynArgs, patSynType,
patSynMatcher, patSynBuilder,
patSynExTyVars, patSynSig,
patSynInstArgTys, patSynInstResTy,
@@ -31,7 +31,6 @@ import Util
import BasicTypes
import FastString
import Var
-import HsBinds( HsPatSynDetails(..) )
import qualified Data.Data as Data
import qualified Data.Typeable
@@ -286,13 +285,6 @@ patSynArity = psArity
patSynArgs :: PatSyn -> [Type]
patSynArgs = psArgs
-patSynTyDetails :: PatSyn -> HsPatSynDetails Type
-patSynTyDetails (MkPatSyn { psInfix = is_infix, psArgs = arg_tys })
- | is_infix, [left,right] <- arg_tys
- = InfixPatSyn left right
- | otherwise
- = PrefixPatSyn arg_tys
-
patSynExTyVars :: PatSyn -> [TyVar]
patSynExTyVars = psExTyVars
diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs
index 1430f38fb1..6917feafce 100644
--- a/compiler/basicTypes/RdrName.hs
+++ b/compiler/basicTypes/RdrName.hs
@@ -944,7 +944,7 @@ data ImpDeclSpec
-- the defining module for this thing!
-- TODO: either should be Module, or there
- -- should be a Maybe PackageKey here too.
+ -- should be a Maybe UnitId 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 826d1f8c7a..0f1d61bada 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -161,14 +161,14 @@ data CLabel
-- | A label from a .cmm file that is not associated with a .hs level Id.
| CmmLabel
- PackageKey -- what package the label belongs to.
+ UnitId -- 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 PackageKey argument.
+ -- instead and give it an appropriate UnitId argument.
| RtsLabel
RtsLabelInfo
@@ -244,7 +244,7 @@ data CLabel
data ForeignLabelSource
-- | Label is in a named package
- = ForeignLabelInPackage PackageKey
+ = ForeignLabelInPackage UnitId
-- | Label is in some external, system package that doesn't also
-- contain compiled Haskell code, and is not associated with any .hi files.
@@ -418,27 +418,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 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
+mkSplitMarkerLabel = CmmLabel rtsUnitId (fsLit "__stg_split_marker") CmmCode
+mkUpdInfoLabel = CmmLabel rtsUnitId (fsLit "stg_upd_frame") CmmInfo
+mkBHUpdInfoLabel = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" ) CmmInfo
+mkIndStaticInfoLabel = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC") CmmInfo
+mkMainCapabilityLabel = CmmLabel rtsUnitId (fsLit "MainCapability") CmmData
+mkMAP_FROZEN_infoLabel = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN") CmmInfo
+mkMAP_FROZEN0_infoLabel = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN0") CmmInfo
+mkMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo
+mkEMPTY_MVAR_infoLabel = CmmLabel rtsUnitId (fsLit "stg_EMPTY_MVAR") CmmInfo
+mkTopTickyCtrLabel = CmmLabel rtsUnitId (fsLit "top_ct") CmmData
+mkCAFBlackHoleInfoTableLabel = CmmLabel rtsUnitId (fsLit "stg_CAF_BLACKHOLE") CmmInfo
+mkCAFBlackHoleEntryLabel = CmmLabel rtsUnitId (fsLit "stg_CAF_BLACKHOLE") CmmEntry
+mkArrWords_infoLabel = CmmLabel rtsUnitId (fsLit "stg_ARR_WORDS") CmmInfo
+mkSMAP_FROZEN_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN") CmmInfo
+mkSMAP_FROZEN0_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN0") CmmInfo
+mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
-----
mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
mkCmmCodeLabel, mkCmmDataLabel, mkCmmClosureLabel
- :: PackageKey -> FastString -> CLabel
+ :: UnitId -> FastString -> CLabel
mkCmmInfoLabel pkg str = CmmLabel pkg str CmmInfo
mkCmmEntryLabel pkg str = CmmLabel pkg str CmmEntry
@@ -652,7 +652,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 == rtsPackageKey = False
+ | pkgId == rtsUnitId = False
-- For other labels we inline one into the HC file directly.
| otherwise = True
@@ -858,11 +858,11 @@ idInfoLabelType info =
-- @labelDynamic@ returns @True@ if the label is located
-- in a DLL, be it a data reference or not.
-labelDynamic :: DynFlags -> PackageKey -> Module -> CLabel -> Bool
+labelDynamic :: DynFlags -> UnitId -> 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 /= rtsPackageKey)
+ RtsLabel _ -> not (gopt Opt_Static dflags) && (this_pkg /= rtsUnitId)
IdLabel n _ _ -> isDllName dflags this_pkg this_mod n
@@ -895,7 +895,7 @@ labelDynamic dflags this_pkg this_mod lbl =
-- libraries
True
- PlainModuleInitLabel m -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageKey m)
+ PlainModuleInitLabel m -> not (gopt Opt_Static dflags) && this_pkg /= (moduleUnitId m)
HpcTicksLabel m -> not (gopt Opt_Static dflags) && this_mod /= m
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index dbd5d06872..000f805b5d 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -574,7 +574,7 @@ importName
-- A label imported with an explicit packageId.
| STRING NAME
- { ($2, mkCmmCodeLabel (fsToPackageKey (mkFastString $1)) $2) }
+ { ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) }
names :: { [FastString] }
@@ -1119,7 +1119,7 @@ profilingInfo dflags desc_str ty_str
else ProfilingInfo (stringToWord8s desc_str)
(stringToWord8s ty_str)
-staticClosure :: PackageKey -> FastString -> FastString -> [CmmLit] -> CmmParse ()
+staticClosure :: UnitId -> 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/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index edd064848f..745dd720eb 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 rtsPackageKey (fsLit "stg_INTLIKE")
+ = do { let intlike_lbl = mkCmmClosureLabel rtsUnitId (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 rtsPackageKey (fsLit "stg_CHARLIKE")
+ = do { let charlike_lbl = mkCmmClosureLabel rtsUnitId (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 03f6a47d87..2091d9b358 100644
--- a/compiler/codeGen/StgCmmExtCode.hs
+++ b/compiler/codeGen/StgCmmExtCode.hs
@@ -63,7 +63,7 @@ data Named
= VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,
-- eg, RtsLabel, ForeignLabel, CmmLabel etc.
- | FunN PackageKey -- ^ A function name from this package
+ | FunN UnitId -- ^ A function name from this package
| LabelN BlockId -- ^ A blockid of some code or data.
-- | An environment of named things.
@@ -167,7 +167,7 @@ newBlockId = code F.newLabelC
-- | Add add a local function to the environment.
newFunctionName
:: FastString -- ^ name of the function
- -> PackageKey -- ^ package of the current module
+ -> UnitId -- ^ package of the current module
-> ExtCode
newFunctionName name pkg = addDecl name (FunN pkg)
@@ -207,7 +207,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 rtsPackageKey name))
+ _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name))
-- | Lift an FCode computation into the CmmParse monad
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 6aaa10083e..bcc5221275 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -523,7 +523,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 rtsPackageKey (fsLit s)))
+mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit s)))
-------------------------------
heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 593dd6cc18..03c11cc19b 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -366,10 +366,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 rtsPackageKey arg_pat
+ stg_ap_pat = mkCmmRetInfoLabel rtsUnitId 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 rtsPackageKey (fsLit "stg_restore_cccs")
+ save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (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 1acf31b327..3d055e75bb 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -498,7 +498,7 @@ withSelfLoop self_loop code = do
instance HasDynFlags FCode where
getDynFlags = liftM cgd_dflags getInfoDown
-getThisPackage :: FCode PackageKey
+getThisPackage :: FCode UnitId
getThisPackage = liftM thisPackage getDynFlags
withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs
index 7249477c9f..a7384c725b 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 rtsPackageKey (fsLit "enterFunCCS")
+ emitRtsCall rtsUnitId (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
- rtsPackageKey
+ rtsUnitId
(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 rtsPackageKey (fsLit "era")))
+ [CmmLoad (mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "era")))
(cInt dflags)]
ldvWord :: DynFlags -> CmmExpr -> CmmExpr
diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
index 3652a79979..03a936fad0 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 rtsPackageKey (fsLit "ticky_entry_ctrs"))
+ ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (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 rtsPackageKey (fsLit "ALLOC_HEAP_tot"))
+ (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))
bytes,
-- Bump the global allocation counter ALLOC_HEAP_ctr
if not genuine then mkNop
else addToMemLbl (cLong dflags)
- (mkCmmDataLabel rtsPackageKey (fsLit "ALLOC_HEAP_ctr"))
+ (mkCmmDataLabel rtsUnitId (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 rtsPackageKey lbl)
+bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsUnitId lbl)
bumpTickyCounterBy :: FastString -> Int -> FCode ()
-bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsPackageKey lbl)
+bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsUnitId lbl)
bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()
-bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsPackageKey lbl)
+bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsUnitId lbl)
bumpTickyEntryCount :: CLabel -> FCode ()
bumpTickyEntryCount lbl = do
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index a03625262c..ccfab85a5a 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -167,10 +167,10 @@ tagToClosure dflags tycon tag
--
-------------------------------------------------------------------------
-emitRtsCall :: PackageKey -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
+emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe
-emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageKey -> FastString
+emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> 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/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs
index f5f58dc442..0e5027768a 100644
--- a/compiler/coreSyn/CoreFVs.hs
+++ b/compiler/coreSyn/CoreFVs.hs
@@ -24,7 +24,7 @@ module CoreFVs (
idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
- ruleLhsOrphNames, ruleLhsFreeIds, exprsOrphNames,
+ ruleLhsFreeIds, exprsOrphNames,
vectsFreeVars,
-- * Core syntax tree annotation with free variables
@@ -215,21 +215,6 @@ tickish_fvs _ = noVars
************************************************************************
-}
--- | ruleLhsOrphNames is used when deciding whether
--- a rule is an orphan. In particular, suppose that T is defined in this
--- module; we want to avoid declaring that a rule like:
---
--- > fromIntegral T = fromIntegral_T
---
--- is an orphan. Of course it isn't, and declaring it an orphan would
--- make the whole module an orphan module, which is bad.
-ruleLhsOrphNames :: CoreRule -> NameSet
-ruleLhsOrphNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn
-ruleLhsOrphNames (Rule { ru_fn = fn, ru_args = tpl_args })
- = extendNameSet (exprsOrphNames tpl_args) fn
- -- No need to delete bndrs, because
- -- exprsOrphNames finds only External names
-
-- | Finds the free /external/ names of an expression, notably
-- including the names of type constructors (which of course do not show
-- up in 'exprFreeVars').
@@ -423,7 +408,7 @@ idRuleAndUnfoldingVars id = ASSERT( isId id)
idUnfoldingVars id
idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars
-idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
+idRuleVars id = ASSERT( isId id) ruleInfoFreeVars (idSpecialisation id)
idUnfoldingVars :: Id -> VarSet
-- Produce free vars for an unfolding, but NOT for an ordinary
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 0b72ff4db2..ea1d9689b7 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -32,6 +32,7 @@ import Literal
import DataCon
import TysWiredIn
import TysPrim
+import TcType ( isFloatingTy )
import Var
import VarEnv
import VarSet
@@ -662,6 +663,15 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
(ptext (sLit "No alternatives for a case scrutinee not known to diverge for sure:") <+> ppr scrut)
}
+ -- See Note [Rules for floating-point comparisons] in PrelRules
+ ; let isLitPat (LitAlt _, _ , _) = True
+ isLitPat _ = False
+ ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts)
+ (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++
+ "expression with literal pattern in case " ++
+ "analysis (see Trac #9238).")
+ $$ text "scrut" <+> ppr scrut)
+
; case tyConAppTyCon_maybe (idType var) of
Just tycon
| debugIsOn &&
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index 7b256a4012..23afcdfb04 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -1168,9 +1168,9 @@ lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of
-- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName'
guardIntegerUse :: DynFlags -> IO a -> IO a
guardIntegerUse dflags act
- | thisPackage dflags == primPackageKey
+ | thisPackage dflags == primUnitId
= return $ panic "Can't use Integer in ghc-prim"
- | thisPackage dflags == integerPackageKey
+ | thisPackage dflags == integerUnitId
= return $ panic "Can't use Integer in integer-*"
| otherwise = act
@@ -1218,7 +1218,7 @@ cpCloneBndr env bndr
-- so that we can drop more stuff as dead code.
-- See also Note [Dead code in CorePrep]
let bndr'' = bndr' `setIdUnfolding` noUnfolding
- `setIdSpecialisation` emptySpecInfo
+ `setIdSpecialisation` emptyRuleInfo
return (extendCorePrepEnv env bndr bndr'', bndr'')
| otherwise -- Top level things, which we don't want
diff --git a/compiler/coreSyn/CoreSeq.hs b/compiler/coreSyn/CoreSeq.hs
index 9bd3f458b6..e3c7844f2e 100644
--- a/compiler/coreSyn/CoreSeq.hs
+++ b/compiler/coreSyn/CoreSeq.hs
@@ -7,7 +7,7 @@
module CoreSeq (
-- * Utilities for forcing Core structures
seqExpr, seqExprs, seqUnfolding, seqRules,
- megaSeqIdInfo, seqSpecInfo, seqBinds,
+ megaSeqIdInfo, seqRuleInfo, seqBinds,
) where
import CoreSyn
@@ -24,7 +24,7 @@ import Id( Id, idInfo )
-- compiler
megaSeqIdInfo :: IdInfo -> ()
megaSeqIdInfo info
- = seqSpecInfo (specInfo info) `seq`
+ = seqRuleInfo (ruleInfo info) `seq`
-- Omitting this improves runtimes a little, presumably because
-- some unfoldings are not calculated at all
@@ -39,8 +39,8 @@ megaSeqIdInfo info
seqOneShot :: OneShotInfo -> ()
seqOneShot l = l `seq` ()
-seqSpecInfo :: SpecInfo -> ()
-seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs
+seqRuleInfo :: RuleInfo -> ()
+seqRuleInfo (RuleInfo rules fvs) = seqRules rules `seq` seqVarSet fvs
seqCaf :: CafInfo -> ()
seqCaf c = c `seq` ()
diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs
index e78ff70888..c1de2051ee 100644
--- a/compiler/coreSyn/CoreSubst.hs
+++ b/compiler/coreSyn/CoreSubst.hs
@@ -623,12 +623,12 @@ substIdType subst@(Subst _ _ tv_env cv_env) id
substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo
substIdInfo subst new_id info
| nothing_to_do = Nothing
- | otherwise = Just (info `setSpecInfo` substSpec subst new_id old_rules
+ | otherwise = Just (info `setRuleInfo` substSpec subst new_id old_rules
`setUnfoldingInfo` substUnfolding subst old_unf)
where
- old_rules = specInfo info
+ old_rules = ruleInfo info
old_unf = unfoldingInfo info
- nothing_to_do = isEmptySpecInfo old_rules && isClosedUnfolding old_unf
+ nothing_to_do = isEmptyRuleInfo old_rules && isClosedUnfolding old_unf
------------------
@@ -668,12 +668,12 @@ substIdOcc subst v = case lookupIdSubst (text "substIdOcc") subst v of
------------------
-- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id'
-substSpec :: Subst -> Id -> SpecInfo -> SpecInfo
-substSpec subst new_id (SpecInfo rules rhs_fvs)
- = seqSpecInfo new_spec `seq` new_spec
+substSpec :: Subst -> Id -> RuleInfo -> RuleInfo
+substSpec subst new_id (RuleInfo rules rhs_fvs)
+ = seqRuleInfo new_spec `seq` new_spec
where
subst_ru_fn = const (idName new_id)
- new_spec = SpecInfo (map (substRule subst subst_ru_fn) rules)
+ new_spec = RuleInfo (map (substRule subst subst_ru_fn) rules)
(substVarSet subst rhs_fvs)
------------------
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index fedf1d73ec..24ce641039 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -233,6 +233,10 @@ These data types are the heart of the compiler
-- The inner case does not need a @Red@ alternative, because @x@
-- can't be @Red@ at that program point.
--
+-- 5. Floating-point values must not be scrutinised against literals.
+-- See Trac #9238 and Note [Rules for floating-point comparisons]
+-- in PrelRules for rationale.
+--
-- * Cast an expression to a particular type.
-- This is used to implement @newtype@s (a @newtype@ constructor or
-- destructor just becomes a 'Cast' in Core) and GADTs.
@@ -329,6 +333,9 @@ simplifier calling findAlt with argument (LitAlt 3). No no. Integer
literals are an opaque encoding of an algebraic data type, not of
an unlifted literal, like all the others.
+Also, we do not permit case analysis with literal patterns on floating-point
+types. See Trac #9238 and Note [Rules for floating-point comparisons] in
+PrelRules for the rationale for this restriction.
-------------------------- CoreSyn INVARIANTS ---------------------------
diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs
index b04c13d886..edbe503fc4 100644
--- a/compiler/coreSyn/CoreUnfold.hs
+++ b/compiler/coreSyn/CoreUnfold.hs
@@ -1239,7 +1239,7 @@ CONLIKE thing (modulo lets).
Note [Lone variables] See also Note [Interaction of exprIsWorkFree and lone variables]
~~~~~~~~~~~~~~~~~~~~~ which appears below
The "lone-variable" case is important. I spent ages messing about
-with unsatisfactory varaints, but this is nice. The idea is that if a
+with unsatisfactory variants, but this is nice. The idea is that if a
variable appears all alone
as an arg of lazy fn, or rhs BoringCtxt
diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs
index 2ae1577bd0..eb5e595925 100644
--- a/compiler/coreSyn/PprCore.hs
+++ b/compiler/coreSyn/PprCore.hs
@@ -418,7 +418,7 @@ ppIdInfo id info
unf_info = unfoldingInfo info
has_unf = hasSomeUnfolding unf_info
- rules = specInfoRules (specInfo info)
+ rules = ruleInfoRules (ruleInfo info)
showAttributes :: [(Bool,SDoc)] -> SDoc
showAttributes stuff
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index 041a6fe344..b9ef0f1c03 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -153,8 +153,8 @@ writeMixEntries dflags mod count entries filename
mod_name = moduleNameString (moduleName mod)
hpc_mod_dir
- | modulePackageKey mod == mainPackageKey = hpc_dir
- | otherwise = hpc_dir ++ "/" ++ packageKeyString (modulePackageKey mod)
+ | moduleUnitId mod == mainUnitId = hpc_dir
+ | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod)
tabStop = 8 -- <tab> counts as a normal char in GHC's location ranges.
@@ -1287,9 +1287,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 (packageKeyFS (modulePackageKey this_mod)))
+ bytesFS (unitIdFS (moduleUnitId this_mod)))
full_name_str
- | modulePackageKey this_mod == mainPackageKey
+ | moduleUnitId this_mod == mainUnitId
= module_name
| otherwise
= package_name <> char '/' <> module_name
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index 1508922423..dceebc1fcd 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -381,12 +381,12 @@ dsRule (L loc (HsRule name rule_act vars lhs _tv_lhs rhs _fv_rhs))
fn_name = idName fn_id
final_rhs = simpleOptExpr rhs'' -- De-crap it
rule_name = snd (unLoc name)
- rule = mkRule this_mod False {- Not auto -} is_local
- rule_name rule_act fn_name final_bndrs args
- final_rhs
arg_ids = varSetElems (exprsSomeFreeVars isId args `delVarSetList` final_bndrs)
; dflags <- getDynFlags
+ ; rule <- dsMkUserRule this_mod is_local
+ rule_name rule_act fn_name final_bndrs args
+ final_rhs
; when (wopt Opt_WarnInlineRuleShadowing dflags) $
warnRuleShadowing rule_name rule_act fn_id arg_ids
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 28e866d8e9..4fa09cb42a 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -13,7 +13,7 @@ lower levels it is preserved with @let@/@letrec@s).
{-# LANGUAGE CPP #-}
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
- dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds
+ dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule
) where
#include "HsVersions.h"
@@ -69,7 +69,7 @@ import DynFlags
import FastString
import Util
import MonadUtils
-import Control.Monad(liftM)
+import Control.Monad(liftM,when)
import Fingerprint(Fingerprint(..), fingerprintString)
{-
@@ -450,7 +450,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
spec_id = mkLocalId spec_name spec_ty
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
- rule = mkRule this_mod False {- Not auto -} is_local_id
+ ; rule <- dsMkUserRule this_mod is_local_id
(mkFastString ("SPEC " ++ showPpr dflags poly_name))
rule_act poly_name
rule_bndrs args
@@ -503,6 +503,17 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
| otherwise = spec_prag_act -- Specified by user
+dsMkUserRule :: Module -> Bool -> RuleName -> Activation
+ -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule
+dsMkUserRule this_mod is_local name act fn bndrs args rhs = do
+ let rule = mkRule this_mod False is_local name act fn bndrs args rhs
+ dflags <- getDynFlags
+ when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $
+ warnDs (ruleOrphWarn rule)
+ return rule
+
+ruleOrphWarn :: CoreRule -> SDoc
+ruleOrphWarn rule = ptext (sLit "Orphan rule:") <+> ppr rule
{- Note [SPECIALISE on INLINE functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -969,10 +980,10 @@ dsEvTypeable ev =
where
tycon_name = tyConName tc
modl = nameModule tycon_name
- pkg = modulePackageKey modl
+ pkg = moduleUnitId modl
modl_fs = moduleNameFS (moduleName modl)
- pkg_fs = packageKeyFS pkg
+ pkg_fs = unitIdFS pkg
name_fs = occNameFS (nameOccName tycon_name)
hash_name_fs
| isPromotedTyCon tc = appendFS (mkFastString "$k") name_fs
@@ -1014,7 +1025,7 @@ dsEvCallStack cs = do
let srcLocTy = mkTyConTy srcLocTyCon
let mkSrcLoc l =
liftM (mkCoreConApps srcLocDataCon)
- (sequence [ mkStringExpr (showPpr df $ modulePackageKey m)
+ (sequence [ mkStringExpr (showPpr df $ moduleUnitId m)
, mkStringExprFS (moduleNameFS $ moduleName m)
, mkStringExprFS (srcSpanFile l)
, return $ mkIntExprInt df (srcSpanStartLine l)
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 9e82c711da..d91ccfbc6c 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -436,7 +436,7 @@ dsExpr (HsStatic expr@(L loc _)) = do
info <- mkConApp staticPtrInfoDataCon <$>
(++[srcLoc]) <$>
mapM mkStringExprFS
- [ packageKeyFS $ modulePackageKey $ nameModule n'
+ [ unitIdFS $ moduleUnitId $ nameModule n'
, moduleNameFS $ moduleName $ nameModule n'
, occNameFS $ nameOccName n'
]
@@ -462,7 +462,7 @@ dsExpr (HsStatic expr@(L loc _)) = do
fingerprintName :: Name -> Fingerprint
fingerprintName n = fingerprintString $ unpackFS $ concatFS
- [ packageKeyFS $ modulePackageKey $ nameModule n
+ [ unitIdFS $ moduleUnitId $ nameModule n
, fsLit ":"
, moduleNameFS (moduleName $ nameModule n)
, fsLit "."
diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs
index 7c6e62cda1..acea47c57b 100644
--- a/compiler/deSugar/DsForeign.hs
+++ b/compiler/deSugar/DsForeign.hs
@@ -223,12 +223,12 @@ dsFCall fn_id co fcall mDeclHeader = do
dflags <- getDynFlags
(fcall', cDoc) <-
case fcall of
- CCall (CCallSpec (StaticTarget _ cName mPackageKey isFun)
+ CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)
CApiConv safety) ->
do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)
let fcall' = CCall (CCallSpec
(StaticTarget (unpackFS wrapperName)
- wrapperName mPackageKey
+ wrapperName mUnitId
True)
CApiConv safety)
c = includes
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 760d903d51..4c060de29f 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1581,7 +1581,7 @@ globalVar name
where
mod = ASSERT( isExternalName name) nameModule name
name_mod = moduleNameString (moduleName mod)
- name_pkg = packageKeyString (modulePackageKey mod)
+ name_pkg = unitIdString (moduleUnitId mod)
name_occ = nameOccName name
mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
| OccName.isVarOcc name_occ = mkNameG_vName
diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs
index 25021f56c5..4e6b8aac53 100644
--- a/compiler/deSugar/MatchLit.hs
+++ b/compiler/deSugar/MatchLit.hs
@@ -228,6 +228,7 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
else if tc == word16TyConName then check (undefined :: Word16)
else if tc == word32TyConName then check (undefined :: Word32)
else if tc == word64TyConName then check (undefined :: Word64)
+ else if tc == integerTyConName then check (undefined :: Integer)
else return ()
| otherwise = return ()
@@ -295,10 +296,12 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
= mk_con_pat intDataCon (HsIntPrim "" int_lit)
| isWordTy ty, Just int_lit <- mb_int_lit
= mk_con_pat wordDataCon (HsWordPrim "" int_lit)
- | isFloatTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon (HsFloatPrim rat_lit)
- | isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit)
| isStringTy ty, Just str_lit <- mb_str_lit
= tidy_lit_pat (HsString "" str_lit)
+ -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
+ -- If we do convert to the constructor form, we'll generate a case
+ -- expression on a Float# or Double# and that's not allowed in Core; see
+ -- Trac #9238 and Note [Rules for floating-point comparisons] in PrelRules
where
mk_con_pat :: DataCon -> HsLit -> Pat Id
mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
@@ -309,15 +312,6 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
(Just _, HsIntegral _ i) -> Just (-i)
_ -> Nothing
- mb_rat_lit :: Maybe FractionalLit
- mb_rat_lit = case (mb_neg, val) of
- (Nothing, HsIntegral _ i) -> Just (integralFractionalLit (fromInteger i))
- (Just _, HsIntegral _ i) -> Just (integralFractionalLit
- (fromInteger (-i)))
- (Nothing, HsFractional f) -> Just f
- (Just _, HsFractional f) -> Just (negateFractionalLit f)
- _ -> Nothing
-
mb_str_lit :: Maybe FastString
mb_str_lit = case (mb_neg, val) of
(Nothing, HsIsString _ s) -> Just s
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 07fb41b8f2..e31d848a08 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -55,7 +55,7 @@ Library
template-haskell,
hpc,
transformers,
- bin-package-db,
+ ghc-boot,
hoopl
if os(windows)
@@ -101,7 +101,7 @@ Library
Include-Dirs: . parser utils
if impl( ghc >= 7.9 )
- -- We need to set the package key to ghc (without a version number)
+ -- We need to set the unit id 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.
@@ -499,7 +499,6 @@ Library
Vectorise
Hoopl.Dataflow
Hoopl
- ShPackageKey
-- CgInfoTbls used in ghci/DebuggerUtils
-- CgHeapery mkVirtHeapOffsets used in ghci
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index f2f793e5ca..6846ad7b97 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -441,13 +441,13 @@ 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))
-compiler_stage1_LIB_NAME = $(subst .$(ProjectPatchLevel),,$(compiler_stage1_LIB_NAME))
+compiler_stage1_COMPONENT_ID = $(subst .$(ProjectPatchLevel),,$(compiler_stage1_COMPONENT_ID))
+compiler_stage1_COMPONENT_ID = $(subst .$(ProjectPatchLevel),,$(compiler_stage1_COMPONENT_ID))
endef
-# NB: the PACKAGE_KEY munging has no effect for new-style package keys
+# NB: the COMPONENT_ID munging has no effect for new-style unit ids
# (which indeed, have nothing version like in them, but are important for
-# old-style package keys which do.) The subst operation is idempotent, so
+# old-style unit ids 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
diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs
index cd31acb7b6..a01fcd89b9 100644
--- a/compiler/ghci/ByteCodeItbls.hs
+++ b/compiler/ghci/ByteCodeItbls.hs
@@ -219,17 +219,17 @@ mkJumpToAddr dflags a = case platformArch (targetPlatform dflags) of
, fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]
ArchARM { } ->
- -- Generates Thumb sequence,
+ -- Generates Arm sequence,
-- ldr r1, [pc, #0]
-- bx r1
--
-- which looks like:
-- 00000000 <.addr-0x8>:
- -- 0: 4900 ldr r1, [pc] ; 8 <.addr>
- -- 4: 4708 bx r1
+ -- 0: 00109fe5 ldr r1, [pc] ; 8 <.addr>
+ -- 4: 11ff2fe1 bx r1
let w32 = fromIntegral (funPtrToInt a) :: Word32
- in Left [ 0x49, 0x00
- , 0x47, 0x08
+ in Left [ 0x00, 0x10, 0x9f, 0xe5
+ , 0x11, 0xff, 0x2f, 0xe1
, byte0 w32, byte1 w32, byte2 w32, byte3 w32]
arch ->
diff --git a/compiler/ghci/ByteCodeLink.hs b/compiler/ghci/ByteCodeLink.hs
index 5090f99065..b977f370d3 100644
--- a/compiler/ghci/ByteCodeLink.hs
+++ b/compiler/ghci/ByteCodeLink.hs
@@ -250,12 +250,12 @@ nameToCLabel :: Name -> String -> String
nameToCLabel n suffix = label where
encodeZ = zString . zEncodeFS
(Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n
- packagePart = encodeZ (packageKeyFS pkgKey)
+ packagePart = encodeZ (unitIdFS pkgKey)
modulePart = encodeZ (moduleNameFS modName)
occPart = encodeZ (occNameFS (nameOccName n))
label = concat
- [ if pkgKey == mainPackageKey then "" else packagePart ++ "_"
+ [ if pkgKey == mainUnitId then "" else packagePart ++ "_"
, modulePart
, '_':occPart
, '_':suffix
diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs
index cafc3759bf..1bca75cedd 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 (fsToPackageKey pkgFS) (mkModuleNameFS modFS)
+ modName = mkModule (fsToUnitId pkgFS) (mkModuleNameFS modFS)
return (Left $ showSDoc dflags $ ppr modName <> dot <> ppr occName)
`recoverM` (Right `fmap` lookupOrig modName occName)
diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs
index 8c2a07c07f..f62998ce86 100644
--- a/compiler/ghci/Linker.hs
+++ b/compiler/ghci/Linker.hs
@@ -117,7 +117,7 @@ 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 :: ![PackageKey],
+ pkgs_loaded :: ![UnitId],
-- we need to remember the name of previous temporary DLL/.so
-- libraries so we can link them (see #10322)
@@ -138,10 +138,10 @@ emptyPLS _ = PersistentLinkerState {
--
-- The linker's symbol table is populated with RTS symbols using an
-- explicit list. See rts/Linker.c for details.
- where init_pkgs = [rtsPackageKey]
+ where init_pkgs = [rtsUnitId]
-extendLoadedPkgs :: [PackageKey] -> IO ()
+extendLoadedPkgs :: [UnitId] -> IO ()
extendLoadedPkgs pkgs =
modifyPLS_ $ \s ->
return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
@@ -540,7 +540,7 @@ getLinkDeps :: HscEnv -> HomePackageTable
-> Maybe FilePath -- replace object suffices?
-> SrcSpan -- for error messages
-> [Module] -- If you need these
- -> IO ([Linkable], [PackageKey]) -- ... then link these first
+ -> IO ([Linkable], [UnitId]) -- ... 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
@@ -578,8 +578,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 PackageKey -- accum. package dependencies
- -> IO ([ModuleName], [PackageKey]) -- result
+ -> UniqSet UnitId -- accum. package dependencies
+ -> IO ([ModuleName], [UnitId]) -- result
follow_deps [] acc_mods acc_pkgs
= return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
follow_deps (mod:mods) acc_mods acc_pkgs
@@ -593,7 +593,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
when (mi_boot iface) $ link_boot_mod_error mod
let
- pkg = modulePackageKey mod
+ pkg = moduleUnitId mod
deps = mi_deps iface
pkg_deps = dep_pkgs deps
@@ -1059,7 +1059,7 @@ showLS (Framework nm) = "(framework) " ++ nm
-- automatically, and it doesn't matter what order you specify the input
-- packages.
--
-linkPackages :: DynFlags -> [PackageKey] -> IO ()
+linkPackages :: DynFlags -> [UnitId] -> 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.
--
@@ -1075,13 +1075,13 @@ linkPackages dflags new_pkgs = do
modifyPLS_ $ \pls -> do
linkPackages' dflags new_pkgs pls
-linkPackages' :: DynFlags -> [PackageKey] -> PersistentLinkerState
+linkPackages' :: DynFlags -> [UnitId] -> PersistentLinkerState
-> IO PersistentLinkerState
linkPackages' dflags new_pks pls = do
pkgs' <- link (pkgs_loaded pls) new_pks
return $! pls { pkgs_loaded = pkgs' }
where
- link :: [PackageKey] -> [PackageKey] -> IO [PackageKey]
+ link :: [UnitId] -> [UnitId] -> IO [UnitId]
link pkgs new_pkgs =
foldM link_one pkgs new_pkgs
@@ -1091,14 +1091,13 @@ linkPackages' dflags new_pks pls = do
| Just pkg_cfg <- lookupPackage dflags new_pkg
= do { -- Link dependents first
- pkgs' <- link pkgs [ resolveInstalledPackageId dflags ipid
- | ipid <- depends pkg_cfg ]
+ pkgs' <- link pkgs (depends pkg_cfg)
-- Now link the package itself
; linkPackage dflags pkg_cfg
; return (new_pkg : pkgs') }
| otherwise
- = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ packageKeyString new_pkg))
+ = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unitIdString new_pkg))
linkPackage :: DynFlags -> PackageConfig -> IO ()
@@ -1200,7 +1199,7 @@ locateLib dflags is_hs dirs lib
-- for a dynamic library (#5289)
-- otherwise, assume loadDLL can find it
--
- = findDll `orElse` findArchive `orElse` tryGcc `orElse` assumeDll
+ = findDll `orElse` findArchive `orElse` tryGcc `orElse` tryGccPrefixed `orElse` assumeDll
| not dynamicGhc
-- When the GHC package was not compiled as dynamic library
@@ -1221,6 +1220,7 @@ locateLib dflags is_hs dirs lib
hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name
so_name = mkSOName platform lib
+ lib_so_name = "lib" ++ so_name
dyn_lib_file = case (arch, os) of
(ArchX86_64, OSSolaris2) -> "64" </> so_name
_ -> so_name
@@ -1230,7 +1230,8 @@ locateLib dflags is_hs dirs lib
findArchive = liftM (fmap Archive) $ findFile dirs arch_file
findHSDll = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file
findDll = liftM (fmap DLLPath) $ findFile dirs dyn_lib_file
- tryGcc = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags so_name dirs
+ tryGcc = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags so_name dirs
+ tryGccPrefixed = liftM (fmap DLLPath) $ searchForLibUsingGcc dflags lib_so_name dirs
assumeDll = return (DLL lib)
infixr `orElse`
@@ -1242,7 +1243,9 @@ locateLib dflags is_hs dirs lib
searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath)
searchForLibUsingGcc dflags so dirs = do
- str <- askCc dflags (map (FileOption "-L") dirs
+ -- GCC does not seem to extend the library search path (using -L) when using
+ -- --print-file-name. So instead pass it a new base location.
+ str <- askCc dflags (map (FileOption "-B") dirs
++ [Option "--print-file-name", Option so])
let file = case lines str of
[] -> ""
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 12a1977c54..10d7e04572 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -1305,8 +1305,8 @@ mk_ghc_ns TH.VarName = OccName.varName
mk_mod :: TH.ModName -> ModuleName
mk_mod mod = mkModuleName (TH.modString mod)
-mk_pkg :: TH.PkgName -> PackageKey
-mk_pkg pkg = stringToPackageKey (TH.pkgString pkg)
+mk_pkg :: TH.PkgName -> UnitId
+mk_pkg pkg = stringToUnitId (TH.pkgString pkg)
mk_uniq :: Int -> Unique
mk_uniq u = mkUniqueGrimily u
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 3c1633d94f..13a6649140 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 = (PackageKey, ModuleName, OccName)
+type OnDiskName = (UnitId, 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 (modulePackageKey mod, moduleName mod, nameOccName name)
+ put_ bh (moduleUnitId mod, moduleName mod, nameOccName name)
-- Note [Symbol table representation of names]
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index c6cddb4611..cbf8048db2 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -516,13 +516,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 == modulePackageKey mod
+ this_package = thisPackage dflags == moduleUnitId 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 (modulePackageKey mod)))
+ <+> quotes (ppr (moduleUnitId mod)))
-----------------------------------------------------
-- Loading type/class/value decls
@@ -711,7 +711,7 @@ findAndReadIface doc_str mod hi_boot_file
(ml_hi_file loc)
-- See Note [Home module load error]
- if thisPackage dflags == modulePackageKey mod &&
+ if thisPackage dflags == moduleUnitId mod &&
not (isOneShot (ghcMode dflags))
then return (Failed (homeModError mod loc))
else do r <- read_file file_path
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index e0743f9020..66a885bb6d 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -111,7 +111,6 @@ import Maybes
import ListSetOps
import Binary
import Fingerprint
-import Bag
import Exception
import Control.Monad
@@ -136,11 +135,10 @@ mkIface :: HscEnv
-> Maybe Fingerprint -- The old fingerprint, if we have it
-> ModDetails -- The trimmed, tidied interface
-> ModGuts -- Usages, deprecations, etc
- -> IO (Messages,
- Maybe (ModIface, -- The new one
- Bool)) -- True <=> there was an old Iface, and the
- -- new one is identical, so no need
- -- to write it
+ -> IO (ModIface, -- The new one
+ Bool) -- True <=> there was an old Iface, and the
+ -- new one is identical, so no need
+ -- to write it
mkIface hsc_env maybe_old_fingerprint mod_details
ModGuts{ mg_module = this_mod,
@@ -199,7 +197,7 @@ mkIfaceTc :: HscEnv
-> SafeHaskellMode -- The safe haskell mode
-> ModDetails -- gotten from mkBootModDetails, probably
-> TcGblEnv -- Usages, deprecations, etc
- -> IO (Messages, Maybe (ModIface, Bool))
+ -> IO (ModIface, Bool)
mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
tc_result@TcGblEnv{ tcg_mod = this_mod,
tcg_src = hsc_src,
@@ -246,12 +244,12 @@ mkDependencies
-- on M.hi-boot, and hence that we should do the hi-boot consistency
-- check.)
- pkgs | th_used = insertList thPackageKey (imp_dep_pkgs imports)
+ pkgs | th_used = insertList thUnitId (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 stablePackageKeyCmp pkgs
+ sorted_pkgs = sortBy stableUnitIdCmp pkgs
trust_pkgs = imp_trust_pkgs imports
dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs
@@ -269,7 +267,7 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource
-> [FilePath]
-> SafeHaskellMode
-> ModDetails
- -> IO (Messages, Maybe (ModIface, Bool))
+ -> IO (ModIface, Bool)
mkIface_ hsc_env maybe_old_fingerprint
this_mod hsc_src used_names used_th deps rdr_env fix_env src_warns
hpc_info dir_imp_mods pkg_trust_req dependent_files safe_mode
@@ -355,38 +353,17 @@ mkIface_ hsc_env maybe_old_fingerprint
addFingerprints hsc_env maybe_old_fingerprint
intermediate_iface decls
- -- Warn about orphans
- -- See Note [Orphans and auto-generated rules]
- let warn_orphs = wopt Opt_WarnOrphans dflags
- warn_auto_orphs = wopt Opt_WarnAutoOrphans dflags
- orph_warnings --- Laziness means no work done unless -fwarn-orphans
- | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns
- | otherwise = emptyBag
- errs_and_warns = (orph_warnings, emptyBag)
- unqual = mkPrintUnqualified dflags rdr_env
- inst_warns = listToBag [ instOrphWarn dflags unqual d
- | (d,i) <- insts `zip` iface_insts
- , isOrphan (ifInstOrph i) ]
- rule_warns = listToBag [ ruleOrphWarn dflags unqual this_mod r
- | r <- iface_rules
- , isOrphan (ifRuleOrph r)
- , if ifRuleAuto r then warn_auto_orphs
- else warn_orphs ]
-
- if errorsFound dflags errs_and_warns
- then return ( errs_and_warns, Nothing )
- else do
- -- Debug printing
- dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
- (pprModIface new_iface)
+ -- Debug printing
+ dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
+ (pprModIface new_iface)
- -- bug #1617: on reload we weren't updating the PrintUnqualified
- -- correctly. This stems from the fact that the interface had
- -- not changed, so addFingerprints returns the old ModIface
- -- with the old GlobalRdrEnv (mi_globals).
- let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }
+ -- bug #1617: on reload we weren't updating the PrintUnqualified
+ -- correctly. This stems from the fact that the interface had
+ -- not changed, so addFingerprints returns the old ModIface
+ -- with the old GlobalRdrEnv (mi_globals).
+ let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }
- return (errs_and_warns, Just (final_iface, no_change_at_all))
+ return (final_iface, no_change_at_all)
where
dflags = hsc_dflags hsc_env
@@ -595,7 +572,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
-- tracked by the usage on the ABI hash of package modules that we import.
let orph_mods
= filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot]
- . filter ((== this_pkg) . modulePackageKey)
+ . filter ((== this_pkg) . moduleUnitId)
$ dep_orphs sorted_deps
dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
@@ -707,7 +684,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 (stablePackageKeyCmp `on` fst) (dep_pkgs d),
+ dep_pkgs = sortBy (stableUnitIdCmp `on` fst) (dep_pkgs d),
dep_orphs = sortBy stableModuleCmp (dep_orphs d),
dep_finsts = sortBy stableModuleCmp (dep_finsts d) }
@@ -726,25 +703,6 @@ mkIfaceAnnCache anns
env = mkOccEnv_C (flip (++)) (map pair anns)
{-
-Note [Orphans and auto-generated rules]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we specialise an INLINEABLE function, or when we have
--fspecialise-aggressively, we auto-generate RULES that are orphans.
-We don't want to warn about these, at least not by default, or we'd
-generate a lot of warnings. Hence -fwarn-auto-orphans.
-
-Indeed, we don't even treat the module as an oprhan module if it has
-auto-generated *rule* orphans. Orphan modules are read every time we
-compile, so they are pretty obtrusive and slow down every compilation,
-even non-optimised ones. (Reason: for type class instances it's a
-type correctness issue.) But specialisation rules are strictly for
-*optimisation* only so it's fine not to read the interface.
-
-What this means is that a SPEC rules from auto-specialisation in
-module M will be used in other modules only if M.hi has been read for
-some other reason, which is actually pretty likely.
-
-
************************************************************************
* *
The ABI of an IfaceDecl
@@ -946,27 +904,6 @@ oldMD5 dflags bh = do
return $! readHexFingerprint hash_str
-}
-instOrphWarn :: DynFlags -> PrintUnqualified -> ClsInst -> WarnMsg
-instOrphWarn dflags unqual inst
- = mkWarnMsg dflags (getSrcSpan inst) unqual $
- hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst)
- $$ text "To avoid this"
- $$ nest 4 (vcat possibilities)
- where
- possibilities =
- text "move the instance declaration to the module of the class or of the type, or" :
- text "wrap the type with a newtype and declare the instance on the new type." :
- []
-
-ruleOrphWarn :: DynFlags -> PrintUnqualified -> Module -> IfaceRule -> WarnMsg
-ruleOrphWarn dflags unqual mod rule
- = mkWarnMsg dflags silly_loc unqual $
- ptext (sLit "Orphan rule:") <+> ppr rule
- where
- silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 1)
- -- We don't have a decent SrcSpan for a Rule, not even the CoreRule
- -- Could readily be fixed by adding a SrcSpan to CoreRule, if we wanted to
-
----------------------
-- mkOrphMap partitions instance decls or rules into
-- (a) an OccEnv for ones that are not orphans,
@@ -1058,7 +995,7 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
-- things in *this* module
= Nothing
- | modulePackageKey mod /= this_pkg
+ | moduleUnitId mod /= this_pkg
= Just UsagePackageModule{ usg_mod = mod,
usg_mod_hash = mod_hash,
usg_safe = imp_safe }
@@ -1366,8 +1303,8 @@ checkDependencies hsc_env summary iface
this_pkg = thisPackage (hsc_dflags hsc_env)
- dep_missing (L _ (ImportDecl { ideclName = L _ mod, ideclPkgQual = pkg })) = do
- find_res <- liftIO $ findImportedModule hsc_env mod (fmap sl_fs pkg)
+ dep_missing (mb_pkg, L _ mod) = do
+ find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)
let reason = moduleNameString mod ++ " changed"
case find_res of
Found _ mod
@@ -1388,7 +1325,7 @@ checkDependencies hsc_env summary iface
return (RecompBecause reason)
else
return UpToDate
- where pkg = modulePackageKey mod
+ where pkg = moduleUnitId mod
_otherwise -> return (RecompBecause reason)
needInterface :: Module -> (ModIface -> IfG RecompileRequired)
@@ -1417,7 +1354,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 :: PackageKey -> Usage -> IfG RecompileRequired
+checkModUsage :: UnitId -> Usage -> IfG RecompileRequired
checkModUsage _this_pkg UsagePackageModule{
usg_mod = mod,
usg_mod_hash = old_mod_hash }
diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs
index 85095997ae..b245422dbc 100644
--- a/compiler/llvmGen/Llvm.hs
+++ b/compiler/llvmGen/Llvm.hs
@@ -20,6 +20,9 @@ module Llvm (
LlvmBlocks, LlvmBlock(..), LlvmBlockId,
LlvmParamAttr(..), LlvmParameter,
+ -- * Atomic operations
+ LlvmAtomicOp(..),
+
-- * Fence synchronization
LlvmSyncOrdering(..),
diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs
index 8a53df00fe..774e555170 100644
--- a/compiler/llvmGen/Llvm/AbsSyn.hs
+++ b/compiler/llvmGen/Llvm/AbsSyn.hs
@@ -87,6 +87,22 @@ data LlvmSyncOrdering
| SyncSeqCst
deriving (Show, Eq)
+-- | LLVM atomic operations. Please see the @atomicrmw@ instruction in
+-- the LLVM documentation for a complete description.
+data LlvmAtomicOp
+ = LAO_Xchg
+ | LAO_Add
+ | LAO_Sub
+ | LAO_And
+ | LAO_Nand
+ | LAO_Or
+ | LAO_Xor
+ | LAO_Max
+ | LAO_Min
+ | LAO_Umax
+ | LAO_Umin
+ deriving (Show, Eq)
+
-- | Llvm Statements
data LlvmStatement
{- |
@@ -250,8 +266,8 @@ data LlvmExpression
| GetElemPtr Bool LlvmVar [LlvmVar]
{- |
- Cast the variable from to the to type. This is an abstraction of three
- cast operators in Llvm, inttoptr, prttoint and bitcast.
+ Cast the variable from to the to type. This is an abstraction of three
+ cast operators in Llvm, inttoptr, prttoint and bitcast.
* cast: Cast type
* from: Variable to cast
* to: type to cast to
@@ -259,6 +275,28 @@ data LlvmExpression
| Cast LlvmCastOp LlvmVar LlvmType
{- |
+ Atomic read-modify-write operation
+ * op: Atomic operation
+ * addr: Address to modify
+ * operand: Operand to operation
+ * ordering: Ordering requirement
+ -}
+ | AtomicRMW LlvmAtomicOp LlvmVar LlvmVar LlvmSyncOrdering
+
+ {- |
+ Compare-and-exchange operation
+ * addr: Address to modify
+ * old: Expected value
+ * new: New value
+ * suc_ord: Ordering required in success case
+ * fail_ord: Ordering required in failure case, can be no stronger than
+ suc_ord
+
+ Result is an @i1@, true if store was successful.
+ -}
+ | CmpXChg LlvmVar LlvmVar LlvmVar LlvmSyncOrdering LlvmSyncOrdering
+
+ {- |
Call a function. The result is the value of the expression.
* tailJumps: CallType to signal if the function should be tail called
* fnptrval: An LLVM value containing a pointer to a function to be
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index db9ef1fccf..cdaf962c4a 100644
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -117,6 +117,7 @@ ppLlvmMeta (MetaNamed n m)
-- | Print out an LLVM metadata value.
ppLlvmMetaExpr :: MetaExpr -> SDoc
+ppLlvmMetaExpr (MetaVar (LMLitVar (LMNullLit _))) = text "null"
ppLlvmMetaExpr (MetaStr s ) = text "!" <> doubleQuotes (ftext s)
ppLlvmMetaExpr (MetaNode n ) = text "!" <> int n
ppLlvmMetaExpr (MetaVar v ) = ppr v
@@ -245,6 +246,8 @@ ppLlvmExpression expr
Load ptr -> ppLoad ptr
ALoad ord st ptr -> ppALoad ord st ptr
Malloc tp amount -> ppMalloc tp amount
+ AtomicRMW aop tgt src ordering -> ppAtomicRMW aop tgt src ordering
+ CmpXChg addr old new s_ord f_ord -> ppCmpXChg addr old new s_ord f_ord
Phi tp precessors -> ppPhi tp precessors
Asm asm c ty v se sk -> ppAsm asm c ty v se sk
MExpr meta expr -> ppMetaExpr meta expr
@@ -278,7 +281,7 @@ ppCall ct fptr args attrs = case fptr of
(case argTy of
VarArgs -> text ", ..."
FixedArgs -> empty)
- fnty = space <> lparen <> ppArgTy <> rparen <> char '*'
+ fnty = space <> lparen <> ppArgTy <> rparen
attrDoc = ppSpaceJoin attrs
in tc <> text "call" <+> ppr cc <+> ppr ret
<> fnty <+> ppName fptr <> lparen <+> ppValues
@@ -327,6 +330,30 @@ ppSyncOrdering SyncRelease = text "release"
ppSyncOrdering SyncAcqRel = text "acq_rel"
ppSyncOrdering SyncSeqCst = text "seq_cst"
+ppAtomicOp :: LlvmAtomicOp -> SDoc
+ppAtomicOp LAO_Xchg = text "xchg"
+ppAtomicOp LAO_Add = text "add"
+ppAtomicOp LAO_Sub = text "sub"
+ppAtomicOp LAO_And = text "and"
+ppAtomicOp LAO_Nand = text "nand"
+ppAtomicOp LAO_Or = text "or"
+ppAtomicOp LAO_Xor = text "xor"
+ppAtomicOp LAO_Max = text "max"
+ppAtomicOp LAO_Min = text "min"
+ppAtomicOp LAO_Umax = text "umax"
+ppAtomicOp LAO_Umin = text "umin"
+
+ppAtomicRMW :: LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc
+ppAtomicRMW aop tgt src ordering =
+ text "atomicrmw" <+> ppAtomicOp aop <+> ppr tgt <> comma
+ <+> ppr src <+> ppSyncOrdering ordering
+
+ppCmpXChg :: LlvmVar -> LlvmVar -> LlvmVar
+ -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc
+ppCmpXChg addr old new s_ord f_ord =
+ text "cmpxchg" <+> ppr addr <> comma <+> ppr old <> comma <+> ppr new
+ <+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord
+
-- XXX: On x86, vector types need to be 16-byte aligned for aligned access, but
-- we have no way of guaranteeing that this is true with GHC (we would need to
-- modify the layout of the stack and closures, change the storage manager,
@@ -336,8 +363,9 @@ ppSyncOrdering SyncSeqCst = text "seq_cst"
-- of specifying alignment.
ppLoad :: LlvmVar -> SDoc
-ppLoad var = text "load" <+> ppr var <> align
+ppLoad var = text "load" <+> ppr derefType <> comma <+> ppr var <> align
where
+ derefType = pLower $ getVarType var
align | isVector . pLower . getVarType $ var = text ", align 1"
| otherwise = empty
@@ -347,7 +375,9 @@ ppALoad ord st var = sdocWithDynFlags $ \dflags ->
align = text ", align" <+> ppr alignment
sThreaded | st = text " singlethread"
| otherwise = empty
- in text "load atomic" <+> ppr var <> sThreaded <+> ppSyncOrdering ord <> align
+ derefType = pLower $ getVarType var
+ in text "load atomic" <+> ppr derefType <> comma <+> ppr var <> sThreaded
+ <+> ppSyncOrdering ord <> align
ppStore :: LlvmVar -> LlvmVar -> SDoc
ppStore val dst
@@ -360,10 +390,10 @@ ppStore val dst
ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
-ppCast op from to
- = ppr op
+ppCast op from to
+ = ppr op
<+> ppr (getVarType from) <+> ppName from
- <+> text "to"
+ <+> text "to"
<+> ppr to
@@ -383,7 +413,9 @@ ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc
ppGetElementPtr inb ptr idx =
let indexes = comma <+> ppCommaJoin idx
inbound = if inb then text "inbounds" else empty
- in text "getelementptr" <+> inbound <+> ppr ptr <> indexes
+ derefType = pLower $ getVarType ptr
+ in text "getelementptr" <+> inbound <+> ppr derefType <> comma <+> ppr ptr
+ <> indexes
ppReturn :: Maybe LlvmVar -> SDoc
diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs
index b3b173096b..d533b4a993 100644
--- a/compiler/llvmGen/Llvm/Types.hs
+++ b/compiler/llvmGen/Llvm/Types.hs
@@ -262,7 +262,7 @@ pLift LMVoid = error "Voids are unliftable"
pLift LMMetadata = error "Metadatas are unliftable"
pLift x = LMPointer x
--- | Lower a variable of 'LMPointer' type.
+-- | Lift a variable to 'LMPointer' type.
pVarLift :: LlvmVar -> LlvmVar
pVarLift (LMGlobalVar s t l x a c) = LMGlobalVar s (pLift t) l x a c
pVarLift (LMLocalVar s t ) = LMLocalVar s (pLift t)
@@ -568,6 +568,8 @@ data LlvmCallConvention
-- does not support varargs and requires the prototype of all callees to
-- exactly match the prototype of the function definition.
| CC_Coldcc
+ -- | The GHC-specific 'registerised' calling convention.
+ | CC_Ghc
-- | Any calling convention may be specified by number, allowing
-- target-specific calling conventions to be used. Target specific calling
-- conventions start at 64.
@@ -581,6 +583,7 @@ instance Outputable LlvmCallConvention where
ppr CC_Ccc = text "ccc"
ppr CC_Fastcc = text "fastcc"
ppr CC_Coldcc = text "coldcc"
+ ppr CC_Ghc = text "ghccc"
ppr (CC_Ncc i) = text "cc " <> ppr i
ppr CC_X86_Stdcc = text "x86_stdcallcc"
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index f0c184a348..345348470a 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -30,7 +30,6 @@ import SysTools ( figureLlvmVersion )
import qualified Stream
import Control.Monad ( when )
-import Data.IORef ( writeIORef )
import Data.Maybe ( fromMaybe, catMaybes )
import System.IO
@@ -47,21 +46,15 @@ llvmCodeGen dflags h us cmm_stream
showPass dflags "LLVM CodeGen"
-- get llvm version, cache for later use
- ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
- writeIORef (llvmVersion dflags) ver
+ ver <- (fromMaybe supportedLlvmVersion) `fmap` figureLlvmVersion dflags
-- warn if unsupported
debugTraceMsg dflags 2
(text "Using LLVM version:" <+> text (show ver))
let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
- when (ver < minSupportLlvmVersion && doWarn) $
- errorMsg dflags (text "You are using an old version of LLVM that"
- <> text " isn't supported anymore!"
+ when (ver /= supportedLlvmVersion && doWarn) $
+ putMsg dflags (text "You are using an unsupported version of LLVM!"
$+$ text "We will try though...")
- when (ver > maxSupportLlvmVersion && doWarn) $
- putMsg dflags (text "You are using a new version of LLVM that"
- <> text " hasn't been tested yet!"
- $+$ text "We will try though...")
-- run code generation
runLlvm dflags ver bufh us $
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 5ef0a4bbfa..510d01f1d7 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -12,8 +12,7 @@ module LlvmCodeGen.Base (
LiveGlobalRegs,
LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
- LlvmVersion, defaultLlvmVersion, minSupportLlvmVersion,
- maxSupportLlvmVersion,
+ LlvmVersion, supportedLlvmVersion,
LlvmM,
runLlvm, liftStream, withClearVars, varLookup, varInsert,
@@ -36,6 +35,7 @@ module LlvmCodeGen.Base (
) where
#include "HsVersions.h"
+#include "ghcautoconf.h"
import Llvm
import LlvmCodeGen.Regs
@@ -111,7 +111,7 @@ widthToLlvmInt w = LMInt $ widthInBits w
llvmGhcCC :: DynFlags -> LlvmCallConvention
llvmGhcCC dflags
| platformUnregisterised (targetPlatform dflags) = CC_Ccc
- | otherwise = CC_Ncc 10
+ | otherwise = CC_Ghc
-- | Llvm Function type for Cmm function
llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
@@ -172,17 +172,11 @@ llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags
--
-- | LLVM Version Number
-type LlvmVersion = Int
+type LlvmVersion = (Int, Int)
--- | The LLVM Version we assume if we don't know
-defaultLlvmVersion :: LlvmVersion
-defaultLlvmVersion = 36
-
-minSupportLlvmVersion :: LlvmVersion
-minSupportLlvmVersion = 36
-
-maxSupportLlvmVersion :: LlvmVersion
-maxSupportLlvmVersion = 36
+-- | The LLVM Version that is currently supported.
+supportedLlvmVersion :: LlvmVersion
+supportedLlvmVersion = sUPPORTED_LLVM_VERSION
-- ----------------------------------------------------------------------------
-- * Environment Handling
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index ed046be891..f1ced7ced8 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -15,7 +15,6 @@ import BlockId
import CodeGen.Platform ( activeStgRegs, callerSaves )
import CLabel
import Cmm
-import CPrim
import PprCmm
import CmmUtils
import CmmSwitch
@@ -180,15 +179,14 @@ genCall (PrimTarget MO_WriteBarrier) _ _ = do
genCall (PrimTarget MO_Touch) _ _
= return (nilOL, [])
-genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = do
- dstV <- getCmmReg (CmmLocal dst)
+genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do
+ dstV <- getCmmRegW (CmmLocal dst)
let ty = cmmToLlvmType $ localRegType dst
width = widthToLlvmFloat w
- castV <- mkLocalVar ty
- (ve, stmts, top) <- exprToVar e
- let stmt3 = Assignment castV $ Cast LM_Uitofp ve width
- stmt4 = Store castV dstV
- return (stmts `snocOL` stmt3 `snocOL` stmt4, top)
+ castV <- lift $ mkLocalVar ty
+ ve <- exprToVarW e
+ statement $ Assignment castV $ Cast LM_Uitofp ve width
+ statement $ Store castV dstV
genCall (PrimTarget (MO_UF_Conv _)) [_] args =
panic $ "genCall: Too many arguments to MO_UF_Conv. " ++
@@ -196,23 +194,20 @@ genCall (PrimTarget (MO_UF_Conv _)) [_] args =
-- Handle prefetching data
genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args
- | 0 <= localityInt && localityInt <= 3 = do
+ | 0 <= localityInt && localityInt <= 3 = runStmtsDecls $ do
let argTy = [i8Ptr, i32, i32, i32]
funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
let (_, arg_hints) = foreignTargetHints t
let args_hints' = zip args arg_hints
- (argVars, stmts1, top1) <- arg_vars args_hints' ([], nilOL, [])
- (fptr, stmts2, top2) <- getFunPtr funTy t
- (argVars', stmts3) <- castVars $ zip argVars argTy
+ argVars <- arg_varsW args_hints' ([], nilOL, [])
+ fptr <- liftExprData $ getFunPtr funTy t
+ argVars' <- castVarsW $ zip argVars argTy
- trash <- getTrashStmts
+ doTrashStmts
let argSuffix = [mkIntLit i32 0, mkIntLit i32 localityInt, mkIntLit i32 1]
- call = Expr $ Call StdCall fptr (argVars' ++ argSuffix) []
- stmts = stmts1 `appOL` stmts2 `appOL` stmts3
- `appOL` trash `snocOL` call
- return (stmts, top1 ++ top2)
+ statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) []
| otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt)
-- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg
@@ -226,22 +221,55 @@ genCall t@(PrimTarget (MO_Ctz 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
+genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do
+ addrVar <- exprToVarW addr
+ nVar <- exprToVarW n
+ let targetTy = widthToLlvmInt width
+ ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy)
+ ptrVar <- doExprW (pLift targetTy) ptrExpr
+ dstVar <- getCmmRegW (CmmLocal dst)
+ let op = case amop of
+ AMO_Add -> LAO_Add
+ AMO_Sub -> LAO_Sub
+ AMO_And -> LAO_And
+ AMO_Nand -> LAO_Nand
+ AMO_Or -> LAO_Or
+ AMO_Xor -> LAO_Xor
+ retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst
+ statement $ Store retVar dstVar
+
+genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = runStmtsDecls $ do
+ dstV <- getCmmRegW (CmmLocal dst)
+ v1 <- genLoadW True addr (localRegType dst)
+ statement $ Store v1 dstV
+
+genCall (PrimTarget (MO_Cmpxchg _width))
+ [dst] [addr, old, new] = runStmtsDecls $ do
+ addrVar <- exprToVarW addr
+ oldVar <- exprToVarW old
+ newVar <- exprToVarW new
+ let targetTy = getVarType oldVar
+ ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy)
+ ptrVar <- doExprW (pLift targetTy) ptrExpr
+ dstVar <- getCmmRegW (CmmLocal dst)
+ retVar <- doExprW (LMStructU [targetTy,i1])
+ $ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst
+ retVar' <- doExprW targetTy $ ExtractV retVar 0
+ statement $ Store retVar' dstVar
+
+genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do
+ addrVar <- exprToVarW addr
+ valVar <- exprToVarW val
+ let ptrTy = pLift $ getVarType valVar
+ ptrExpr = Cast LM_Inttoptr addrVar ptrTy
+ ptrVar <- doExprW ptrTy ptrExpr
+ statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst
-- Handle memcpy function specifically since llvm's intrinsic version takes
-- some extra parameters.
genCall t@(PrimTarget op) [] args
- | Just align <- machOpMemcpyishAlign op = do
- dflags <- getDynFlags
+ | Just align <- machOpMemcpyishAlign op = runStmtsDecls $ do
+ dflags <- lift $ getDynFlags
let isVolTy = [i1]
isVolVal = [mkIntLit i1 0]
argTy | MO_Memset _ <- op = [i8Ptr, i8, llvmWord dflags, i32] ++ isVolTy
@@ -251,61 +279,56 @@ genCall t@(PrimTarget op) [] args
let (_, arg_hints) = foreignTargetHints t
let args_hints = zip args arg_hints
- (argVars, stmts1, top1) <- arg_vars args_hints ([], nilOL, [])
- (fptr, stmts2, top2) <- getFunPtr funTy t
- (argVars', stmts3) <- castVars $ zip argVars argTy
+ argVars <- arg_varsW args_hints ([], nilOL, [])
+ fptr <- getFunPtrW funTy t
+ argVars' <- castVarsW $ zip argVars argTy
- stmts4 <- getTrashStmts
+ doTrashStmts
let alignVal = mkIntLit i32 align
arguments = argVars' ++ (alignVal:isVolVal)
- call = Expr $ Call StdCall fptr arguments []
- stmts = stmts1 `appOL` stmts2 `appOL` stmts3
- `appOL` stmts4 `snocOL` call
- return (stmts, top1 ++ top2)
+ statement $ Expr $ Call StdCall fptr arguments []
-- We handle MO_U_Mul2 by simply using a 'mul' instruction, but with operands
-- twice the width (we first zero-extend them), e.g., on 64-bit arch we will
-- generate 'mul' on 128-bit operands. Then we only need some plumbing to
-- extract the two 64-bit values out of 128-bit result.
-genCall (PrimTarget (MO_U_Mul2 w)) [dstH, dstL] [lhs, rhs] = do
+genCall (PrimTarget (MO_U_Mul2 w)) [dstH, dstL] [lhs, rhs] = runStmtsDecls $ do
let width = widthToLlvmInt w
bitWidth = widthInBits w
width2x = LMInt (bitWidth * 2)
-- First zero-extend the operands ('mul' instruction requires the operands
-- and the result to be of the same type). Note that we don't use 'castVars'
-- because it tries to do LM_Sext.
- (lhsVar, stmts1, decls1) <- exprToVar lhs
- (rhsVar, stmts2, decls2) <- exprToVar rhs
- (lhsExt, stmt3) <- doExpr width2x $ Cast LM_Zext lhsVar width2x
- (rhsExt, stmt4) <- doExpr width2x $ Cast LM_Zext rhsVar width2x
+ lhsVar <- exprToVarW lhs
+ rhsVar <- exprToVarW rhs
+ lhsExt <- doExprW width2x $ Cast LM_Zext lhsVar width2x
+ rhsExt <- doExprW width2x $ Cast LM_Zext rhsVar width2x
-- Do the actual multiplication (note that the result is also 2x width).
- (retV, stmt5) <- doExpr width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt
+ retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt
-- Extract the lower bits of the result into retL.
- (retL, stmt6) <- doExpr width $ Cast LM_Trunc retV width
+ retL <- doExprW width $ Cast LM_Trunc retV width
-- Now we right-shift the higher bits by width.
let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width
- (retShifted, stmt7) <- doExpr width2x $ LlvmOp LM_MO_LShr retV widthLlvmLit
+ retShifted <- doExprW width2x $ LlvmOp LM_MO_LShr retV widthLlvmLit
-- And extract them into retH.
- (retH, stmt8) <- doExpr width $ Cast LM_Trunc retShifted width
- dstRegL <- getCmmReg (CmmLocal dstL)
- dstRegH <- getCmmReg (CmmLocal dstH)
- let storeL = Store retL dstRegL
- storeH = Store retH dstRegH
- stmts = stmts1 `appOL` stmts2 `appOL`
- toOL [ stmt3 , stmt4, stmt5, stmt6, stmt7, stmt8, storeL, storeH ]
- return (stmts, decls1 ++ decls2)
+ retH <- doExprW width $ Cast LM_Trunc retShifted width
+ dstRegL <- getCmmRegW (CmmLocal dstL)
+ dstRegH <- getCmmRegW (CmmLocal dstH)
+ statement $ Store retL dstRegL
+ statement $ Store retH dstRegH
-- MO_U_QuotRem2 is another case we handle by widening the registers to double
-- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The
-- main difference here is that we need to combine two words into one register
-- and then use both 'udiv' and 'urem' instructions to compute the result.
-genCall (PrimTarget (MO_U_QuotRem2 w)) [dstQ, dstR] [lhsH, lhsL, rhs] = run $ do
+genCall (PrimTarget (MO_U_QuotRem2 w))
+ [dstQ, dstR] [lhsH, lhsL, rhs] = runStmtsDecls $ do
let width = widthToLlvmInt w
bitWidth = widthInBits w
width2x = LMInt (bitWidth * 2)
-- First zero-extend all parameters to double width.
let zeroExtend expr = do
- var <- liftExprData $ exprToVar expr
+ var <- exprToVarW expr
doExprW width2x $ Cast LM_Zext var width2x
lhsExtH <- zeroExtend lhsH
lhsExtL <- zeroExtend lhsL
@@ -328,19 +351,6 @@ genCall (PrimTarget (MO_U_QuotRem2 w)) [dstQ, dstR] [lhsH, lhsL, rhs] = run $ do
dstRegR <- lift $ getCmmReg (CmmLocal dstR)
statement $ Store retDiv dstRegQ
statement $ Store retRem dstRegR
- where
- -- TODO(michalt): Consider extracting this and using in more places.
- -- Hopefully this should cut down on the noise of accumulating the
- -- statements and declarations.
- doExprW :: LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
- doExprW a b = do
- (var, stmt) <- lift $ doExpr a b
- statement stmt
- return var
- run :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
- run action = do
- LlvmAccum stmts decls <- execWriterT action
- return (stmts, decls)
-- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from
-- which we need to extract the actual values.
@@ -357,9 +367,8 @@ genCall t@(PrimTarget (MO_Add2 w)) [dstO, dstV] [lhs, rhs] =
genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
-- Handle all other foreign calls and prim ops.
-genCall target res args = do
-
- dflags <- getDynFlags
+genCall target res args = runStmtsDecls $ do
+ dflags <- lift $ getDynFlags
-- parameter types
let arg_type (_, AddrHint) = i8Ptr
@@ -374,7 +383,7 @@ genCall target res args = do
++ " 0 or 1, given " ++ show (length t) ++ "."
-- extract Cmm call convention, and translate to LLVM call convention
- platform <- getLlvmPlatform
+ platform <- lift $ getLlvmPlatform
let lmconv = case target of
ForeignTarget _ (ForeignConvention conv _ _ _) ->
case conv of
@@ -416,37 +425,32 @@ genCall target res args = do
lmconv retTy FixedArgs argTy (llvmFunAlign dflags)
- (argVars, stmts1, top1) <- arg_vars args_hints ([], nilOL, [])
- (fptr, stmts2, top2) <- getFunPtr funTy target
+ argVars <- arg_varsW args_hints ([], nilOL, [])
+ fptr <- getFunPtrW funTy target
- let retStmt | ccTy == TailCall = unitOL $ Return Nothing
- | never_returns = unitOL $ Unreachable
- | otherwise = nilOL
+ let doReturn | ccTy == TailCall = statement $ Return Nothing
+ | never_returns = statement $ Unreachable
+ | otherwise = return ()
- stmts3 <- getTrashStmts
- let stmts = stmts1 `appOL` stmts2 `appOL` stmts3
+ doTrashStmts
-- make the actual call
case retTy of
LMVoid -> do
- let s1 = Expr $ Call ccTy fptr argVars fnAttrs
- let allStmts = stmts `snocOL` s1 `appOL` retStmt
- return (allStmts, top1 ++ top2)
+ statement $ Expr $ Call ccTy fptr argVars fnAttrs
_ -> do
- (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
+ v1 <- doExprW retTy $ Call ccTy fptr argVars fnAttrs
-- get the return register
let ret_reg [reg] = reg
ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
++ " 1, given " ++ show (length t) ++ "."
let creg = ret_reg res
- vreg <- getCmmReg (CmmLocal creg)
- let allStmts = stmts `snocOL` s1
+ vreg <- getCmmRegW (CmmLocal creg)
if retTy == pLower (getVarType vreg)
then do
- let s2 = Store v1 vreg
- return (allStmts `snocOL` s2 `appOL` retStmt,
- top1 ++ top2)
+ statement $ Store v1 vreg
+ doReturn
else do
let ty = pLower $ getVarType vreg
let op = case ty of
@@ -456,10 +460,9 @@ genCall target res args = do
panic $ "genCall: CmmReg bad match for"
++ " returned type!"
- (v2, s2) <- doExpr ty $ Cast op v1 ty
- let s3 = Store v2 vreg
- return (allStmts `snocOL` s2 `snocOL` s3
- `appOL` retStmt, top1 ++ top2)
+ v2 <- doExprW ty $ Cast op v1 ty
+ statement $ Store v2 vreg
+ doReturn
-- | Generate a call to an LLVM intrinsic that performs arithmetic operation
-- with overflow bit (i.e., returns a struct containing the actual result of the
@@ -555,6 +558,11 @@ genCallSimpleCast _ _ dsts _ =
panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts")
-- | Create a function pointer from a target.
+getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget
+ -> WriterT LlvmAccum LlvmM LlvmVar
+getFunPtrW funTy targ = liftExprData $ getFunPtr funTy targ
+
+-- | Create a function pointer from a target.
getFunPtr :: (LMString -> LlvmType) -> ForeignTarget
-> LlvmM ExprData
getFunPtr funTy targ = case targ of
@@ -582,6 +590,15 @@ getFunPtr funTy targ = case targ of
getInstrinct2 name fty
-- | Conversion of call arguments.
+arg_varsW :: [(CmmActual, ForeignHint)]
+ -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
+ -> WriterT LlvmAccum LlvmM [LlvmVar]
+arg_varsW xs ys = do
+ (vars, stmts, decls) <- lift $ arg_vars xs ys
+ tell $ LlvmAccum stmts decls
+ return vars
+
+-- | Conversion of call arguments.
arg_vars :: [(CmmActual, ForeignHint)]
-> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
@@ -609,6 +626,14 @@ arg_vars ((e, _):rest) (vars, stmts, tops)
-- | Cast a collection of LLVM variables to specific types.
+castVarsW :: [(LlvmVar, LlvmType)]
+ -> WriterT LlvmAccum LlvmM [LlvmVar]
+castVarsW vars = do
+ (vars, stmts) <- lift $ castVars vars
+ tell $ LlvmAccum stmts mempty
+ return vars
+
+-- | Cast a collection of LLVM variables to specific types.
castVars :: [(LlvmVar, LlvmType)]
-> LlvmM ([LlvmVar], LlvmStatements)
castVars vars = do
@@ -715,10 +740,9 @@ cmmPrimOpFunctions mop = do
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
+ MO_AtomicRMW _ _ -> unsupported
+ MO_AtomicWrite _ -> unsupported
+ MO_Cmpxchg _ -> unsupported
-- | Tail function calls
genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData
@@ -1209,44 +1233,38 @@ genMachOp_fast opt op r n e
genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
-- Element extraction
-genMachOp_slow _ (MO_V_Extract l w) [val, idx] = do
- (vval, stmts1, top1) <- exprToVar val
- (vidx, stmts2, top2) <- exprToVar idx
- ([vval'], stmts3) <- castVars [(vval, LMVector l ty)]
- (v1, s1) <- doExpr ty $ Extract vval' vidx
- return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2)
+genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do
+ vval <- exprToVarW val
+ vidx <- exprToVarW idx
+ [vval'] <- castVarsW [(vval, LMVector l ty)]
+ doExprW ty $ Extract vval' vidx
where
ty = widthToLlvmInt w
-genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = do
- (vval, stmts1, top1) <- exprToVar val
- (vidx, stmts2, top2) <- exprToVar idx
- ([vval'], stmts3) <- castVars [(vval, LMVector l ty)]
- (v1, s1) <- doExpr ty $ Extract vval' vidx
- return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2)
+genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = runExprData $ do
+ vval <- exprToVarW val
+ vidx <- exprToVarW idx
+ [vval'] <- castVarsW [(vval, LMVector l ty)]
+ doExprW ty $ Extract vval' vidx
where
ty = widthToLlvmFloat w
-- Element insertion
-genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = do
- (vval, stmts1, top1) <- exprToVar val
- (velt, stmts2, top2) <- exprToVar elt
- (vidx, stmts3, top3) <- exprToVar idx
- ([vval'], stmts4) <- castVars [(vval, ty)]
- (v1, s1) <- doExpr ty $ Insert vval' velt vidx
- return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1,
- top1 ++ top2 ++ top3)
+genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = runExprData $ do
+ vval <- exprToVarW val
+ velt <- exprToVarW elt
+ vidx <- exprToVarW idx
+ [vval'] <- castVarsW [(vval, ty)]
+ doExprW ty $ Insert vval' velt vidx
where
ty = LMVector l (widthToLlvmInt w)
-genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = do
- (vval, stmts1, top1) <- exprToVar val
- (velt, stmts2, top2) <- exprToVar elt
- (vidx, stmts3, top3) <- exprToVar idx
- ([vval'], stmts4) <- castVars [(vval, ty)]
- (v1, s1) <- doExpr ty $ Insert vval' velt vidx
- return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1,
- top1 ++ top2 ++ top3)
+genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = runExprData $ do
+ vval <- exprToVarW val
+ velt <- exprToVarW elt
+ vidx <- exprToVarW idx
+ [vval'] <- castVarsW [(vval, ty)]
+ doExprW ty $ Insert vval' velt vidx
where
ty = LMVector l (widthToLlvmFloat w)
@@ -1335,35 +1353,28 @@ genMachOp_slow opt op [x, y] = case op of
MO_VF_Neg {} -> panicOp
where
- binLlvmOp ty binOp = do
- (vx, stmts1, top1) <- exprToVar x
- (vy, stmts2, top2) <- exprToVar y
+ binLlvmOp ty binOp = runExprData $ do
+ vx <- exprToVarW x
+ vy <- exprToVarW y
if getVarType vx == getVarType vy
then do
- (v1, s1) <- doExpr (ty vx) $ binOp vx vy
- return (v1, stmts1 `appOL` stmts2 `snocOL` s1,
- top1 ++ top2)
+ doExprW (ty vx) $ binOp vx vy
else do
-- Error. Continue anyway so we can debug the generated ll file.
- dflags <- getDynFlags
+ dflags <- lift getDynFlags
let style = mkCodeStyle CStyle
toString doc = renderWithStyle dflags doc style
cmmToStr = (lines . toString . PprCmm.pprExpr)
- let dx = Comment $ map fsLit $ cmmToStr x
- let dy = Comment $ map fsLit $ cmmToStr y
- (v1, s1) <- doExpr (ty vx) $ binOp vx vy
- let allStmts = stmts1 `appOL` stmts2 `snocOL` dx
- `snocOL` dy `snocOL` s1
- return (v1, allStmts, top1 ++ top2)
-
- binCastLlvmOp ty binOp = do
- (vx, stmts1, top1) <- exprToVar x
- (vy, stmts2, top2) <- exprToVar y
- ([vx', vy'], stmts3) <- castVars [(vx, ty), (vy, ty)]
- (v1, s1) <- doExpr ty $ binOp vx' vy'
- return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1,
- top1 ++ top2)
+ statement $ Comment $ map fsLit $ cmmToStr x
+ statement $ Comment $ map fsLit $ cmmToStr y
+ doExprW (ty vx) $ binOp vx vy
+
+ binCastLlvmOp ty binOp = runExprData $ do
+ vx <- exprToVarW x
+ vy <- exprToVarW y
+ [vx', vy'] <- castVarsW [(vx, ty), (vy, ty)]
+ doExprW ty $ binOp vx' vy'
-- | Need to use EOption here as Cmm expects word size results from
-- comparisons while LLVM return i1. Need to extend to llvmWord type
@@ -1391,11 +1402,11 @@ genMachOp_slow opt op [x, y] = case op of
-- implementation. Its much longer due to type information/safety.
-- This should actually compile to only about 3 asm instructions.
isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData
- isSMulOK _ x y = do
- (vx, stmts1, top1) <- exprToVar x
- (vy, stmts2, top2) <- exprToVar y
+ isSMulOK _ x y = runExprData $ do
+ vx <- exprToVarW x
+ vy <- exprToVarW y
- dflags <- getDynFlags
+ dflags <- lift getDynFlags
let word = getVarType vx
let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx)
let shift = llvmWidthInBits dflags word
@@ -1404,18 +1415,14 @@ genMachOp_slow opt op [x, y] = case op of
if isInt word
then do
- (x1, s1) <- doExpr word2 $ Cast LM_Sext vx word2
- (y1, s2) <- doExpr word2 $ Cast LM_Sext vy word2
- (r1, s3) <- doExpr word2 $ LlvmOp LM_MO_Mul x1 y1
- (rlow1, s4) <- doExpr word $ Cast LM_Trunc r1 word
- (rlow2, s5) <- doExpr word $ LlvmOp LM_MO_AShr rlow1 shift1
- (rhigh1, s6) <- doExpr word2 $ LlvmOp LM_MO_AShr r1 shift2
- (rhigh2, s7) <- doExpr word $ Cast LM_Trunc rhigh1 word
- (dst, s8) <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2
- let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4
- `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8
- return (dst, stmts1 `appOL` stmts2 `appOL` stmts,
- top1 ++ top2)
+ x1 <- doExprW word2 $ Cast LM_Sext vx word2
+ y1 <- doExprW word2 $ Cast LM_Sext vy word2
+ r1 <- doExprW word2 $ LlvmOp LM_MO_Mul x1 y1
+ rlow1 <- doExprW word $ Cast LM_Trunc r1 word
+ rlow2 <- doExprW word $ LlvmOp LM_MO_AShr rlow1 shift1
+ rhigh1 <- doExprW word2 $ LlvmOp LM_MO_AShr r1 shift2
+ rhigh2 <- doExprW word $ Cast LM_Trunc rhigh1 word
+ doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2
else
panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")"
@@ -1497,24 +1504,19 @@ genLoad_fast atomic e r n ty = do
-- | Handle Cmm load expression.
-- Generic case. Uses casts and pointer arithmetic if needed.
genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData
-genLoad_slow atomic e ty meta = do
- (iptr, stmts, tops) <- exprToVar e
- dflags <- getDynFlags
+genLoad_slow atomic e ty meta = runExprData $ do
+ iptr <- exprToVarW e
+ dflags <- lift getDynFlags
case getVarType iptr of
LMPointer _ -> do
- (dvar, load) <- doExpr (cmmToLlvmType ty)
- (MExpr meta $ loadInstr iptr)
- return (dvar, stmts `snocOL` load, tops)
+ doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr)
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 $ loadInstr ptr)
- return (dvar, stmts `snocOL` cast `snocOL` load, tops)
+ ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty
+ doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr ptr)
- other -> do dflags <- getDynFlags
- pprPanic "exprToVar: CmmLoad expression is not right type!"
+ other -> do pprPanic "exprToVar: CmmLoad expression is not right type!"
(PprCmm.pprExpr e <+> text (
"Size of Ptr: " ++ show (llvmPtrBits dflags) ++
", Size of var: " ++ show (llvmWidthInBits dflags other) ++
@@ -1839,3 +1841,33 @@ liftExprData action = do
statement :: LlvmStatement -> WriterT LlvmAccum LlvmM ()
statement stmt = tell $ LlvmAccum (unitOL stmt) []
+
+doExprW :: LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
+doExprW a b = do
+ (var, stmt) <- lift $ doExpr a b
+ statement stmt
+ return var
+
+exprToVarW :: CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
+exprToVarW = liftExprData . exprToVar
+
+runExprData :: WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
+runExprData action = do
+ (var, LlvmAccum stmts decls) <- runWriterT action
+ return (var, stmts, decls)
+
+runStmtsDecls :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
+runStmtsDecls action = do
+ LlvmAccum stmts decls <- execWriterT action
+ return (stmts, decls)
+
+getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
+getCmmRegW = lift . getCmmReg
+
+genLoadW :: Atomic -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar
+genLoadW atomic e ty = liftExprData $ genLoad atomic e ty
+
+doTrashStmts :: WriterT LlvmAccum LlvmM ()
+doTrashStmts = do
+ stmts <- lift getTrashStmts
+ tell $ LlvmAccum stmts mempty
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index 1a9373bce2..d7ddf804f2 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -52,7 +52,7 @@ moduleLayout = sdocWithPlatform $ \platform ->
$+$ text "target triple = \"x86_64-linux-gnu\""
Platform { platformArch = ArchARM {}, platformOS = OSLinux } ->
text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""
- $+$ text "target triple = \"arm-unknown-linux-gnueabi\""
+ $+$ text "target triple = \"armv6-unknown-linux-gnueabihf\""
Platform { platformArch = ArchARM {}, platformOS = OSAndroid } ->
text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""
$+$ text "target triple = \"arm-unknown-linux-androideabi\""
diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs
index f55a15a842..00a0801c47 100644
--- a/compiler/main/CodeOutput.hs
+++ b/compiler/main/CodeOutput.hs
@@ -50,7 +50,7 @@ codeOutput :: DynFlags
-> FilePath
-> ModLocation
-> ForeignStubs
- -> [PackageKey]
+ -> [UnitId]
-> 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 ()
- -> [PackageKey]
+ -> [UnitId]
-> 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 dflags rtsPackageKey
+ let rts = getPackageDetails dflags rtsUnitId
let cc_injects = unlines (map mk_include (includes rts))
mk_include h_file =
@@ -124,7 +124,7 @@ outputC dflags filenm cmm_stream packages
'<':_ -> "#include "++h_file
_ -> "#include \""++h_file++"\""
- let pkg_names = map packageKeyString packages
+ let pkg_names = map unitIdString packages
doOutput filenm $ \ h -> do
hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
@@ -208,7 +208,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 dflags rtsPackageKey in
+ let rts_pkg = getPackageDetails dflags rtsUnitId in
concatMap mk_include (includes rts_pkg)
mk_include i = "#include \"" ++ i ++ "\"\n"
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index aae4d0e7c2..1541d95c62 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -16,7 +16,6 @@ module DriverMkDepend (
import qualified GHC
import GhcMonad
-import HsSyn ( ImportDecl(..) )
import DynFlags
import Util
import HscTypes
@@ -30,7 +29,6 @@ import Panic
import SrcLoc
import Data.List
import FastString
-import BasicTypes ( StringLiteral(..) )
import Exception
import ErrUtils
@@ -227,9 +225,8 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)
-- Emit a dependency for each import
; let do_imps is_boot idecls = sequence_
- [ do_imp loc is_boot (fmap sl_fs $ ideclPkgQual i) mod
- | L loc i <- idecls,
- let mod = unLoc (ideclName i),
+ [ do_imp loc is_boot mb_pkg mod
+ | (mb_pkg, L loc mod) <- idecls,
mod `notElem` excl_mods ]
; do_imps True (ms_srcimps node)
@@ -379,7 +376,7 @@ pprCycle summaries = pp_group (CyclicSCC summaries)
pp_ms loop_breaker $$ vcat (map pp_group groups)
where
(boot_only, others) = partition is_boot_only mss
- is_boot_only ms = not (any in_group (map (ideclName.unLoc) (ms_imps ms)))
+ is_boot_only ms = not (any in_group (map snd (ms_imps ms)))
in_group (L _ m) = m `elem` group_mods
group_mods = map (moduleName . ms_mod) mss
@@ -388,8 +385,8 @@ pprCycle summaries = pp_group (CyclicSCC summaries)
groups = GHC.topSortModuleGraph True all_others Nothing
pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))
- <+> (pp_imps empty (map (ideclName.unLoc) (ms_imps summary)) $$
- pp_imps (ptext (sLit "{-# SOURCE #-}")) (map (ideclName.unLoc) (ms_srcimps summary)))
+ <+> (pp_imps empty (map snd (ms_imps summary)) $$
+ pp_imps (ptext (sLit "{-# SOURCE #-}")) (map snd (ms_srcimps summary)))
where
mod_str = moduleNameString (moduleName (ms_mod summary))
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index a45507e635..e83f7d66a3 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -64,10 +64,8 @@ import MonadUtils
import Platform
import TcRnTypes
import Hooks
-import MkIface
import Exception
-import Data.IORef ( readIORef )
import System.Directory
import System.FilePath
import System.IO
@@ -133,173 +131,90 @@ compileOne' :: Maybe TcGblEnv
compileOne' m_tc_result mHscMessage
hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
source_modified0
- | HsBootMerge <- ms_hsc_src summary
- = do -- Do a boot merge instead! For now, something very simple
- output_fn <- getOutputFilename next_phase
- Temporary basename dflags next_phase (Just location)
- e <- genericHscMergeRequirement mHscMessage
- hsc_env summary mb_old_iface (mod_index, nmods)
-
- case e of
- -- TODO: dedup
- Left iface ->
- do details <- genModDetails hsc_env iface
- return (HomeModInfo{ hm_details = details,
- hm_iface = iface,
- hm_linkable = maybe_old_linkable })
- Right (iface0, mb_old_hash) ->
- case hsc_lang of
- HscInterpreted ->
- do (iface, _no_change) <- mkIfaceDirect hsc_env mb_old_hash iface0
- details <- genModDetails hsc_env iface
- -- Merges don't need to link in any bytecode, unlike
- -- HsSrcFiles.
- let linkable = LM (ms_hs_date summary) this_mod []
- return (HomeModInfo{ hm_details = details,
- hm_iface = iface,
- hm_linkable = Just linkable })
-
- HscNothing ->
- do (iface, no_change) <- mkIfaceDirect hsc_env mb_old_hash iface0
- details <- genModDetails hsc_env iface
- when (gopt Opt_WriteInterface dflags) $
- hscWriteIface dflags iface no_change summary
- let linkable = LM (ms_hs_date summary) this_mod []
- return (HomeModInfo{ hm_details = details,
- hm_iface = iface,
- hm_linkable = Just linkable })
- _ ->
- do (iface, no_change) <- mkIfaceDirect hsc_env mb_old_hash iface0
- hscWriteIface dflags iface no_change summary
-
- -- #10660: Use the pipeline instead of calling
- -- compileEmptyStub directly, so -dynamic-too gets
- -- handled properly
- let mod_name = ms_mod_name summary
- _ <- runPipeline StopLn hsc_env
- (output_fn,
- Just (HscOut src_flavour
- mod_name HscUpdateBootMerge))
- (Just basename)
- Persistent
- (Just location)
- Nothing
-
- details <- genModDetails hsc_env iface
-
- o_time <- getModificationUTCTime object_filename
- let linkable =
- LM o_time this_mod [DotO object_filename]
- return (HomeModInfo{ hm_details = details,
- hm_iface = iface,
- hm_linkable = Just linkable })
-
- | otherwise
= do
debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)
- -- What file to generate the output into?
- output_fn <- getOutputFilename next_phase
- Temporary basename dflags next_phase (Just location)
-
- e <- genericHscCompileGetFrontendResult
- always_do_basic_recompilation_check
- m_tc_result mHscMessage
- hsc_env summary source_modified mb_old_iface (mod_index, nmods)
-
- case e of
- Left iface ->
- do details <- genModDetails hsc_env iface
- MASSERT(isJust maybe_old_linkable || isNoLink (ghcLink dflags))
- return (HomeModInfo{ hm_details = details,
- hm_iface = iface,
- hm_linkable = maybe_old_linkable })
-
- Right (tc_result, mb_old_hash) ->
- -- run the compiler
- case hsc_lang of
- HscInterpreted ->
- case ms_hsc_src summary of
- HsBootFile ->
- do (iface, _changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash
- return (HomeModInfo{ hm_details = details,
- hm_iface = iface,
- hm_linkable = maybe_old_linkable })
- _ -> do guts0 <- hscDesugar hsc_env summary tc_result
- guts <- hscSimplify hsc_env guts0
- (iface, _changed, details, cgguts) <- hscNormalIface hsc_env guts mb_old_hash
- (hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env cgguts summary
-
- stub_o <- case hasStub of
- Nothing -> return []
- Just stub_c -> do
- stub_o <- compileStub hsc_env stub_c
- return [DotO stub_o]
-
- let hs_unlinked = [BCOs comp_bc modBreaks]
- unlinked_time = ms_hs_date summary
- -- Why do we use the timestamp of the source file here,
- -- rather than the current time? This works better in
- -- the case where the local clock is out of sync
- -- with the filesystem's clock. It's just as accurate:
- -- if the source is modified, then the linkable will
- -- be out of date.
- let linkable = LM unlinked_time this_mod
- (hs_unlinked ++ stub_o)
-
- return (HomeModInfo{ hm_details = details,
- hm_iface = iface,
- hm_linkable = Just linkable })
- HscNothing ->
- do (iface, changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash
- when (gopt Opt_WriteInterface dflags) $
- hscWriteIface dflags iface changed summary
- let linkable = if isHsBoot src_flavour
- then maybe_old_linkable
- else Just (LM (ms_hs_date summary) this_mod [])
- return (HomeModInfo{ hm_details = details,
- hm_iface = iface,
- hm_linkable = linkable })
- _ ->
- case ms_hsc_src summary of
- HsBootMerge -> panic "This driver can't handle it"
- HsBootFile ->
- do (iface, changed, details) <- hscSimpleIface hsc_env tc_result mb_old_hash
- hscWriteIface dflags iface changed summary
-
- touchObjectFile dflags object_filename
-
- return (HomeModInfo{
- hm_details = details,
- hm_iface = iface,
- hm_linkable = maybe_old_linkable })
-
- HsSrcFile ->
- do guts0 <- hscDesugar hsc_env summary tc_result
- guts <- hscSimplify hsc_env guts0
- (iface, changed, details, cgguts) <- hscNormalIface hsc_env guts mb_old_hash
- hscWriteIface dflags iface changed summary
-
- -- We're in --make mode: finish the compilation pipeline.
- let mod_name = ms_mod_name summary
- _ <- runPipeline StopLn hsc_env
- (output_fn,
- Just (HscOut src_flavour mod_name (HscRecomp cgguts summary)))
- (Just basename)
- Persistent
- (Just location)
- Nothing
- -- The object filename comes from the ModLocation
- o_time <- getModificationUTCTime object_filename
- let linkable = LM o_time this_mod [DotO object_filename]
-
- return (HomeModInfo{ hm_details = details,
- hm_iface = iface,
- hm_linkable = Just linkable })
+ (status, hmi0) <- hscIncrementalCompile
+ always_do_basic_recompilation_check
+ m_tc_result mHscMessage
+ hsc_env summary source_modified mb_old_iface (mod_index, nmods)
+
+ case (status, hsc_lang) of
+ (HscUpToDate, _) ->
+ ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )
+ return hmi0 { hm_linkable = maybe_old_linkable }
+ (HscNotGeneratingCode, HscNothing) ->
+ let mb_linkable = if isHsBoot src_flavour
+ then Nothing
+ -- TODO: Questionable.
+ else Just (LM (ms_hs_date summary) this_mod [])
+ in return hmi0 { hm_linkable = mb_linkable }
+ (HscNotGeneratingCode, _) -> panic "compileOne HscNotGeneratingCode"
+ (_, HscNothing) -> panic "compileOne HscNothing"
+ (HscUpdateBoot, HscInterpreted) -> do
+ return hmi0
+ (HscUpdateBoot, _) -> do
+ touchObjectFile dflags object_filename
+ return hmi0
+ (HscUpdateBootMerge, HscInterpreted) ->
+ let linkable = LM (ms_hs_date summary) this_mod []
+ in return hmi0 { hm_linkable = Just linkable }
+ (HscUpdateBootMerge, _) -> do
+ output_fn <- getOutputFilename next_phase
+ Temporary basename dflags next_phase (Just location)
+
+ -- #10660: Use the pipeline instead of calling
+ -- compileEmptyStub directly, so -dynamic-too gets
+ -- handled properly
+ _ <- runPipeline StopLn hsc_env
+ (output_fn,
+ Just (HscOut src_flavour
+ mod_name HscUpdateBootMerge))
+ (Just basename)
+ Persistent
+ (Just location)
+ Nothing
+ o_time <- getModificationUTCTime object_filename
+ let linkable = LM o_time this_mod [DotO object_filename]
+ return hmi0 { hm_linkable = Just linkable }
+ (HscRecomp cgguts summary, HscInterpreted) -> do
+ (hasStub, comp_bc, modBreaks) <- hscInteractive hsc_env cgguts summary
+
+ stub_o <- case hasStub of
+ Nothing -> return []
+ Just stub_c -> do
+ stub_o <- compileStub hsc_env stub_c
+ return [DotO stub_o]
+
+ let hs_unlinked = [BCOs comp_bc modBreaks]
+ unlinked_time = ms_hs_date summary
+ -- Why do we use the timestamp of the source file here,
+ -- rather than the current time? This works better in
+ -- the case where the local clock is out of sync
+ -- with the filesystem's clock. It's just as accurate:
+ -- if the source is modified, then the linkable will
+ -- be out of date.
+ let linkable = LM unlinked_time (ms_mod summary)
+ (hs_unlinked ++ stub_o)
+ return hmi0 { hm_linkable = Just linkable }
+ (HscRecomp cgguts summary, _) -> do
+ output_fn <- getOutputFilename next_phase
+ Temporary basename dflags next_phase (Just location)
+ -- We're in --make mode: finish the compilation pipeline.
+ _ <- runPipeline StopLn hsc_env
+ (output_fn,
+ Just (HscOut src_flavour mod_name (HscRecomp cgguts summary)))
+ (Just basename)
+ Persistent
+ (Just location)
+ Nothing
+ -- The object filename comes from the ModLocation
+ o_time <- getModificationUTCTime object_filename
+ let linkable = LM o_time this_mod [DotO object_filename]
+ return hmi0 { hm_linkable = Just linkable }
+
where dflags0 = ms_hspp_opts summary
- this_mod = ms_mod summary
- src_flavour = ms_hsc_src summary
location = ms_location summary
input_fn = expectJust "compile:hs" (ml_hs_file location)
input_fnpp = ms_hspp_file summary
@@ -310,6 +225,13 @@ compileOne' m_tc_result mHscMessage
isDynWay = any (== WayDyn) (ways dflags0)
isProfWay = any (== WayProf) (ways dflags0)
+
+ src_flavour = ms_hsc_src summary
+ this_mod = ms_mod summary
+ mod_name = ms_mod_name summary
+ next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
+ object_filename = ml_obj_file location
+
-- #8180 - when using TemplateHaskell, switch on -dynamic-too so
-- the linker can correctly load the object files.
@@ -329,15 +251,12 @@ compileOne' m_tc_result mHscMessage
-- Figure out what lang we're generating
hsc_lang = hscTarget dflags
- -- ... and what the next phase should be
- next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
-- -fforce-recomp should also work with --make
force_recomp = gopt Opt_ForceRecomp dflags
source_modified
| force_recomp = SourceModified
| otherwise = source_modified0
- object_filename = ml_obj_file location
always_do_basic_recompilation_check = case hsc_lang of
HscInterpreted -> True
@@ -478,7 +397,7 @@ link' dflags batch_attempt_linking hpt
return Succeeded
-linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [PackageKey] -> IO Bool
+linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [UnitId] -> 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
@@ -514,7 +433,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 -> [PackageKey] -> FilePath -> IO Bool
+checkLinkInfo :: DynFlags -> [UnitId] -> 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
@@ -1087,8 +1006,9 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
ms_merge_imps = (False, []) }
-- run the compiler!
- result <- liftIO $ hscCompileOneShot hsc_env'
- mod_summary source_unchanged
+ let msg hsc_env _ what _ = oneShotMsg hsc_env what
+ (result, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'
+ mod_summary source_unchanged Nothing (1,1)
return (HscOut src_flavour mod_name result,
panic "HscOut doesn't have an input filename")
@@ -1261,7 +1181,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 == basePackageKey
+ thisPackage dflags == baseUnitId
then [ "-DCOMPILING_BASE_PACKAGE" ]
else [])
@@ -1338,14 +1258,7 @@ runPhase (RealPhase (As with_cpp)) input_fn dflags
-- assembler, so we use clang as the assembler instead. (#5636)
let whichAsProg | hscTarget dflags == HscLlvm &&
platformOS (targetPlatform dflags) == OSDarwin
- = do
- -- be careful what options we call clang with
- -- see #5903 and #7617 for bugs caused by this.
- llvmVer <- liftIO $ figureLlvmVersion dflags
- return $ case llvmVer of
- Just n | n >= 30 -> SysTools.runClang
- _ -> SysTools.runAs
-
+ = return SysTools.runClang
| otherwise = return SysTools.runAs
as_prog <- whichAsProg
@@ -1487,18 +1400,15 @@ runPhase (RealPhase SplitAs) _input_fn dflags
runPhase (RealPhase LlvmOpt) input_fn dflags
= do
- ver <- liftIO $ readIORef (llvmVersion dflags)
-
let opt_lvl = max 0 (min 2 $ optLevel dflags)
-- don't specify anything if user has specified commands. We do this
-- for opt but not llc since opt is very specifically for optimisation
-- passes only, so if the user is passing us extra options we assume
-- they know what they are doing and don't get in the way.
optFlag = if null (getOpts dflags opt_lo)
- then map SysTools.Option $ words (llvmOpts ver !! opt_lvl)
+ then map SysTools.Option $ words (llvmOpts !! opt_lvl)
else []
- tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier
- | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true"
+ tbaa | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true"
| otherwise = "--enable-tbaa=false"
@@ -1512,22 +1422,19 @@ runPhase (RealPhase LlvmOpt) input_fn dflags
++ [SysTools.Option tbaa])
return (RealPhase LlvmLlc, output_fn)
- where
+ where
-- we always (unless -optlo specified) run Opt since we rely on it to
-- fix up some pretty big deficiencies in the code we generate
- llvmOpts ver = [ "-mem2reg -globalopt"
- , if ver >= 34 then "-O1 -globalopt" else "-O1"
- -- LLVM 3.4 -O1 doesn't eliminate aliases reliably (bug #8855)
- , "-O2"
- ]
+ llvmOpts = [ "-mem2reg -globalopt"
+ , "-O1 -globalopt"
+ , "-O2"
+ ]
-----------------------------------------------------------------------------
-- LlvmLlc phase
runPhase (RealPhase LlvmLlc) input_fn dflags
= do
- ver <- liftIO $ readIORef (llvmVersion dflags)
-
let opt_lvl = max 0 (min 2 $ optLevel dflags)
-- iOS requires external references to be loaded indirectly from the
-- DATA segment or dyld traps at runtime writing into TEXT: see #7722
@@ -1535,8 +1442,7 @@ runPhase (RealPhase LlvmLlc) input_fn dflags
| gopt Opt_PIC dflags = "pic"
| not (gopt Opt_Static dflags) = "dynamic-no-pic"
| otherwise = "static"
- tbaa | ver < 29 = "" -- no tbaa in 2.8 and earlier
- | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true"
+ tbaa | gopt Opt_LlvmTBAA dflags = "--enable-tbaa=true"
| otherwise = "--enable-tbaa=false"
-- hidden debugging flag '-dno-llvm-mangler' to skip mangling
@@ -1544,13 +1450,8 @@ runPhase (RealPhase LlvmLlc) input_fn dflags
False -> LlvmMangle
True | gopt Opt_SplitObjs dflags -> Splitter
True -> As False
-
- output_fn <- phaseOutputFilename next_phase
- -- AVX can cause LLVM 3.2 to generate a C-like frame pointer
- -- prelude, see #9391
- when (ver == 32 && isAvxEnabled dflags) $ liftIO $ errorMsg dflags $ text
- "Note: LLVM 3.2 has known problems with AVX instructions (see trac #9391)"
+ output_fn <- phaseOutputFilename next_phase
liftIO $ SysTools.runLlvmLlc dflags
([ SysTools.Option (llvmOpts !! opt_lvl),
@@ -1561,7 +1462,7 @@ runPhase (RealPhase LlvmLlc) input_fn dflags
++ map SysTools.Option fpOpts
++ map SysTools.Option abiOpts
++ map SysTools.Option sseOpts
- ++ map SysTools.Option (avxOpts ver)
+ ++ map SysTools.Option avxOpts
++ map SysTools.Option avx512Opts
++ map SysTools.Option stackAlignOpts)
@@ -1574,7 +1475,7 @@ runPhase (RealPhase LlvmLlc) input_fn dflags
-- On ARMv7 using LLVM, LLVM fails to allocate floating point registers
-- while compiling GHC source code. It's probably due to fact that it
-- does not enable VFP by default. Let's do this manually here
- fpOpts = case platformArch (targetPlatform dflags) of
+ fpOpts = case platformArch (targetPlatform dflags) of
ArchARM ARMv7 ext _ -> if (elem VFPv3 ext)
then ["-mattr=+v7,+vfp3"]
else if (elem VFPv3D16 ext)
@@ -1597,11 +1498,10 @@ runPhase (RealPhase LlvmLlc) input_fn dflags
| isSseEnabled dflags = ["-mattr=+sse"]
| otherwise = []
- avxOpts ver | isAvx512fEnabled dflags = ["-mattr=+avx512f"]
- | isAvx2Enabled dflags = ["-mattr=+avx2"]
- | isAvxEnabled dflags = ["-mattr=+avx"]
- | ver == 32 = ["-mattr=-avx"] -- see #9391
- | otherwise = []
+ avxOpts | isAvx512fEnabled dflags = ["-mattr=+avx512f"]
+ | isAvx2Enabled dflags = ["-mattr=+avx2"]
+ | isAvxEnabled dflags = ["-mattr=+avx"]
+ | otherwise = []
avx512Opts =
[ "-mattr=+avx512cd" | isAvx512cdEnabled dflags ] ++
@@ -1693,7 +1593,7 @@ mkExtraObj dflags extn xs
= do cFile <- newTempName dflags extn
oFile <- newTempName dflags "o"
writeFile cFile xs
- let rtsDetails = getPackageDetails dflags rtsPackageKey
+ let rtsDetails = getPackageDetails dflags rtsUnitId
pic_c_flags = picCCOpts dflags
SysTools.runCc dflags
([Option "-c",
@@ -1748,7 +1648,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 -> [PackageKey] -> IO [FilePath]
+mkNoteObjsToLinkIntoBinary :: DynFlags -> [UnitId] -> IO [FilePath]
mkNoteObjsToLinkIntoBinary dflags dep_packages = do
link_info <- getLinkInfo dflags dep_packages
@@ -1789,7 +1689,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 -> [PackageKey] -> IO String
+getLinkInfo :: DynFlags -> [UnitId] -> IO String
getLinkInfo dflags dep_packages = do
package_link_opts <- getPackageLinkOpts dflags dep_packages
pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)
@@ -1810,13 +1710,13 @@ getLinkInfo dflags dep_packages = do
-----------------------------------------------------------------------------
-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
-getHCFilePackages :: FilePath -> IO [PackageKey]
+getHCFilePackages :: FilePath -> IO [UnitId]
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 stringToPackageKey (words rest))
+ return (map stringToUnitId (words rest))
_other ->
return []
@@ -1833,10 +1733,10 @@ getHCFilePackages filename =
-- read any interface files), so the user must explicitly specify all
-- the packages.
-linkBinary :: DynFlags -> [FilePath] -> [PackageKey] -> IO ()
+linkBinary :: DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkBinary = linkBinary' False
-linkBinary' :: Bool -> DynFlags -> [FilePath] -> [PackageKey] -> IO ()
+linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO ()
linkBinary' staticLink dflags o_files dep_packages = do
let platform = targetPlatform dflags
mySettings = settings dflags
@@ -2080,7 +1980,7 @@ maybeCreateManifest dflags exe_filename
| otherwise = return []
-linkDynLibCheck :: DynFlags -> [String] -> [PackageKey] -> IO ()
+linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO ()
linkDynLibCheck dflags o_files dep_packages
= do
when (haveRtsOptsFlags dflags) $ do
@@ -2090,7 +1990,7 @@ linkDynLibCheck dflags o_files dep_packages
linkDynLib dflags o_files dep_packages
-linkStaticLibCheck :: DynFlags -> [String] -> [PackageKey] -> IO ()
+linkStaticLibCheck :: DynFlags -> [String] -> [UnitId] -> IO ()
linkStaticLibCheck dflags o_files dep_packages
= do
when (platformOS (targetPlatform dflags) `notElem` [OSiOS, OSDarwin]) $
@@ -2275,7 +2175,7 @@ haveRtsOptsFlags dflags =
-- | Find out path to @ghcversion.h@ file
getGhcVersionPathName :: DynFlags -> IO FilePath
getGhcVersionPathName dflags = do
- dirs <- getPackageIncludePath dflags [rtsPackageKey]
+ dirs <- getPackageIncludePath dflags [rtsUnitId]
found <- filterM doesFileExist (map (</> "ghcversion.h") dirs)
case found of
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 3327a1effe..3ecb1031a4 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -92,7 +92,7 @@ module DynFlags (
getVerbFlags,
updOptLevel,
setTmpDir,
- setPackageKey,
+ setUnitId,
interpretPackageEnv,
-- ** Parsing DynFlags
@@ -100,10 +100,6 @@ module DynFlags (
parseDynamicFilePragma,
parseDynamicFlagsFull,
- -- ** Package key cache
- PackageKeyCache,
- ShPackageKey(..),
-
-- ** Available DynFlags
allFlags,
flagsAll,
@@ -181,8 +177,6 @@ import Foreign.C ( CInt(..) )
import System.IO.Unsafe ( unsafeDupablePerformIO )
#endif
import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage )
-import UniqFM
-import UniqSet
import System.IO.Unsafe ( unsafePerformIO )
import Data.IORef
@@ -667,29 +661,6 @@ type SigOf = Map ModuleName Module
getSigOf :: DynFlags -> ModuleName -> Maybe Module
getSigOf dflags n = Map.lookup n (sigOf dflags)
--- NameCache updNameCache
-type PackageKeyEnv = UniqFM
-type PackageKeyCache = PackageKeyEnv ShPackageKey
-
--- | An elaborated representation of a 'PackageKey', which records
--- all of the components that go into the hashed 'PackageKey'.
-data ShPackageKey
- = ShPackageKey {
- shPackageKeyUnitName :: !UnitName,
- shPackageKeyLibraryName :: !LibraryName,
- shPackageKeyInsts :: ![(ModuleName, Module)],
- shPackageKeyFreeHoles :: UniqSet ModuleName
- }
- | ShDefinitePackageKey {
- shPackageKey :: !PackageKey
- }
- deriving Eq
-
-instance Outputable ShPackageKey where
- ppr (ShPackageKey pn vh insts fh)
- = ppr pn <+> ppr vh <+> ppr insts <+> parens (ppr fh)
- ppr (ShDefinitePackageKey pk) = ppr pk
-
-- | Contains not only a collection of 'GeneralFlag's but also a plethora of
-- information relating to the compilation of a single file or GHC session
data DynFlags = DynFlags {
@@ -734,10 +705,7 @@ data DynFlags = DynFlags {
solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver
-- Typically only 1 is needed
- thisPackage :: PackageKey, -- ^ key of package currently being compiled
- thisLibraryName :: LibraryName,
- -- ^ the version hash which identifies the textual
- -- package being compiled.
+ thisPackage :: UnitId, -- ^ key of package currently being compiled
-- ways
ways :: [Way], -- ^ Way flags from the command line
@@ -824,7 +792,6 @@ data DynFlags = DynFlags {
-- Packages.initPackages
pkgDatabase :: Maybe [PackageConfig],
pkgState :: PackageState,
- pkgKeyCache :: {-# UNPACK #-} !(IORef PackageKeyCache),
-- Temporary files
-- These have to be IORefs, because the defaultCleanupHandler needs to
@@ -902,8 +869,6 @@ data DynFlags = DynFlags {
interactivePrint :: Maybe String,
- llvmVersion :: IORef Int,
-
nextWrapperNum :: IORef (ModuleEnv Int),
-- | Machine dependant flags (-m<blah> stuff)
@@ -1153,7 +1118,7 @@ isNoLink _ = False
data PackageArg =
PackageArg String -- ^ @-package@, by 'PackageName'
| PackageIdArg String -- ^ @-package-id@, by 'SourcePackageId'
- | PackageKeyArg String -- ^ @-package-key@, by 'InstalledPackageId'
+ | UnitIdArg String -- ^ @-package-key@, by 'ComponentId'
deriving (Eq, Show)
-- | Represents the renaming that may be associated with an exposed
@@ -1411,7 +1376,6 @@ initDynFlags dflags = do
refDirsToClean <- newIORef Map.empty
refFilesToNotIntermediateClean <- newIORef []
refGeneratedDumps <- newIORef Set.empty
- refLlvmVersion <- newIORef 28
refRtldInfo <- newIORef Nothing
refRtccInfo <- newIORef Nothing
wrapperNum <- newIORef emptyModuleEnv
@@ -1428,7 +1392,6 @@ initDynFlags dflags = do
dirsToClean = refDirsToClean,
filesToNotIntermediateClean = refFilesToNotIntermediateClean,
generatedDumps = refGeneratedDumps,
- llvmVersion = refLlvmVersion,
nextWrapperNum = wrapperNum,
useUnicode = canUseUnicode,
rtldInfo = refRtldInfo,
@@ -1473,8 +1436,7 @@ defaultDynFlags mySettings =
reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH,
solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS,
- thisPackage = mainPackageKey,
- thisLibraryName = LibraryName nilFS,
+ thisPackage = mainUnitId,
objectDir = Nothing,
dylibInstallName = Nothing,
@@ -1520,7 +1482,6 @@ defaultDynFlags mySettings =
pkgDatabase = Nothing,
-- This gets filled in with GHC.setSessionDynFlags
pkgState = emptyPackageState,
- pkgKeyCache = v_unsafePkgKeyCache,
ways = defaultWays mySettings,
buildTag = mkBuildTag (defaultWays mySettings),
rtsBuildTag = mkBuildTag (defaultWays mySettings),
@@ -1583,7 +1544,6 @@ defaultDynFlags mySettings =
useUnicode = False,
traceLevel = 1,
profAuto = NoProfAuto,
- llvmVersion = panic "defaultDynFlags: No llvmVersion",
interactivePrint = Nothing,
nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum",
sseVersion = Nothing,
@@ -1954,10 +1914,10 @@ parseSigOf str = case filter ((=="").snd) (readP_to_S parse str) of
m <- tok $ parseModule
return (n, m)
parseModule = do
- pk <- munch1 (\c -> isAlphaNum c || c `elem` "-_")
+ pk <- munch1 (\c -> isAlphaNum c || c `elem` "-_.")
_ <- R.char ':'
m <- parseModuleName
- return (mkModule (stringToPackageKey pk) m)
+ return (mkModule (stringToUnitId pk) m)
tok m = skipSpaces >> m
setSigOf :: String -> DynFlags -> DynFlags
@@ -2766,13 +2726,12 @@ package_flags = [
deprecate "Use -no-user-package-db instead")
, defGhcFlag "package-name" (HasArg $ \name -> do
- upd (setPackageKey name)
+ upd (setUnitId name)
deprecate "Use -this-package-key instead")
- , defGhcFlag "this-package-key" (hasArg setPackageKey)
- , defGhcFlag "library-name" (hasArg setLibraryName)
+ , defGhcFlag "this-package-key" (hasArg setUnitId)
, defFlag "package-id" (HasArg exposePackageId)
, defFlag "package" (HasArg exposePackage)
- , defFlag "package-key" (HasArg exposePackageKey)
+ , defFlag "package-key" (HasArg exposeUnitId)
, defFlag "hide-package" (HasArg hidePackage)
, defFlag "hide-all-packages" (NoArg (setGeneralFlag Opt_HideAllPackages))
, defFlag "package-env" (HasArg setPackageEnv)
@@ -2877,7 +2836,8 @@ fWarningFlags = [
Opt_WarnAlternativeLayoutRuleTransitional,
flagSpec' "warn-amp" Opt_WarnAMP
(\_ -> deprecate "it has no effect, and will be removed in GHC 7.12"),
- flagSpec "warn-auto-orphans" Opt_WarnAutoOrphans,
+ flagSpec' "warn-auto-orphans" Opt_WarnAutoOrphans
+ (\_ -> deprecate "it has no effect"),
flagSpec "warn-deferred-type-errors" Opt_WarnDeferredTypeErrors,
flagSpec "warn-deprecations" Opt_WarnWarningsDeprecations,
flagSpec "warn-deprecated-flags" Opt_WarnDeprecatedFlags,
@@ -3751,15 +3711,15 @@ parsePackageFlag constr str = case filter ((=="").snd) (readP_to_S parse str) of
return (orig, orig))
tok m = m >>= \x -> skipSpaces >> return x
-exposePackage, exposePackageId, exposePackageKey, hidePackage, ignorePackage,
+exposePackage, exposePackageId, exposeUnitId, hidePackage, ignorePackage,
trustPackage, distrustPackage :: String -> DynP ()
exposePackage p = upd (exposePackage' p)
exposePackageId p =
upd (\s -> s{ packageFlags =
parsePackageFlag PackageIdArg p : packageFlags s })
-exposePackageKey p =
+exposeUnitId p =
upd (\s -> s{ packageFlags =
- parsePackageFlag PackageKeyArg p : packageFlags s })
+ parsePackageFlag UnitIdArg p : packageFlags s })
hidePackage p =
upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })
ignorePackage p =
@@ -3774,11 +3734,8 @@ exposePackage' p dflags
= dflags { packageFlags =
parsePackageFlag PackageArg p : packageFlags dflags }
-setPackageKey :: String -> DynFlags -> DynFlags
-setPackageKey p s = s{ thisPackage = stringToPackageKey p }
-
-setLibraryName :: String -> DynFlags -> DynFlags
-setLibraryName v s = s{ thisLibraryName = LibraryName (mkFastString v) }
+setUnitId :: String -> DynFlags -> DynFlags
+setUnitId p s = s{ thisPackage = stringToUnitId p }
-- -----------------------------------------------------------------------------
-- | Find the package environment (if one exists)
@@ -3927,10 +3884,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 mainPackageKey (mkModuleName main_mod) }
+ mainModIs = mkModule mainUnitId (mkModuleName main_mod) }
| isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar"
- = upd $ \d -> d{ mainModIs = mkModule mainPackageKey (mkModuleName arg) }
+ = upd $ \d -> d{ mainModIs = mkModule mainUnitId (mkModuleName arg) }
| otherwise -- The arg looked like "baz"
= upd $ \d -> d{ mainFunIs = Just arg }
@@ -4120,6 +4077,7 @@ compilerInfo dflags
("Support parallel --make", "YES"),
("Support reexported-modules", "YES"),
("Support thinning and renaming package flags", "YES"),
+ ("Requires unified installed package IDs", "YES"),
("Uses package keys", "YES"),
("Dynamic by default", if dYNAMIC_BY_DEFAULT dflags
then "YES" else "NO"),
@@ -4270,8 +4228,6 @@ unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags
setUnsafeGlobalDynFlags :: DynFlags -> IO ()
setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags
-GLOBAL_VAR(v_unsafePkgKeyCache, emptyUFM, PackageKeyCache)
-
-- -----------------------------------------------------------------------------
-- SSE and AVX
diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs
index 208475fefb..1ccf33f668 100644
--- a/compiler/main/Finder.hs
+++ b/compiler/main/Finder.hs
@@ -72,7 +72,7 @@ flushFinderCaches hsc_env =
where
this_pkg = thisPackage (hsc_dflags hsc_env)
fc_ref = hsc_FC hsc_env
- is_ext mod _ | modulePackageKey mod /= this_pkg = True
+ is_ext mod _ | moduleUnitId mod /= this_pkg = True
| otherwise = False
addToFinderCache :: IORef FinderCache -> Module -> FindResult -> IO ()
@@ -121,7 +121,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 modulePackageKey mod == thisPackage dflags
+ in if moduleUnitId mod == thisPackage dflags
then findHomeModule hsc_env (moduleName mod)
else findPackageModule hsc_env mod
@@ -167,8 +167,8 @@ findExposedPackageModule hsc_env mod_name mb_pkg
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_pkgs_hidden = map (moduleUnitId.fst) pkg_hiddens
+ , fr_mods_hidden = map (moduleUnitId.fst) mod_hiddens
, fr_suggestions = [] })
LookupNotFound suggest ->
return (NotFound{ fr_paths = [], fr_pkg = Nothing
@@ -211,7 +211,7 @@ uncacheModule hsc_env mod = do
-- 2. When you have a package qualified import with package name "this",
-- we shortcut to the home module.
--
--- 3. When we look up an exact 'Module', if the package key associated with
+-- 3. When we look up an exact 'Module', if the unit id associated with
-- the module is the current home module do a look up in the home module.
--
-- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to
@@ -258,7 +258,7 @@ findPackageModule :: HscEnv -> Module -> IO FindResult
findPackageModule hsc_env mod = do
let
dflags = hsc_dflags hsc_env
- pkg_id = modulePackageKey mod
+ pkg_id = moduleUnitId mod
--
case lookupPackage dflags pkg_id of
Nothing -> return (NoPackage pkg_id)
@@ -268,12 +268,12 @@ findPackageModule hsc_env mod = do
-- 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.hs@) and (2)
--- the 'PackageConfig' must be consistent with the package key in the 'Module'.
+-- the 'PackageConfig' must be consistent with the unit id 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 )
+ ASSERT( moduleUnitId mod == packageConfigId pkg_conf )
modLocationCache hsc_env mod $
-- special case for GHC.Prim; we won't find it in the filesystem.
@@ -343,7 +343,7 @@ searchPathExts paths mod exts
]
search [] = return (NotFound { fr_paths = map fst to_search
- , fr_pkg = Just (modulePackageKey mod)
+ , fr_pkg = Just (moduleUnitId mod)
, fr_mods_hidden = [], fr_pkgs_hidden = []
, fr_suggestions = [] })
@@ -531,7 +531,7 @@ cantFindErr _ multiple_found _ mod_name (FoundMultiple mods)
where
unambiguousPackages = foldl' unambiguousPackage (Just []) mods
unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)
- = Just (modulePackageKey m : xs)
+ = Just (moduleUnitId m : xs)
unambiguousPackage _ _ = Nothing
pprMod (m, o) = ptext (sLit "it is bound as") <+> ppr m <+>
@@ -539,7 +539,7 @@ cantFindErr _ multiple_found _ mod_name (FoundMultiple mods)
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)]
+ then [ptext (sLit "package") <+> ppr (moduleUnitId m)]
else [] ++
map ((ptext (sLit "a reexport in package") <+>)
.ppr.packageConfigId) res ++
@@ -553,7 +553,7 @@ cantFindErr cannot_find _ dflags mod_name find_result
more_info
= case find_result of
NoPackage pkg
- -> ptext (sLit "no package key matching") <+> quotes (ppr pkg) <+>
+ -> ptext (sLit "no unit id matching") <+> quotes (ppr pkg) <+>
ptext (sLit "was found") $$ looks_like_srcpkgid pkg
NotFound { fr_paths = files, fr_pkg = mb_pkg
@@ -600,11 +600,11 @@ cantFindErr cannot_find _ dflags mod_name find_result
| otherwise =
hang (ptext (sLit "Locations searched:")) 2 $ vcat (map text files)
- pkg_hidden :: PackageKey -> SDoc
+ pkg_hidden :: UnitId -> SDoc
pkg_hidden pkgid =
ptext (sLit "It is a member of the hidden package")
<+> quotes (ppr pkgid)
- --FIXME: we don't really want to show the package key here we should
+ --FIXME: we don't really want to show the unit id here we should
-- show the source package id or installed package id if it's ambiguous
<> dot $$ cabal_pkg_hidden_hint pkgid
cabal_pkg_hidden_hint pkgid
@@ -615,13 +615,13 @@ cantFindErr cannot_find _ dflags mod_name find_result
ptext (sLit "to the build-depends in your .cabal file.")
| otherwise = Outputable.empty
- looks_like_srcpkgid :: PackageKey -> SDoc
+ looks_like_srcpkgid :: UnitId -> SDoc
looks_like_srcpkgid pk
- -- Unsafely coerce a package key FastString into a source package ID
+ -- Unsafely coerce a unit id FastString into a source package ID
-- FastString and see if it means anything.
- | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (packageKeyFS pk))
- = parens (text "This package key looks like the source package ID;" $$
- text "the real package key is" <+> quotes (ftext (packageKeyFS (packageKey pkg))) $$
+ | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (unitIdFS pk))
+ = parens (text "This unit ID looks like the source package ID;" $$
+ text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$
(if null pkgs then Outputable.empty
else text "and" <+> int (length pkgs) <+> text "other candidates"))
-- Todo: also check if it looks like a package name!
@@ -645,9 +645,9 @@ cantFindErr cannot_find _ dflags mod_name find_result
fromExposedReexport = res,
fromPackageFlag = f })
| Just True <- e
- = parens (ptext (sLit "from") <+> ppr (modulePackageKey mod))
+ = parens (ptext (sLit "from") <+> ppr (moduleUnitId mod))
| f && moduleName mod == m
- = parens (ptext (sLit "from") <+> ppr (modulePackageKey mod))
+ = parens (ptext (sLit "from") <+> ppr (moduleUnitId mod))
| (pkg:_) <- res
= parens (ptext (sLit "from") <+> ppr (packageConfigId pkg)
<> comma <+> ptext (sLit "reexporting") <+> ppr mod)
@@ -661,8 +661,8 @@ cantFindErr cannot_find _ dflags mod_name find_result
fromHiddenReexport = rhs })
| Just False <- e
= parens (ptext (sLit "needs flag -package-key")
- <+> ppr (modulePackageKey mod))
+ <+> ppr (moduleUnitId mod))
| (pkg:_) <- rhs
- = parens (ptext (sLit "needs flag -package-key")
+ = parens (ptext (sLit "needs flag -package-id")
<+> ppr (packageConfigId pkg))
| otherwise = Outputable.empty
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 17c0a0da2f..1f7b1173cb 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -156,10 +156,10 @@ module GHC (
-- * Abstract syntax elements
-- ** Packages
- PackageKey,
+ UnitId,
-- ** Modules
- Module, mkModule, pprModule, moduleName, modulePackageKey,
+ Module, mkModule, pprModule, moduleName, moduleUnitId,
ModuleName, mkModuleName, moduleNameString,
-- ** Names
@@ -399,7 +399,6 @@ defaultErrorHandler fm (FlushOut flushOut) inner =
(\ge -> liftIO $ do
flushOut
case ge of
- PhaseFailed _ code -> exitWith code
Signal _ -> exitWith (ExitFailure 1)
_ -> do fatalErrorMsg'' fm (show ge)
exitWith (ExitFailure 1)
@@ -570,7 +569,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 [PackageKey]
+setSessionDynFlags :: GhcMonad m => DynFlags -> m [UnitId]
setSessionDynFlags dflags = do
dflags' <- checkNewDynFlags dflags
(dflags'', preload) <- liftIO $ initPackages dflags'
@@ -580,7 +579,7 @@ setSessionDynFlags dflags = do
return preload
-- | Sets the program 'DynFlags'.
-setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageKey]
+setProgramDynFlags :: GhcMonad m => DynFlags -> m [UnitId]
setProgramDynFlags dflags = do
dflags' <- checkNewDynFlags dflags
(dflags'', preload) <- liftIO $ initPackages dflags'
@@ -1361,7 +1360,7 @@ showRichTokenStream ts = go startLoc ts ""
-- -----------------------------------------------------------------------------
-- Interactive evaluation
--- | Takes a 'ModuleName' and possibly a 'PackageKey', and consults the
+-- | Takes a 'ModuleName' and possibly a 'UnitId', 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
@@ -1371,7 +1370,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
this_pkg = thisPackage dflags
--
case maybe_pkg of
- Just pkg | fsToPackageKey pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
+ Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
res <- findImportedModule hsc_env mod_name maybe_pkg
case res of
Found _ m -> return m
@@ -1383,7 +1382,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 | modulePackageKey m /= this_pkg -> return m
+ Found loc m | moduleUnitId m /= this_pkg -> return m
| otherwise -> modNotLoadedError dflags m loc
err -> throwOneError $ noModError dflags noSrcSpan mod_name err
@@ -1428,7 +1427,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, [PackageKey])
+moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [UnitId])
moduleTrustReqs m = withSession $ \hsc_env ->
liftIO $ hscGetSafe hsc_env m noSrcSpan
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 3d29b1d38e..65df44b83d 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -34,10 +34,8 @@ import ErrUtils
import Finder
import GhcMonad
import HeaderInfo
-import HsSyn
import HscTypes
import Module
-import RdrName ( RdrName )
import TcIface ( typecheckIface )
import TcRnMonad ( initIfaceCheck )
@@ -1627,7 +1625,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
calcDeps summ
| HsBootFile <- ms_hsc_src summ
, Just m <- getSigOf (hsc_dflags hsc_env) (moduleName (ms_mod summ))
- , modulePackageKey m == thisPackage (hsc_dflags hsc_env)
+ , moduleUnitId m == thisPackage (hsc_dflags hsc_env)
= (noLoc (moduleName m), NotBoot) : msDeps summ
| otherwise = msDeps summ
@@ -1720,9 +1718,9 @@ msDeps s =
then [ (noLoc (moduleName (ms_mod s)), IsBoot) ]
else []
-home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]
-home_imps imps = [ ideclName i | L _ i <- imps,
- isLocal (fmap sl_fs $ ideclPkgQual i) ]
+home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]
+home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps,
+ isLocal mb_pkg ]
where isLocal Nothing = True
isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
isLocal _ = False
@@ -1922,7 +1920,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
just_found location mod
| otherwise ->
-- Drop external-pkg
- ASSERT(modulePackageKey mod /= thisPackage dflags)
+ ASSERT(moduleUnitId mod /= thisPackage dflags)
return Nothing
err -> return $ Just $ Left $ noModError dflags loc wanted_mod err
diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index 3473a4ab88..b4c3f81678 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -37,6 +37,7 @@ import Maybes
import Bag ( emptyBag, listToBag, unitBag )
import MonadUtils
import Exception
+import BasicTypes
import Control.Monad
import System.IO
@@ -54,7 +55,9 @@ getImports :: DynFlags
-- reporting parse error locations.
-> FilePath -- ^ The original source filename (used for locations
-- in the function result)
- -> IO ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
+ -> IO ([(Maybe FastString, Located ModuleName)],
+ [(Maybe FastString, Located ModuleName)],
+ Located ModuleName)
-- ^ The source imports, normal imports, and the module name.
getImports dflags buf filename source_filename = do
let loc = mkRealSrcLoc (mkFastString filename) 1 1
@@ -83,8 +86,11 @@ getImports dflags buf filename source_filename = do
implicit_prelude = xopt Opt_ImplicitPrelude dflags
implicit_imports = mkPrelImports (unLoc mod) main_loc
implicit_prelude imps
+ convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)
in
- return (src_idecls, implicit_imports ++ ordinary_imps, mod)
+ return (map convImport src_idecls,
+ map convImport (implicit_imports ++ ordinary_imps),
+ mod)
mkPrelImports :: ModuleName
-> SrcSpan -- Attribute the "import Prelude" to this location
diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs
index f9339b1cef..f75214b4f4 100644
--- a/compiler/main/Hooks.hs
+++ b/compiler/main/Hooks.hs
@@ -14,7 +14,6 @@ module Hooks ( Hooks
, tcForeignImportsHook
, tcForeignExportsHook
, hscFrontendHook
- , hscCompileOneShotHook
, hscCompileCoreExprHook
, ghcPrimIfaceHook
, runPhaseHook
@@ -58,14 +57,12 @@ import Data.Maybe
emptyHooks :: Hooks
emptyHooks = Hooks Nothing Nothing Nothing Nothing Nothing
Nothing Nothing Nothing Nothing Nothing Nothing
- Nothing
data Hooks = Hooks
{ dsForeignsHook :: Maybe ([LForeignDecl Id] -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))
, tcForeignImportsHook :: Maybe ([LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id], Bag GlobalRdrElt))
, tcForeignExportsHook :: Maybe ([LForeignDecl Name] -> TcM (LHsBinds TcId, [LForeignDecl TcId], Bag GlobalRdrElt))
- , hscFrontendHook :: Maybe (ModSummary -> Hsc TcGblEnv)
- , hscCompileOneShotHook :: Maybe (HscEnv -> ModSummary -> SourceModified -> IO HscStatus)
+ , hscFrontendHook :: Maybe (ModSummary -> Hsc FrontendResult)
, hscCompileCoreExprHook :: Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO HValue)
, ghcPrimIfaceHook :: Maybe ModIface
, runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath))
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index e5c6ce14ec..64143e0c03 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -19,10 +19,11 @@
-- from here on in (although it has mutable components, for the
-- caches).
--
--- Warning messages are dealt with consistently throughout this API:
--- during compilation warnings are collected, and before any function
--- in @HscMain@ returns, the warnings are either printed, or turned
--- into a real compialtion error if the @-Werror@ flag is enabled.
+-- We use the Hsc monad to deal with warning messages consistently:
+-- specifically, while executing within an Hsc monad, warnings are
+-- collected. When a Hsc monad returns to an IO monad, the
+-- warnings are printed, or compilation aborts if the @-Werror@
+-- flag is enabled.
--
-- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
--
@@ -36,12 +37,11 @@ module HscMain
-- * Compiling complete source files
, Messager, batchMsg
, HscStatus (..)
- , hscCompileOneShot
+ , hscIncrementalCompile
, hscCompileCmmFile
, hscCompileCore
- , genericHscCompileGetFrontendResult
- , genericHscMergeRequirement
+ , hscIncrementalFrontend
, genModDetails
, hscSimpleIface
@@ -58,12 +58,14 @@ module HscMain
, makeSimpleDetails
, hscSimplify -- ToDo, shouldn't really export this
+ -- * Safe Haskell
+ , hscCheckSafe
+ , hscGetSafe
+
-- * Support for interactive evaluation
, hscParseIdentifier
, hscTcRcLookupName
, hscTcRnGetInfo
- , hscCheckSafe
- , hscGetSafe
#ifdef GHCI
, hscIsGHCiMonad
, hscGetModuleInterface
@@ -458,7 +460,7 @@ makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails
-> IO (ModIface,Bool)
makeSimpleIface hsc_env maybe_old_iface tc_result details = runHsc hsc_env $ do
safe_mode <- hscGetSafeMode tc_result
- ioMsgMaybe $ do
+ liftIO $ do
mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) safe_mode
details tc_result
@@ -513,73 +515,38 @@ This is the only thing that isn't caught by the type-system.
type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO ()
--- | Analogous to 'genericHscCompileGetFrontendResult', this function
--- calls 'hscMergeFrontEnd' if recompilation is necessary. It does
--- not write out the resulting 'ModIface' (see 'compileOne').
--- TODO: maybe fold this 'genericHscCompileGetFrontendResult' into
--- some higher-order function
-genericHscMergeRequirement ::
- Maybe Messager
- -> HscEnv
- -> ModSummary
- -> Maybe ModIface -- Old interface, if available
- -> (Int,Int) -- (i,n) = module i of n (for msgs)
- -> IO (Either ModIface (ModIface, Maybe Fingerprint))
-genericHscMergeRequirement mHscMessage
- hsc_env mod_summary mb_old_iface mod_index = do
- let msg what = case mHscMessage of
- Just hscMessage ->
- hscMessage hsc_env mod_index what mod_summary
- Nothing -> return ()
-
- skip iface = do
- msg UpToDate
- return (Left iface)
-
- -- TODO: hook this
- compile mb_old_hash reason = do
- msg reason
- r <- hscMergeFrontEnd hsc_env mod_summary
- return $ Right (r, mb_old_hash)
-
- (recomp_reqd, mb_checked_iface)
- <- {-# SCC "checkOldIface" #-}
- checkOldIface hsc_env mod_summary
- SourceUnmodified mb_old_iface
- case mb_checked_iface of
- Just iface | not (recompileRequired recomp_reqd) -> skip iface
- _ -> compile (fmap mi_iface_hash mb_checked_iface) recomp_reqd
-
--- | This function runs 'genericHscFrontend' if recompilation is necessary.
--- It does not write out the results of typechecking (see 'compileOne').
-genericHscCompileGetFrontendResult ::
- Bool -- always do basic recompilation check?
- -> Maybe TcGblEnv
- -> Maybe Messager
- -> HscEnv
- -> ModSummary
- -> SourceModified
- -> Maybe ModIface -- Old interface, if available
- -> (Int,Int) -- (i,n) = module i of n (for msgs)
- -> IO (Either ModIface (TcGblEnv, Maybe Fingerprint))
-
-genericHscCompileGetFrontendResult
+-- | This function runs GHC's frontend with recompilation
+-- avoidance. Specifically, it checks if recompilation is needed,
+-- and if it is, it parses and typechecks the input module.
+-- It does not write out the results of typechecking (See
+-- compileOne and hscIncrementalCompile).
+hscIncrementalFrontend :: Bool -- always do basic recompilation check?
+ -> Maybe TcGblEnv
+ -> Maybe Messager
+ -> ModSummary
+ -> SourceModified
+ -> Maybe ModIface -- Old interface, if available
+ -> (Int,Int) -- (i,n) = module i of n (for msgs)
+ -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
+
+hscIncrementalFrontend
always_do_basic_recompilation_check m_tc_result
- mHscMessage hsc_env mod_summary source_modified mb_old_iface mod_index
+ mHscMessage mod_summary source_modified mb_old_iface mod_index
= do
+ hsc_env <- getHscEnv
let msg what = case mHscMessage of
Just hscMessage -> hscMessage hsc_env mod_index what mod_summary
Nothing -> return ()
skip iface = do
- msg UpToDate
+ liftIO $ msg UpToDate
return $ Left iface
compile mb_old_hash reason = do
- msg reason
- tc_result <- runHsc hsc_env $ genericHscFrontend mod_summary
- return $ Right (tc_result, mb_old_hash)
+ liftIO $ msg reason
+ result <- genericHscFrontend mod_summary
+ return $ Right (result, mb_old_hash)
stable = case source_modified of
SourceUnmodifiedAndStable -> True
@@ -588,11 +555,11 @@ genericHscCompileGetFrontendResult
case m_tc_result of
Just tc_result
| not always_do_basic_recompilation_check ->
- return $ Right (tc_result, Nothing)
+ return $ Right (FrontendTypecheck tc_result, Nothing)
_ -> do
(recomp_reqd, mb_checked_iface)
<- {-# SCC "checkOldIface" #-}
- checkOldIface hsc_env mod_summary
+ liftIO $ checkOldIface hsc_env mod_summary
source_modified mb_old_iface
-- save the interface that comes back from checkOldIface.
-- In one-shot mode we don't have the old iface until this
@@ -624,101 +591,149 @@ genericHscCompileGetFrontendResult
case m_tc_result of
Nothing -> compile mb_old_hash recomp_reqd
Just tc_result ->
- return $ Right (tc_result, mb_old_hash)
+ return $ Right (FrontendTypecheck tc_result, mb_old_hash)
-genericHscFrontend :: ModSummary -> Hsc TcGblEnv
+genericHscFrontend :: ModSummary -> Hsc FrontendResult
genericHscFrontend mod_summary =
getHooked hscFrontendHook genericHscFrontend' >>= ($ mod_summary)
-genericHscFrontend' :: ModSummary -> Hsc TcGblEnv
-genericHscFrontend' mod_summary = hscFileFrontEnd mod_summary
+genericHscFrontend' :: ModSummary -> Hsc FrontendResult
+genericHscFrontend' mod_summary
+ | ms_hsc_src mod_summary == HsBootMerge
+ = FrontendMerge `fmap` hscMergeFrontEnd mod_summary
+ | otherwise
+ = FrontendTypecheck `fmap` hscFileFrontEnd mod_summary
--------------------------------------------------------------
-- Compilers
--------------------------------------------------------------
-hscCompileOneShot :: HscEnv
- -> ModSummary
- -> SourceModified
- -> IO HscStatus
-hscCompileOneShot env =
- lookupHook hscCompileOneShotHook hscCompileOneShot' (hsc_dflags env) env
-
-- Compile Haskell/boot in OneShot mode.
-hscCompileOneShot' :: HscEnv
- -> ModSummary
- -> SourceModified
- -> IO HscStatus
-hscCompileOneShot' hsc_env mod_summary src_changed
+hscIncrementalCompile :: Bool
+ -> Maybe TcGblEnv
+ -> Maybe Messager
+ -> HscEnv
+ -> ModSummary
+ -> SourceModified
+ -> Maybe ModIface
+ -> (Int,Int)
+ -- HomeModInfo does not contain linkable, since we haven't
+ -- code-genned yet
+ -> IO (HscStatus, HomeModInfo)
+hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
+ mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index
= do
-- One-shot mode needs a knot-tying mutable variable for interface
-- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
type_env_var <- newIORef emptyNameEnv
let mod = ms_mod mod_summary
- hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
-
- msg what = oneShotMsg hsc_env' what
+ hsc_env = hsc_env'{ hsc_type_env_var = Just (mod, type_env_var) }
- skip = do msg UpToDate
- dumpIfaceStats hsc_env'
- return HscUpToDate
+ -- NB: enter Hsc monad here so that we don't bail out early with
+ -- -Werror on typechecker warnings; we also want to run the desugarer
+ -- to get those warnings too. (But we'll always exit at that point
+ -- because the desugarer runs ioMsgMaybe.)
+ runHsc hsc_env $ do
+ let dflags = hsc_dflags hsc_env
- compile mb_old_hash reason = runHsc hsc_env' $ do
- liftIO $ msg reason
- tc_result <- genericHscFrontend mod_summary
- guts0 <- hscDesugar' (ms_location mod_summary) tc_result
- dflags <- getDynFlags
+ e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage
+ mod_summary source_modified mb_old_iface mod_index
+ case e of
+ Left iface -> do
+ details <- liftIO $ genModDetails hsc_env iface
+ return (HscUpToDate, HomeModInfo{
+ hm_details = details,
+ hm_iface = iface,
+ hm_linkable = Nothing
+ })
+ Right (result, mb_old_hash) -> do
+ (status, hmi, no_change) <- case result of
+ FrontendTypecheck tc_result ->
+ if hscTarget dflags /= HscNothing &&
+ ms_hsc_src mod_summary == HsSrcFile
+ then finish hsc_env mod_summary tc_result mb_old_hash
+ else finishTypecheckOnly hsc_env mod_summary tc_result mb_old_hash
+ FrontendMerge raw_iface ->
+ finishMerge hsc_env mod_summary raw_iface mb_old_hash
+ liftIO $ hscMaybeWriteIface dflags (hm_iface hmi) no_change mod_summary
+ return (status, hmi)
+
+-- Generates and writes out the final interface for an hs-boot merge.
+finishMerge :: HscEnv
+ -> ModSummary
+ -> ModIface
+ -> Maybe Fingerprint
+ -> Hsc (HscStatus, HomeModInfo, Bool)
+finishMerge hsc_env summary iface0 mb_old_hash = do
+ MASSERT( ms_hsc_src summary == HsBootMerge )
+ (iface, changed) <- liftIO $ mkIfaceDirect hsc_env mb_old_hash iface0
+ details <- liftIO $ genModDetails hsc_env iface
+ let dflags = hsc_dflags hsc_env
+ hsc_status =
case hscTarget dflags of
- HscNothing -> do
- when (gopt Opt_WriteInterface dflags) $ liftIO $ do
- (iface, changed, _details) <- hscSimpleIface hsc_env tc_result mb_old_hash
- hscWriteIface dflags iface changed mod_summary
- return HscNotGeneratingCode
- _ ->
- case ms_hsc_src mod_summary of
- HsBootFile ->
- do (iface, changed, _) <- hscSimpleIface' tc_result mb_old_hash
- liftIO $ hscWriteIface dflags iface changed mod_summary
- return HscUpdateBoot
- HsSrcFile ->
- do guts <- hscSimplify' guts0
- (iface, changed, _details, cgguts) <- hscNormalIface' guts mb_old_hash
- liftIO $ hscWriteIface dflags iface changed mod_summary
- return $ HscRecomp cgguts mod_summary
- HsBootMerge -> panic "hscCompileOneShot HsBootMerge"
-
- -- XXX This is always False, because in one-shot mode the
- -- concept of stability does not exist. The driver never
- -- passes SourceUnmodifiedAndStable in here.
- stable = case src_changed of
- SourceUnmodifiedAndStable -> True
- _ -> False
-
- (recomp_reqd, mb_checked_iface)
- <- {-# SCC "checkOldIface" #-}
- checkOldIface hsc_env' mod_summary src_changed Nothing
- -- save the interface that comes back from checkOldIface.
- -- In one-shot mode we don't have the old iface until this
- -- point, when checkOldIface reads it from the disk.
- let mb_old_hash = fmap mi_iface_hash mb_checked_iface
-
- case mb_checked_iface of
- Just iface | not (recompileRequired recomp_reqd) ->
- -- If the module used TH splices when it was last compiled,
- -- then the recompilation check is not accurate enough (#481)
- -- and we must ignore it. However, if the module is stable
- -- (none of the modules it depends on, directly or indirectly,
- -- changed), then we *can* skip recompilation. This is why
- -- the SourceModified type contains SourceUnmodifiedAndStable,
- -- and it's pretty important: otherwise ghc --make would
- -- always recompile TH modules, even if nothing at all has
- -- changed. Stability is just the same check that make is
- -- doing for us in one-shot mode.
- if mi_used_th iface && not stable
- then compile mb_old_hash (RecompBecause "TH")
- else skip
- _ ->
- compile mb_old_hash recomp_reqd
+ HscNothing -> HscNotGeneratingCode
+ _ -> HscUpdateBootMerge
+ return (hsc_status,
+ HomeModInfo{ hm_details = details,
+ hm_iface = iface,
+ hm_linkable = Nothing },
+ changed)
+
+-- Generates and writes out the final interface for a typecheck.
+finishTypecheckOnly :: HscEnv
+ -> ModSummary
+ -> TcGblEnv
+ -> Maybe Fingerprint
+ -> Hsc (HscStatus, HomeModInfo, Bool)
+finishTypecheckOnly hsc_env summary tc_result mb_old_hash = do
+ let dflags = hsc_dflags hsc_env
+ MASSERT( hscTarget dflags == HscNothing || ms_hsc_src summary == HsBootFile )
+ (iface, changed, details) <- liftIO $ hscSimpleIface hsc_env tc_result mb_old_hash
+ let hsc_status =
+ case (hscTarget dflags, ms_hsc_src summary) of
+ (HscNothing, _) -> HscNotGeneratingCode
+ (_, HsBootFile) -> HscUpdateBoot
+ _ -> panic "finishTypecheckOnly"
+ return (hsc_status,
+ HomeModInfo{ hm_details = details,
+ hm_iface = iface,
+ hm_linkable = Nothing },
+ changed)
+
+-- Runs the post-typechecking frontend (desugar and simplify),
+-- and then generates and writes out the final interface. We want
+-- to write the interface AFTER simplification so we can get
+-- as up-to-date and good unfoldings and other info as possible
+-- in the interface file. This is only ever run for HsSrcFile,
+-- and NOT for HscNothing.
+finish :: HscEnv
+ -> ModSummary
+ -> TcGblEnv
+ -> Maybe Fingerprint
+ -> Hsc (HscStatus, HomeModInfo, Bool)
+finish hsc_env summary tc_result mb_old_hash = do
+ let dflags = hsc_dflags hsc_env
+ MASSERT( ms_hsc_src summary == HsSrcFile )
+ MASSERT( hscTarget dflags /= HscNothing )
+ guts0 <- hscDesugar' (ms_location summary) tc_result
+ guts <- hscSimplify' guts0
+ (iface, changed, details, cgguts) <- liftIO $ hscNormalIface hsc_env guts mb_old_hash
+
+ return (HscRecomp cgguts summary,
+ HomeModInfo{ hm_details = details,
+ hm_iface = iface,
+ hm_linkable = Nothing },
+ changed)
+
+hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
+hscMaybeWriteIface dflags iface changed summary =
+ let force_write_interface = gopt Opt_WriteInterface dflags
+ write_interface = case hscTarget dflags of
+ HscNothing -> False
+ HscInterpreted -> False
+ _ -> True
+ in when (write_interface || force_write_interface) $
+ hscWriteIface dflags iface changed summary
--------------------------------------------------------------
-- NoRecomp handlers
@@ -768,8 +783,9 @@ batchMsg hsc_env mod_index recomp mod_summary =
-- | Given an 'HsBootMerge' 'ModSummary', merges all @hs-boot@ files
-- under this module name into a composite, publically visible 'ModIface'.
-hscMergeFrontEnd :: HscEnv -> ModSummary -> IO ModIface
-hscMergeFrontEnd hsc_env mod_summary = do
+hscMergeFrontEnd :: ModSummary -> Hsc ModIface
+hscMergeFrontEnd mod_summary = do
+ hsc_env <- getHscEnv
MASSERT( ms_hsc_src mod_summary == HsBootMerge )
let dflags = hsc_dflags hsc_env
-- TODO: actually merge in signatures from external packages.
@@ -783,7 +799,7 @@ hscMergeFrontEnd hsc_env mod_summary = do
iface0 <- case lookupHptByModule hpt mod of
Just hm -> return (hm_iface hm)
Nothing -> do
- mb_iface0 <- initIfaceCheck hsc_env
+ mb_iface0 <- liftIO . initIfaceCheck hsc_env
$ findAndReadIface (text "merge-requirements")
mod is_boot
case mb_iface0 of
@@ -949,7 +965,7 @@ checkSafeImports dflags tcg_env
impInfo = tcg_imports tcg_env -- ImportAvails
imports = imp_mods impInfo -- ImportedMods
imports' = moduleEnvToList imports -- (Module, [ImportedModsVal])
- pkgReqs = imp_trust_pkgs impInfo -- [PackageKey]
+ pkgReqs = imp_trust_pkgs impInfo -- [UnitId]
condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
condense (_, []) = panic "HscMain.condense: Pattern match failure!"
@@ -992,7 +1008,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, [PackageKey])
+hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [UnitId])
hscGetSafe hsc_env m l = runHsc hsc_env $ do
dflags <- getDynFlags
(self, pkgs) <- hscCheckSafe' dflags m l
@@ -1006,15 +1022,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 PackageKey, [PackageKey])
+hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe UnitId, [UnitId])
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 $ modulePackageKey m, pkgs)
+ | otherwise -> return (Just $ moduleUnitId m, pkgs)
where
- isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageKey])
+ isModSafe :: Module -> SrcSpan -> Hsc (Bool, [UnitId])
isModSafe m l = do
iface <- lookup' m
case iface of
@@ -1046,7 +1062,7 @@ hscCheckSafe' dflags m l = do
pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
sep [ ppr (moduleName m)
<> text ": Can't be safely imported!"
- , text "The package (" <> ppr (modulePackageKey m)
+ , text "The package (" <> ppr (moduleUnitId m)
<> text ") the module resides in isn't trusted."
]
modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
@@ -1066,7 +1082,7 @@ hscCheckSafe' dflags m l = do
packageTrusted Sf_Safe False _ = True
packageTrusted _ _ m
| isHomePkg m = True
- | otherwise = trusted $ getPackageDetails dflags (modulePackageKey m)
+ | otherwise = trusted $ getPackageDetails dflags (moduleUnitId m)
lookup' :: Module -> Hsc (Maybe ModIface)
lookup' m = do
@@ -1090,11 +1106,11 @@ hscCheckSafe' dflags m l = do
isHomePkg :: Module -> Bool
isHomePkg m
- | thisPackage dflags == modulePackageKey m = True
+ | thisPackage dflags == moduleUnitId m = True
| otherwise = False
-- | Check the list of packages are trusted.
-checkPkgTrust :: DynFlags -> [PackageKey] -> Hsc ()
+checkPkgTrust :: DynFlags -> [UnitId] -> Hsc ()
checkPkgTrust dflags pkgs =
case errors of
[] -> return ()
@@ -1200,7 +1216,7 @@ hscSimpleIface' tc_result mb_old_iface = do
safe_mode <- hscGetSafeMode tc_result
(new_iface, no_change)
<- {-# SCC "MkFinalIface" #-}
- ioMsgMaybe $
+ liftIO $
mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result
-- And the answer is ...
liftIO $ dumpIfaceStats hsc_env
@@ -1228,7 +1244,7 @@ hscNormalIface' simpl_result mb_old_iface = do
-- until after code output
(new_iface, no_change)
<- {-# SCC "MkFinalIface" #-}
- ioMsgMaybe $
+ liftIO $
mkIface hsc_env mb_old_iface details simpl_result
liftIO $ dumpIfaceStats hsc_env
@@ -1508,7 +1524,7 @@ hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
handleWarnings
-- Then code-gen, and link it
- -- It's important NOT to have package 'interactive' as thisPackageKey
+ -- It's important NOT to have package 'interactive' as thisUnitId
-- 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.hs b/compiler/main/HscTypes.hs
index ce5d37f00a..317a9413ec 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -451,7 +451,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 key cached here for convenience
+ -- "home" unit id cached here for convenience
-- | Helps us find information about modules in the imported packages
type PackageIfaceTable = ModuleEnv ModIface
@@ -683,7 +683,7 @@ type FinderCache = ModuleEnv FindResult
data FindResult
= Found ModLocation Module
-- ^ The module was found
- | NoPackage PackageKey
+ | NoPackage UnitId
-- ^ The requested package was not found
| FoundMultiple [(Module, ModuleOrigin)]
-- ^ _Error_: both in multiple packages
@@ -692,14 +692,14 @@ data FindResult
| NotFound
{ fr_paths :: [FilePath] -- Places where I looked
- , fr_pkg :: Maybe PackageKey -- Just p => module is in this package's
+ , fr_pkg :: Maybe UnitId -- Just p => module is in this package's
-- manifest, but couldn't find
-- the .hi file
- , fr_mods_hidden :: [PackageKey] -- Module is in these packages,
+ , fr_mods_hidden :: [UnitId] -- Module is in these packages,
-- but the *module* is hidden
- , fr_pkgs_hidden :: [PackageKey] -- Module is in these packages,
+ , fr_pkgs_hidden :: [UnitId] -- Module is in these packages,
-- but the *package* is hidden
, fr_suggestions :: [ModuleSuggestion] -- Possible mis-spelled modules
@@ -1123,7 +1123,7 @@ data CgGuts
-- as part of the code-gen of tycons
cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs
- cg_dep_pkgs :: ![PackageKey], -- ^ Dependent packages, used to
+ cg_dep_pkgs :: ![UnitId], -- ^ Dependent packages, used to
-- generate #includes for C code gen
cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information
cg_modBreaks :: !ModBreaks -- ^ Module breakpoints
@@ -1162,7 +1162,7 @@ as if they were defined in modules
interactive:Ghci2
...etc...
with each bunch of declarations using a new module, all sharing a
-common package 'interactive' (see Module.interactivePackageKey, and
+common package 'interactive' (see Module.interactiveUnitId, and
PrelNames.mkInteractiveModule).
This scheme deals well with shadowing. For example:
@@ -1454,7 +1454,7 @@ shadowed_by ids = shadowed
setInteractivePackage :: HscEnv -> HscEnv
-- Set the 'thisPackage' DynFlag to 'interactive'
setInteractivePackage hsc_env
- = hsc_env { hsc_dflags = (hsc_dflags hsc_env) { thisPackage = interactivePackageKey } }
+ = hsc_env { hsc_dflags = (hsc_dflags hsc_env) { thisPackage = interactiveUnitId } }
setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext
setInteractivePrintName ic n = ic{ic_int_print = n}
@@ -1538,20 +1538,13 @@ 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]
+Note [Printing unit ids]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.
+UnitId, the situation can be different: if the key is instantiated with
+some holes, we should try to give the user some more useful information.
-}
-- | Creates some functions that work out the best ways to format
@@ -1563,7 +1556,7 @@ mkPrintUnqualified dflags env = QueryQualify qual_name
where
qual_name mod occ
| [] <- unqual_gres
- , modulePackageKey mod `elem` [primPackageKey, basePackageKey, thPackageKey]
+ , moduleUnitId mod `elem` [primUnitId, baseUnitId, thUnitId]
, not (isDerivedOccName occ)
= NameUnqual -- For names from ubiquitous packages that come with GHC, if
-- there are no entities called unqualified 'occ', then
@@ -1609,10 +1602,10 @@ mkPrintUnqualified dflags env = QueryQualify qual_name
-- is only one exposed package which exports this module, don't qualify.
mkQualModule :: DynFlags -> QueryQualifyModule
mkQualModule dflags mod
- | modulePackageKey mod == thisPackage dflags = False
+ | moduleUnitId mod == thisPackage dflags = False
| [(_, pkgconfig)] <- lookup,
- packageConfigId pkgconfig == modulePackageKey mod
+ packageConfigId pkgconfig == moduleUnitId 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
@@ -1622,10 +1615,10 @@ mkQualModule dflags 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.
+-- with a unit id if the package ID would be ambiguous.
mkQualPackage :: DynFlags -> QueryQualifyPackage
mkQualPackage dflags pkg_key
- | pkg_key == mainPackageKey || pkg_key == interactivePackageKey
+ | pkg_key == mainUnitId || pkg_key == interactiveUnitId
-- Skip the lookup if it's main, since it won't be in the package
-- database!
= False
@@ -2085,7 +2078,7 @@ data Dependencies
-- I.e. modules that this one imports, or that are in the
-- dep_mods of those directly-imported modules
- , dep_pkgs :: [(PackageKey, Bool)]
+ , dep_pkgs :: [(UnitId, 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
@@ -2407,9 +2400,9 @@ data ModSummary
-- ^ Timestamp of hi file, if we *only* are typechecking (it is
-- 'Nothing' otherwise.
-- See Note [Recompilation checking when typechecking only] and #9243
- ms_srcimps :: [Located (ImportDecl RdrName)],
+ ms_srcimps :: [(Maybe FastString, Located ModuleName)],
-- ^ Source imports of the module
- ms_textual_imps :: [Located (ImportDecl RdrName)],
+ ms_textual_imps :: [(Maybe FastString, Located ModuleName)],
-- ^ Non-source imports of the module from the module *text*
ms_merge_imps :: (Bool, [Module]),
-- ^ Non-textual imports computed for HsBootMerge
@@ -2425,26 +2418,12 @@ data ModSummary
ms_mod_name :: ModSummary -> ModuleName
ms_mod_name = moduleName . ms_mod
-ms_imps :: ModSummary -> [Located (ImportDecl RdrName)]
+ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_imps ms =
ms_textual_imps ms ++
map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms))
where
- -- This is a not-entirely-satisfactory means of creating an import
- -- that corresponds to an import that did not occur in the program
- -- text, such as those induced by the use of plugins (the -plgFoo
- -- flag)
- mk_additional_import mod_nm = noLoc $ ImportDecl {
- ideclSourceSrc = Nothing,
- ideclName = noLoc mod_nm,
- ideclPkgQual = Nothing,
- ideclSource = False,
- ideclImplicit = True, -- Maybe implicit because not "in the program text"
- ideclQualified = False,
- ideclAs = Nothing,
- ideclHiding = Nothing,
- ideclSafe = False
- }
+ mk_additional_import mod_nm = (Nothing, noLoc mod_nm)
-- The ModLocation contains both the original source filename and the
-- filename of the cleaned-up source file after all preprocessing has been
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 6b0c4851e1..2b2fdaf9e8 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -927,7 +927,7 @@ getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
-- its full top-level scope available.
moduleIsInterpreted :: GhcMonad m => Module -> m Bool
moduleIsInterpreted modl = withSession $ \h ->
- if modulePackageKey modl /= thisPackage (hsc_dflags h)
+ if moduleUnitId 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 71a84d8622..3fdb0af1d3 100644
--- a/compiler/main/PackageConfig.hs
+++ b/compiler/main/PackageConfig.hs
@@ -9,23 +9,18 @@
module PackageConfig (
-- $package_naming
- -- * PackageKey
+ -- * UnitId
packageConfigId,
- -- * LibraryName
- LibraryName(..),
-
-- * The PackageConfig type: information about a package
PackageConfig,
InstalledPackageInfo(..),
- InstalledPackageId(..),
+ ComponentId(..),
SourcePackageId(..),
PackageName(..),
- UnitName(..),
Version(..),
- packageUnitName,
defaultPackageConfig,
- installedPackageIdString,
+ componentIdString,
sourcePackageIdString,
packageNameString,
pprPackageConfig,
@@ -42,29 +37,27 @@ import Module
import Unique
-- -----------------------------------------------------------------------------
--- Our PackageConfig type is the InstalledPackageInfo from bin-package-db,
+-- Our PackageConfig type is the InstalledPackageInfo from ghc-boot,
-- which is similar to a subset of the InstalledPackageInfo type from Cabal.
type PackageConfig = InstalledPackageInfo
- InstalledPackageId
+ ComponentId
SourcePackageId
PackageName
- Module.PackageKey
+ Module.UnitId
Module.ModuleName
-- TODO: there's no need for these to be FastString, as we don't need the uniq
-- feature, but ghc doesn't currently have convenient support for any
-- other compact string types, e.g. plain ByteString or Text.
-newtype InstalledPackageId = InstalledPackageId FastString deriving (Eq, Ord)
+newtype ComponentId = ComponentId FastString deriving (Eq, Ord)
newtype SourcePackageId = SourcePackageId FastString deriving (Eq, Ord)
newtype PackageName = PackageName FastString deriving (Eq, Ord)
-newtype UnitName = UnitName FastString deriving (Eq, Ord)
-newtype LibraryName = LibraryName FastString deriving (Eq, Ord)
-instance BinaryStringRep InstalledPackageId where
- fromStringRep = InstalledPackageId . mkFastStringByteString
- toStringRep (InstalledPackageId s) = fastStringToByteString s
+instance BinaryStringRep ComponentId where
+ fromStringRep = ComponentId . mkFastStringByteString
+ toStringRep (ComponentId s) = fastStringToByteString s
instance BinaryStringRep SourcePackageId where
fromStringRep = SourcePackageId . mkFastStringByteString
@@ -74,12 +67,8 @@ instance BinaryStringRep PackageName where
fromStringRep = PackageName . mkFastStringByteString
toStringRep (PackageName s) = fastStringToByteString s
-instance BinaryStringRep LibraryName where
- fromStringRep = LibraryName . mkFastStringByteString
- toStringRep (LibraryName s) = fastStringToByteString s
-
-instance Uniquable InstalledPackageId where
- getUnique (InstalledPackageId n) = getUnique n
+instance Uniquable ComponentId where
+ getUnique (ComponentId n) = getUnique n
instance Uniquable SourcePackageId where
getUnique (SourcePackageId n) = getUnique n
@@ -87,14 +76,8 @@ instance Uniquable SourcePackageId where
instance Uniquable PackageName where
getUnique (PackageName n) = getUnique n
-instance Outputable InstalledPackageId where
- ppr (InstalledPackageId str) = ftext str
-
-instance Outputable UnitName where
- ppr (UnitName str) = ftext str
-
-instance Outputable LibraryName where
- ppr (LibraryName str) = ftext str
+instance Outputable ComponentId where
+ ppr (ComponentId str) = ftext str
instance Outputable SourcePackageId where
ppr (SourcePackageId str) = ftext str
@@ -124,10 +107,10 @@ pprOriginalModule (OriginalModule originalPackageId originalModuleName) =
defaultPackageConfig :: PackageConfig
defaultPackageConfig = emptyInstalledPackageInfo
-installedPackageIdString :: PackageConfig -> String
-installedPackageIdString pkg = unpackFS str
+componentIdString :: PackageConfig -> String
+componentIdString pkg = unpackFS str
where
- InstalledPackageId str = installedPackageId pkg
+ ComponentId str = componentId pkg
sourcePackageIdString :: PackageConfig -> String
sourcePackageIdString pkg = unpackFS str
@@ -144,8 +127,7 @@ pprPackageConfig InstalledPackageInfo {..} =
vcat [
field "name" (ppr packageName),
field "version" (text (showVersion packageVersion)),
- field "id" (ppr installedPackageId),
- field "key" (ppr packageKey),
+ field "id" (ppr componentId),
field "exposed" (ppr exposed),
field "exposed-modules"
(if all isExposedModule exposedModules
@@ -175,20 +157,16 @@ pprPackageConfig InstalledPackageInfo {..} =
-- -----------------------------------------------------------------------------
--- PackageKey (package names, versions and dep hash)
+-- UnitId (package names, versions and dep hash)
-- $package_naming
-- #package_naming#
--- Mostly the compiler deals in terms of 'PackageKey's, which are md5 hashes
+-- Mostly the compiler deals in terms of 'UnitId'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
+-- to pass in the unit id 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#.
--- | Get the GHC 'PackageKey' right out of a Cabalish 'PackageConfig'
-packageConfigId :: PackageConfig -> PackageKey
-packageConfigId = packageKey
-
-packageUnitName :: PackageConfig -> UnitName
-packageUnitName pkg = let PackageName fs = packageName pkg
- in UnitName fs
+-- | Get the GHC 'UnitId' right out of a Cabalish 'PackageConfig'
+packageConfigId :: PackageConfig -> UnitId
+packageConfigId = unitId
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index bb0aba241e..0e32947b31 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -18,7 +18,6 @@ module Packages (
-- * Querying the package config
lookupPackage,
- resolveInstalledPackageId,
searchPackageId,
getPackageDetails,
listVisibleModuleNames,
@@ -41,7 +40,7 @@ module Packages (
packageHsLibs,
-- * Utils
- packageKeyPackageIdString,
+ unitIdPackageIdString,
pprFlag,
pprPackages,
pprPackagesSimple,
@@ -214,18 +213,18 @@ originEmpty :: ModuleOrigin -> Bool
originEmpty (ModOrigin Nothing [] [] False) = True
originEmpty _ = False
--- | 'UniqFM' map from 'PackageKey'
-type PackageKeyMap = UniqFM
+-- | 'UniqFM' map from 'UnitId'
+type UnitIdMap = UniqFM
--- | 'UniqFM' map from 'PackageKey' to 'PackageConfig'
-type PackageConfigMap = PackageKeyMap PackageConfig
+-- | 'UniqFM' map from 'UnitId' to 'PackageConfig'
+type PackageConfigMap = UnitIdMap PackageConfig
--- | 'UniqFM' map from 'PackageKey' to (1) whether or not all modules which
+-- | 'UniqFM' map from 'UnitId' 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)
+ UnitIdMap (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
@@ -234,7 +233,7 @@ type ModuleToPkgConfAll =
Map ModuleName (Map Module ModuleOrigin)
data PackageState = PackageState {
- -- | A mapping of 'PackageKey' to 'PackageConfig'. This list is adjusted
+ -- | A mapping of 'UnitId' to 'PackageConfig'. This list is adjusted
-- so that only valid packages are here. 'PackageConfig' reflects
-- what was stored *on disk*, except for the 'trusted' flag, which
-- is adjusted at runtime. (In particular, some packages in this map
@@ -244,39 +243,32 @@ data PackageState = PackageState {
-- | 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],
+ preloadPackages :: [UnitId],
-- | 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
+ moduleToPkgConfAll :: ModuleToPkgConfAll
}
emptyPackageState :: PackageState
emptyPackageState = PackageState {
pkgIdMap = emptyUFM,
preloadPackages = [],
- moduleToPkgConfAll = Map.empty,
- installedPackageIdMap = Map.empty
+ moduleToPkgConfAll = Map.empty
}
-type InstalledPackageIdMap = Map InstalledPackageId PackageKey
-type InstalledPackageIndex = Map InstalledPackageId PackageConfig
+type InstalledPackageIndex = Map UnitId PackageConfig
-- | Empty package configuration map
emptyPackageConfigMap :: PackageConfigMap
emptyPackageConfigMap = emptyUFM
-- | Find the package we know about with the given key (e.g. @foo_HASH@), if any
-lookupPackage :: DynFlags -> PackageKey -> Maybe PackageConfig
+lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig
lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags))
-lookupPackage' :: PackageConfigMap -> PackageKey -> Maybe PackageConfig
+lookupPackage' :: PackageConfigMap -> UnitId -> Maybe PackageConfig
lookupPackage' = lookupUFM
-- | Search for packages with a given package ID (e.g. \"foo-0.1\")
@@ -293,7 +285,7 @@ extendPackageConfigMap pkg_map new_pkgs
-- | Looks up the package with the given id in the package state, panicing if it is
-- not found
-getPackageDetails :: DynFlags -> PackageKey -> PackageConfig
+getPackageDetails :: DynFlags -> UnitId -> PackageConfig
getPackageDetails dflags pid =
expectJust "getPackageDetails" (lookupPackage dflags pid)
@@ -304,12 +296,6 @@ getPackageDetails dflags pid =
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
@@ -326,7 +312,7 @@ resolveInstalledPackageId dflags ipid =
-- '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, [PackageKey])
+initPackages :: DynFlags -> IO (DynFlags, [UnitId])
initPackages dflags = do
pkg_db <- case pkgDatabase dflags of
Nothing -> readPackageConfigs dflags
@@ -563,15 +549,15 @@ matchingStr str p
|| str == packageNameString p
matchingId :: String -> PackageConfig -> Bool
-matchingId str p = str == installedPackageIdString p
+matchingId str p = str == componentIdString p
matchingKey :: String -> PackageConfig -> Bool
-matchingKey str p = str == packageKeyString (packageConfigId p)
+matchingKey str p = str == unitIdString (packageConfigId p)
matching :: PackageArg -> PackageConfig -> Bool
matching (PackageArg str) = matchingStr str
matching (PackageIdArg str) = matchingId str
-matching (PackageKeyArg str) = matchingKey str
+matching (UnitIdArg str) = matchingKey str
sortByVersion :: [PackageConfig] -> [PackageConfig]
sortByVersion = sortBy (flip (comparing packageVersion))
@@ -602,7 +588,7 @@ packageFlagErr dflags flag reasons
text "(use -v for more information)")
ppr_reasons = vcat (map ppr_reason reasons)
ppr_reason (p, reason) =
- pprReason (ppr (installedPackageId p) <+> text "is") reason
+ pprReason (ppr (unitId p) <+> text "is") reason
pprFlag :: PackageFlag -> SDoc
pprFlag flag = case flag of
@@ -614,7 +600,7 @@ pprFlag flag = case flag of
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
+ UnitIdArg p -> text "-package-key " <> text p
ppr_rns (ModRenaming True []) = Outputable.empty
ppr_rns (ModRenaming b rns) =
if b then text "with" else Outputable.empty <+>
@@ -626,13 +612,15 @@ pprFlag flag = case flag of
-- Wired-in packages
wired_in_pkgids :: [String]
-wired_in_pkgids = map packageKeyString wiredInPackageKeys
+wired_in_pkgids = map unitIdString wiredInUnitIds
+
+type WiredPackagesMap = Map UnitId UnitId
findWiredInPackages
:: DynFlags
-> [PackageConfig] -- database
-> VisibilityMap -- info on what packages are visible
- -> IO ([PackageConfig], VisibilityMap)
+ -> IO ([PackageConfig], VisibilityMap, WiredPackagesMap)
findWiredInPackages dflags pkgs vis_map = do
--
@@ -686,14 +674,14 @@ findWiredInPackages dflags pkgs vis_map = do
ptext (sLit "wired-in package ")
<> text wired_pkg
<> ptext (sLit " mapped to ")
- <> ppr (installedPackageId pkg)
+ <> ppr (unitId pkg)
return (Just pkg)
mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids
let
wired_in_pkgs = catMaybes mb_wired_in_pkgs
- wired_in_ids = map installedPackageId wired_in_pkgs
+ wired_in_ids = map unitId wired_in_pkgs
-- this is old: we used to assume that if there were
-- multiple versions of wired-in packages installed that
@@ -708,32 +696,45 @@ findWiredInPackages dflags pkgs vis_map = do
&& package p `notElem` map fst wired_in_ids
-}
- updateWiredInDependencies pkgs = map upd_pkg pkgs
+ wiredInMap :: Map UnitId UnitId
+ wiredInMap = foldl' add_mapping Map.empty pkgs
+ where add_mapping m pkg
+ | let key = unitId pkg
+ , key `elem` wired_in_ids
+ = Map.insert key (stringToUnitId (packageNameString pkg)) m
+ | otherwise = m
+
+ updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs
where upd_pkg pkg
- | installedPackageId pkg `elem` wired_in_ids
+ | unitId pkg `elem` wired_in_ids
= pkg {
- packageKey = stringToPackageKey (packageNameString pkg)
+ unitId = stringToUnitId (packageNameString pkg)
}
| otherwise
= pkg
+ upd_deps pkg = pkg {
+ depends = map upd_wired_in (depends pkg)
+ }
+ upd_wired_in key
+ | Just key' <- Map.lookup key wiredInMap = key'
+ | otherwise = key
updateVisibilityMap vis_map = foldl' f vis_map wired_in_pkgs
where f vm p = case lookupUFM vis_map (packageConfigId p) of
Nothing -> vm
- Just r -> addToUFM vm (stringToPackageKey
+ Just r -> addToUFM vm (stringToUnitId
(packageNameString p)) r
- return (updateWiredInDependencies pkgs, updateVisibilityMap vis_map)
+ return (updateWiredInDependencies pkgs, updateVisibilityMap vis_map, wiredInMap)
-- ----------------------------------------------------------------------------
data UnusablePackageReason
= IgnoredWithFlag
- | MissingDependencies [InstalledPackageId]
- | ShadowedBy InstalledPackageId
+ | MissingDependencies [UnitId]
-type UnusablePackages = Map InstalledPackageId
+type UnusablePackages = Map UnitId
(PackageConfig, UnusablePackageReason)
pprReason :: SDoc -> UnusablePackageReason -> SDoc
@@ -744,8 +745,6 @@ pprReason pref reason = case reason of
pref <+>
ptext (sLit "unusable due to missing or recursive dependencies:") $$
nest 2 (hsep (map ppr deps))
- ShadowedBy ipid ->
- pref <+> ptext (sLit "shadowed by package ") <> ppr ipid
reportUnusable :: DynFlags -> UnusablePackages -> IO ()
reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
@@ -770,62 +769,31 @@ findBroken pkgs = go [] Map.empty pkgs
go avail ipids not_avail =
case partitionWith (depsAvailable ipids) not_avail of
([], not_avail) ->
- Map.fromList [ (installedPackageId p, (p, MissingDependencies deps))
+ Map.fromList [ (unitId p, (p, MissingDependencies deps))
| (p,deps) <- not_avail ]
(new_avail, not_avail) ->
go (new_avail ++ avail) new_ipids (map fst not_avail)
where new_ipids = Map.insertList
- [ (installedPackageId p, p) | p <- new_avail ]
+ [ (unitId p, p) | p <- new_avail ]
ipids
depsAvailable :: InstalledPackageIndex
-> PackageConfig
- -> Either PackageConfig (PackageConfig, [InstalledPackageId])
+ -> Either PackageConfig (PackageConfig, [UnitId])
depsAvailable ipids pkg
| null dangling = Left pkg
| otherwise = Right (pkg, dangling)
where dangling = filter (not . (`Map.member` ipids)) (depends pkg)
-- -----------------------------------------------------------------------------
--- Eliminate shadowed packages, giving the user some feedback
-
--- later packages in the list should shadow earlier ones with the same
--- package name/version. Additionally, a package may be preferred if
--- it is in the transitive closure of packages selected using -package-id
--- flags.
-type UnusablePackage = (PackageConfig, UnusablePackageReason)
-shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages
-shadowPackages pkgs preferred
- = let (shadowed,_) = foldl check ([],emptyUFM) pkgs
- in Map.fromList shadowed
- where
- check :: ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig)
- -> PackageConfig
- -> ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig)
- check (shadowed,pkgmap) 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, (pkg, ShadowedBy ipid_old)) : shadowed, pkgmap)
- else ((ipid_old, (oldpkg, ShadowedBy ipid_new)) : shadowed, pkgmap')
- | otherwise
- = (shadowed, pkgmap')
- where
- pkgid = packageKeyFS (packageKey pkg)
- pkgmap' = addToUFM pkgmap pkgid pkg
-
--- -----------------------------------------------------------------------------
+-- Ignore packages
ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages
ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
where
doit (IgnorePackage str) =
case partition (matchingStr str) pkgs of
- (ps, _) -> [ (installedPackageId p, (p, IgnoredWithFlag))
+ (ps, _) -> [ (unitId p, (p, IgnoredWithFlag))
| p <- ps ]
-- missing package is not an error for -ignore-package,
-- because a common usage is to -ignore-package P as
@@ -833,115 +801,87 @@ ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
doit _ = panic "ignorePackages"
-- -----------------------------------------------------------------------------
-
-depClosure :: InstalledPackageIndex
- -> [InstalledPackageId]
- -> [InstalledPackageId]
-depClosure index ipids = closure Map.empty ipids
- where
- closure set [] = Map.keys set
- closure set (ipid : ipids)
- | ipid `Map.member` set = closure set ipids
- | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set)
- (depends p ++ ipids)
- | otherwise = closure set ipids
-
--- -----------------------------------------------------------------------------
-- When all the command-line options are in, we can process our package
-- settings and populate the package state.
mkPackageState
:: DynFlags
-> [PackageConfig] -- initial database
- -> [PackageKey] -- preloaded packages
+ -> [UnitId] -- preloaded packages
-> IO (PackageState,
- [PackageKey], -- new packages to preload
- PackageKey) -- this package, might be modified if the current
+ [UnitId], -- new packages to preload
+ UnitId) -- this package, might be modified if the current
-- package is a wired-in package.
mkPackageState dflags0 pkgs0 preload0 = do
dflags <- interpretPackageEnv dflags0
- -- Compute the package key
+ -- Compute the unit id
let this_package = thisPackage dflags
{-
Plan.
- 1. P = transitive closure of packages selected by -package-id
-
- 2. Apply shadowing. When there are multiple packages with the same
- 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 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
- by giving explicit -package-id flags; then we have to take these
- preferences into account when selecting which other packages are
- made available.
-
- Our simple algorithm throws away some solutions: there may be other
- consistent sets that would satisfy the -package flags, but it's
- not GHC's job to be doing constraint solving.
- ]
-
- 3. remove packages selected by -ignore-package
-
- 4. remove any packages with missing dependencies, or mutually recursive
+ 1. When there are multiple packages with the same
+ installed package ID, if they have the same ABI hash, use the one
+ highest in the package stack. Otherwise, error.
+
+ 2. remove packages selected by -ignore-package
+
+ 3. remove any packages with missing dependencies, or mutually recursive
dependencies.
- 5. report (with -v) any packages that were removed by steps 2-4
+ 4. report (with -v) any packages that were removed by steps 2-4
- 6. apply flags to set exposed/hidden on the resulting packages
+ 5. apply flags to set exposed/hidden on the resulting packages
- if any flag refers to a package which was removed by 2-4, then
we can give an error message explaining why
- 7. hide any packages which are superseded by later exposed packages
+ 6. hide any packages which are superseded by later exposed packages
-}
let
- flags = reverse (packageFlags dflags)
-
-- pkgs0 with duplicate packages filtered out. This is
-- important: it is possible for a package in the global package
- -- DB to have the same IPID as a package in the user DB, and
- -- we want the latter to take precedence. This is not the same
- -- as shadowing (below), since in this case the two packages
- -- have the same ABI and are interchangeable.
+ -- DB to have the same key as a package in the user DB, and
+ -- we want the latter to take precedence.
--
- -- #4072: note that we must retain the ordering of the list here
- -- so that shadowing behaves as expected when we apply it later.
- pkgs0_unique = snd $ foldr del (Set.empty,[]) pkgs0
- where del p (s,ps)
- | pid `Set.member` s = (s,ps)
- | otherwise = (Set.insert pid s, p:ps)
- where pid = installedPackageId p
- -- XXX this is just a variant of nub
-
- ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ]
-
- ipid_selected = depClosure ipid_map
- [ InstalledPackageId (mkFastString i)
- | ExposePackage (PackageIdArg i) _ <- flags ]
-
+ -- NB: We have to check that the ABIs of the old and new packages
+ -- are equal; if they are not that's a fatal error.
+ --
+ -- TODO: might be useful to report when this shadowing occurs
+ (_, pkgs0_unique, abis) = foldr del (Set.empty,[],Map.empty) pkgs0
+ where del p (s,ps,a)
+ | key `Set.member` s = (s,ps,a')
+ | otherwise = (Set.insert key s, p:ps, a')
+ where key = unitId p
+ a' = Map.insertWith Set.union key
+ (Set.singleton (abiHash p)) a
+ failed_abis = [ (key, Set.toList as)
+ | (key, as) <- Map.toList abis
+ , Set.size as > 1 ]
+
+ unless (null failed_abis) $ do
+ throwGhcException (CmdLineError (showSDoc dflags
+ (text "package db: duplicate packages with incompatible ABIs:" $$
+ nest 4 (vcat [ ppr key <+> text "has ABIs" <> colon <+>
+ hsep (punctuate comma (map text as))
+ | (key, as) <- failed_abis]))))
+
+ let flags = reverse (packageFlags dflags)
(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
- isBroken = (`Map.member` (Map.union shadowed ignored)).installedPackageId
+ isBroken = (`Map.member` ignored) . unitId
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'
+ unusable = ignored `Map.union` broken
+ pkgs1 = filter (not . (`Map.member` unusable) . unitId) pkgs0'
reportUnusable dflags unusable
@@ -976,11 +916,11 @@ mkPackageState dflags0 pkgs0 preload0 = do
--
-- 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
+ -- it modifies the unit ids of wired in packages, but when we process
-- package arguments we need to key against the old versions. We also
-- have to update the visibility map in the process.
--
- (pkgs3, vis_map) <- findWiredInPackages dflags pkgs2 vis_map2
+ (pkgs3, vis_map, wired_map) <- findWiredInPackages dflags pkgs2 vis_map2
--
-- Here we build up a set of the packages mentioned in -package
@@ -989,7 +929,9 @@ mkPackageState dflags0 pkgs0 preload0 = do
-- should contain at least rts & base, which is why we pretend that
-- the command line contains -package rts & -package base.
--
- let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ]
+ let preload1 = [ let key = unitId p
+ in fromMaybe key (Map.lookup key wired_map)
+ | f <- flags, p <- get_exposed f ]
get_exposed (ExposePackage a _) = take 1 . sortByVersion
. filter (matching a)
@@ -998,21 +940,14 @@ mkPackageState dflags0 pkgs0 preload0 = do
let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs3
- ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p)
- | p <- pkgs3 ]
-
- lookupIPID ipid
- | Just pid <- Map.lookup ipid ipid_map = return pid
- | otherwise = missingPackageErr dflags ipid
-
- preload2 <- mapM lookupIPID preload1
+ let preload2 = preload1
let
-- add base & rts to the preload packages
basicLinkedPackages
| gopt Opt_AutoLinkPackages dflags
= filter (flip elemUFM pkg_db)
- [basePackageKey, rtsPackageKey]
+ [baseUnitId, rtsUnitId]
| 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
@@ -1021,14 +956,13 @@ mkPackageState dflags0 pkgs0 preload0 = do
$ (basicLinkedPackages ++ preload2)
-- Close the preload packages with their dependencies
- dep_preload <- closeDeps dflags pkg_db ipid_map (zip preload3 (repeat Nothing))
+ dep_preload <- closeDeps dflags pkg_db (zip preload3 (repeat Nothing))
let new_dep_preload = filter (`notElem` preload0) dep_preload
let pstate = PackageState{
preloadPackages = dep_preload,
pkgIdMap = pkg_db,
- moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map,
- installedPackageIdMap = ipid_map
+ moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db vis_map
}
return (pstate, new_dep_preload, this_package)
@@ -1039,10 +973,9 @@ mkPackageState dflags0 pkgs0 preload0 = do
mkModuleToPkgConfAll
:: DynFlags
-> PackageConfigMap
- -> InstalledPackageIdMap
-> VisibilityMap
-> ModuleToPkgConfAll
-mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map =
+mkModuleToPkgConfAll dflags pkg_db vis_map =
foldl' extend_modmap emptyMap (eltsUFM pkg_db)
where
emptyMap = Map.empty
@@ -1078,9 +1011,8 @@ mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map =
let (pk', m', pkg', origin') =
case exposedReexport of
Nothing -> (pk, m, pkg, fromExposedModules e)
- Just (OriginalModule ipid' m') ->
- let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map)
- pkg' = pkg_lookup pk'
+ Just (OriginalModule pk' m') ->
+ let pkg' = pkg_lookup pk'
in (pk', m', pkg', fromReexportedModules e pkg')
return (m, sing pk' m' pkg' origin')
@@ -1108,7 +1040,7 @@ mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map =
-- use.
-- | Find all the include directories in these and the preload packages
-getPackageIncludePath :: DynFlags -> [PackageKey] -> IO [String]
+getPackageIncludePath :: DynFlags -> [UnitId] -> IO [String]
getPackageIncludePath dflags pkgs =
collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs
@@ -1116,7 +1048,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 -> [PackageKey] -> IO [String]
+getPackageLibraryPath :: DynFlags -> [UnitId] -> IO [String]
getPackageLibraryPath dflags pkgs =
collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs
@@ -1125,7 +1057,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 -> [PackageKey] -> IO ([String], [String], [String])
+getPackageLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String])
getPackageLinkOpts dflags pkgs =
collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs
@@ -1174,19 +1106,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 -> [PackageKey] -> IO [String]
+getPackageExtraCcOpts :: DynFlags -> [UnitId] -> 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 -> [PackageKey] -> IO [String]
+getPackageFrameworkPath :: DynFlags -> [UnitId] -> 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 -> [PackageKey] -> IO [String]
+getPackageFrameworks :: DynFlags -> [UnitId] -> IO [String]
getPackageFrameworks dflags pkgs = do
ps <- getPreloadPackagesAnd dflags pkgs
return (concatMap frameworks ps)
@@ -1204,7 +1136,7 @@ lookupModuleInAllPackages dflags m
LookupFound a b -> [(a,b)]
LookupMultiple rs -> map f rs
where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags
- (modulePackageKey m)))
+ (moduleUnitId m)))
_ -> []
-- | The result of performing a lookup
@@ -1248,7 +1180,7 @@ lookupModuleWithSuggestions dflags m mb_pn
pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags
pkg_state = pkgState dflags
- mod_pkg = pkg_lookup . modulePackageKey
+ mod_pkg = pkg_lookup . moduleUnitId
-- Filters out origins which are not associated with the given package
-- qualifier. No-op if there is no package qualifier. Test if this
@@ -1293,27 +1225,25 @@ listVisibleModuleNames dflags =
-- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
-- 'PackageConfig's
-getPreloadPackagesAnd :: DynFlags -> [PackageKey] -> IO [PackageConfig]
+getPreloadPackagesAnd :: DynFlags -> [UnitId] -> IO [PackageConfig]
getPreloadPackagesAnd dflags pkgids =
let
state = pkgState dflags
pkg_map = pkgIdMap state
- ipid_map = installedPackageIdMap state
preload = preloadPackages state
pairs = zip pkgids (repeat Nothing)
in do
- all_pkgs <- throwErr dflags (foldM (add_package pkg_map ipid_map) preload pairs)
+ all_pkgs <- throwErr dflags (foldM (add_package pkg_map) preload pairs)
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 PackageKey
- -> [(PackageKey, Maybe PackageKey)]
- -> IO [PackageKey]
-closeDeps dflags pkg_map ipid_map ps
- = throwErr dflags (closeDepsErr pkg_map ipid_map ps)
+ -> [(UnitId, Maybe UnitId)]
+ -> IO [UnitId]
+closeDeps dflags pkg_map ps
+ = throwErr dflags (closeDepsErr pkg_map ps)
throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
throwErr dflags m
@@ -1322,18 +1252,16 @@ throwErr dflags m
Succeeded r -> return r
closeDepsErr :: PackageConfigMap
- -> Map InstalledPackageId PackageKey
- -> [(PackageKey,Maybe PackageKey)]
- -> MaybeErr MsgDoc [PackageKey]
-closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps
+ -> [(UnitId,Maybe UnitId)]
+ -> MaybeErr MsgDoc [UnitId]
+closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps
-- internal helper
add_package :: PackageConfigMap
- -> Map InstalledPackageId PackageKey
- -> [PackageKey]
- -> (PackageKey,Maybe PackageKey)
- -> MaybeErr MsgDoc [PackageKey]
-add_package pkg_db ipid_map ps (p, mb_parent)
+ -> [UnitId]
+ -> (UnitId,Maybe UnitId)
+ -> MaybeErr MsgDoc [UnitId]
+add_package pkg_db ps (p, mb_parent)
| p `elem` ps = return ps -- Check if we've already added this package
| otherwise =
case lookupPackage' pkg_db p of
@@ -1341,37 +1269,29 @@ add_package pkg_db ipid_map ps (p, mb_parent)
missingDependencyMsg mb_parent)
Just pkg -> do
-- Add the package's dependents also
- ps' <- foldM add_package_ipid ps (depends pkg)
+ ps' <- foldM add_unit_key ps (depends pkg)
return (p : ps')
where
- add_package_ipid ps ipid
- | Just pid <- Map.lookup ipid ipid_map
- = add_package pkg_db ipid_map ps (pid, Just p)
- | otherwise
- = Failed (missingPackageMsg ipid
- <> missingDependencyMsg mb_parent)
-
-missingPackageErr :: Outputable pkgid => DynFlags -> pkgid -> IO a
-missingPackageErr dflags p
- = throwGhcExceptionIO (CmdLineError (showSDoc dflags (missingPackageMsg p)))
+ add_unit_key ps key
+ = add_package pkg_db ps (key, Just p)
missingPackageMsg :: Outputable pkgid => pkgid -> SDoc
missingPackageMsg p = ptext (sLit "unknown package:") <+> ppr p
-missingDependencyMsg :: Maybe PackageKey -> SDoc
+missingDependencyMsg :: Maybe UnitId -> SDoc
missingDependencyMsg Nothing = Outputable.empty
missingDependencyMsg (Just parent)
- = space <> parens (ptext (sLit "dependency of") <+> ftext (packageKeyFS parent))
+ = space <> parens (ptext (sLit "dependency of") <+> ftext (unitIdFS parent))
-- -----------------------------------------------------------------------------
-packageKeyPackageIdString :: DynFlags -> PackageKey -> Maybe String
-packageKeyPackageIdString dflags pkg_key
- | pkg_key == mainPackageKey = Just "main"
+unitIdPackageIdString :: DynFlags -> UnitId -> Maybe String
+unitIdPackageIdString dflags pkg_key
+ | pkg_key == mainUnitId = Just "main"
| otherwise = fmap sourcePackageIdString (lookupPackage dflags pkg_key)
-- | Will the 'Name' come from a dynamically linked library?
-isDllName :: DynFlags -> PackageKey -> Module -> Name -> Bool
+isDllName :: DynFlags -> UnitId -> 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
@@ -1420,7 +1340,7 @@ pprPackagesWith pprIPI dflags =
-- be different from the package databases (exposure, trust)
pprPackagesSimple :: DynFlags -> SDoc
pprPackagesSimple = pprPackagesWith pprIPI
- where pprIPI ipi = let InstalledPackageId i = installedPackageId ipi
+ where pprIPI ipi = let i = unitIdFS (unitId ipi)
e = if exposed ipi then text "E" else text " "
t = if trusted ipi then text "T" else text " "
in e <> t <> text " " <> ftext i
@@ -1432,7 +1352,7 @@ pprModuleMap 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)
+ | m == moduleName m' = ppr (moduleUnitId m') <+> parens (ppr o)
| otherwise = ppr m' <+> parens (ppr o)
fsPackageName :: PackageConfig -> FastString
diff --git a/compiler/main/Packages.hs-boot b/compiler/main/Packages.hs-boot
index bac04bc20a..1197fadb57 100644
--- a/compiler/main/Packages.hs-boot
+++ b/compiler/main/Packages.hs-boot
@@ -1,7 +1,7 @@
module Packages where
-- Well, this is kind of stupid...
-import {-# SOURCE #-} Module (PackageKey)
+import {-# SOURCE #-} Module (UnitId)
import {-# SOURCE #-} DynFlags (DynFlags)
data PackageState
-packageKeyPackageIdString :: DynFlags -> PackageKey -> Maybe String
+unitIdPackageIdString :: DynFlags -> UnitId -> Maybe String
emptyPackageState :: PackageState
diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index 15baa38bf5..1a1d4b50f5 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -613,7 +613,7 @@ runClang dflags args = do
)
-- | Figure out which version of LLVM we are running this session
-figureLlvmVersion :: DynFlags -> IO (Maybe Int)
+figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int))
figureLlvmVersion dflags = do
let (pgm,opts) = pgm_lc dflags
args = filter notNull (map showOpt opts)
@@ -626,17 +626,18 @@ figureLlvmVersion dflags = do
(pin, pout, perr, _) <- runInteractiveProcess pgm args'
Nothing Nothing
{- > llc -version
- Low Level Virtual Machine (http://llvm.org/):
- llvm version 2.8 (Ubuntu 2.8-0Ubuntu1)
+ LLVM (http://llvm.org/):
+ LLVM version 3.5.2
...
-}
hSetBinaryMode pout False
_ <- hGetLine pout
- vline <- hGetLine pout
- v <- case filter isDigit vline of
- [] -> fail "no digits!"
- [x] -> fail $ "only 1 digit! (" ++ show x ++ ")"
- (x:y:_) -> return ((read [x,y]) :: Int)
+ vline <- dropWhile (not . isDigit) `fmap` hGetLine pout
+ v <- case span (/= '.') vline of
+ ("",_) -> fail "no digits!"
+ (x,y) -> return (read x
+ , read $ takeWhile isDigit $ drop 1 y)
+
hClose pin
hClose pout
hClose perr
@@ -1327,19 +1328,15 @@ handleProc pgm phase_name proc = do
(rc, r) <- proc `catchIO` handler
case rc of
ExitSuccess{} -> return r
- ExitFailure n
- -- rawSystem returns (ExitFailure 127) if the exec failed for any
- -- reason (eg. the program doesn't exist). This is the only clue
- -- we have, but we need to report something to the user because in
- -- the case of a missing program there will otherwise be no output
- -- at all.
- | n == 127 -> does_not_exist
- | otherwise -> throwGhcExceptionIO (PhaseFailed phase_name rc)
+ ExitFailure n -> throwGhcExceptionIO (
+ ProgramError ("`" ++ takeBaseName pgm ++ "'" ++
+ " failed in phase `" ++ phase_name ++ "'." ++
+ " (Exit code: " ++ show n ++ ")"))
where
handler err =
if IO.isDoesNotExistError err
then does_not_exist
- else IO.ioError err
+ else throwGhcExceptionIO (ProgramError $ show err)
does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
@@ -1473,7 +1470,7 @@ traceCmd dflags phase_name cmd_line action
where
handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
- ; throwGhcExceptionIO (PhaseFailed phase_name (ExitFailure 1)) }
+ ; throwGhcExceptionIO (ProgramError (show exn))}
{-
************************************************************************
@@ -1544,7 +1541,7 @@ linesPlatform xs =
#endif
-linkDynLib :: DynFlags -> [String] -> [PackageKey] -> IO ()
+linkDynLib :: DynFlags -> [String] -> [UnitId] -> IO ()
linkDynLib dflags0 o_files dep_packages
= do
let -- This is a rather ugly hack to fix dynamically linked
@@ -1590,7 +1587,7 @@ linkDynLib dflags0 o_files dep_packages
OSMinGW32 ->
pkgs
_ ->
- filter ((/= rtsPackageKey) . packageConfigId) pkgs
+ filter ((/= rtsUnitId) . 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
@@ -1600,7 +1597,7 @@ linkDynLib dflags0 o_files dep_packages
-- frameworks
pkg_framework_opts <- getPkgFrameworkOpts dflags platform
- (map packageKey pkgs)
+ (map unitId pkgs)
let framework_opts = getFrameworkOpts dflags platform
case os of
@@ -1721,7 +1718,7 @@ linkDynLib dflags0 o_files dep_packages
++ map Option pkg_link_opts
)
-getPkgFrameworkOpts :: DynFlags -> Platform -> [PackageKey] -> IO [String]
+getPkgFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [String]
getPkgFrameworkOpts dflags platform dep_packages
| platformUsesFrameworks platform = do
pkg_framework_path_opts <- do
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
index 2b31a03b21..e2a772f8d4 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -832,7 +832,7 @@ dffvLetBndr :: Bool -> Id -> DFFV ()
-- we say "True" if we are exposing that unfolding
dffvLetBndr vanilla_unfold id
= do { go_unf (unfoldingInfo idinfo)
- ; mapM_ go_rule (specInfoRules (specInfo idinfo)) }
+ ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) }
where
idinfo = idInfo id
@@ -1123,7 +1123,7 @@ tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
------------------------
tidyTopBind :: DynFlags
- -> PackageKey
+ -> UnitId
-> Module
-> (Integer -> CoreExpr)
-> UnfoldEnv
@@ -1311,7 +1311,7 @@ type CafRefEnv = (VarEnv Id, Integer -> CoreExpr)
-- The Integer -> CoreExpr is the desugaring function for Integer literals
-- See Note [Disgusting computation of CafRefs]
-hasCafRefs :: DynFlags -> PackageKey -> Module
+hasCafRefs :: DynFlags -> UnitId -> Module
-> CafRefEnv -> Arity -> CoreExpr
-> CafInfo
hasCafRefs dflags this_pkg this_mod p@(_,cvt_integer) arity expr
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index 2e5caf4b74..d84578805b 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -82,6 +82,7 @@ import qualified Stream
import Data.List
import Data.Maybe
+import Data.Ord ( comparing )
import Control.Exception
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative (Applicative(..))
@@ -428,12 +429,15 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap us
cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap
cmm count
- let newFileIds = fileIds' `minusUFM` fileIds
+ -- Generate .file directives for every new file that has been
+ -- used. Note that it is important that we generate these in
+ -- ascending order, as Clang's 3.6 assembler complains.
+ let newFileIds = sortBy (comparing snd) $ eltsUFM $ fileIds' `minusUFM` fileIds
pprDecl (f,n) = ptext (sLit "\t.file ") <> ppr n <+>
doubleQuotes (ftext f)
emitNativeCode dflags h $ vcat $
- map pprDecl (eltsUFM newFileIds) ++
+ map pprDecl newFileIds ++
map (pprNatCmmDecl ncgImpl) native
-- force evaluation all this stuff to avoid space leaks
@@ -1118,15 +1122,15 @@ cmmExprNative referenceKind expr = do
CmmReg (CmmGlobal EagerBlackholeInfo)
| arch == ArchPPC && not (gopt Opt_PIC dflags)
-> cmmExprNative referenceKind $
- CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit "__stg_EAGER_BLACKHOLE_info")))
+ CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info")))
CmmReg (CmmGlobal GCEnter1)
| arch == ArchPPC && not (gopt Opt_PIC dflags)
-> cmmExprNative referenceKind $
- CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit "__stg_gc_enter_1")))
+ CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
| arch == ArchPPC && not (gopt Opt_PIC dflags)
-> cmmExprNative referenceKind $
- CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit "__stg_gc_fun")))
+ CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun")))
other
-> return other
diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs
index 975527817d..b5c26ed906 100644
--- a/compiler/nativeGen/PPC/Instr.hs
+++ b/compiler/nativeGen/PPC/Instr.hs
@@ -74,19 +74,19 @@ instance Instruction Instr where
ppc_mkStackAllocInstr :: Platform -> Int -> Instr
ppc_mkStackAllocInstr platform amount
- = case platformArch platform of
- ArchPPC -> -- SUB II32 (OpImm (ImmInt amount)) (OpReg esp)
- ADD sp sp (RIImm (ImmInt (-amount)))
- ArchPPC_64 _ -> STU II64 sp (AddrRegImm sp (ImmInt (-amount)))
- arch -> panic $ "ppc_mkStackAllocInstr " ++ show arch
+ = ppc_mkStackAllocInstr' platform (-amount)
ppc_mkStackDeallocInstr :: Platform -> Int -> Instr
ppc_mkStackDeallocInstr platform amount
+ = ppc_mkStackAllocInstr' platform amount
+
+ppc_mkStackAllocInstr' :: Platform -> Int -> Instr
+ppc_mkStackAllocInstr' platform amount
= case platformArch platform of
- ArchPPC -> -- ADD II32 (OpImm (ImmInt amount)) (OpReg esp)
- ADD sp sp (RIImm (ImmInt amount))
- ArchPPC_64 _ -> ADD sp sp (RIImm (ImmInt amount))
- arch -> panic $ "ppc_mkStackDeallocInstr " ++ show arch
+ ArchPPC -> UPDATE_SP II32 (ImmInt amount)
+ ArchPPC_64 _ -> UPDATE_SP II64 (ImmInt amount)
+ _ -> panic $ "ppc_mkStackAllocInstr' "
+ ++ show (platformArch platform)
--
-- See note [extra spill slots] in X86/Instr.hs
@@ -186,8 +186,10 @@ data Instr
-- Loads and stores.
| LD Format Reg AddrMode -- Load format, dst, src
+ | LDFAR Format Reg AddrMode -- Load format, dst, src 32 bit offset
| LA Format Reg AddrMode -- Load arithmetic format, dst, src
| ST Format Reg AddrMode -- Store format, src, dst
+ | STFAR Format Reg AddrMode -- Store format, src, dst 32 bit offset
| STU Format Reg AddrMode -- Store with Update format, src, dst
| LIS Reg Imm -- Load Immediate Shifted dst, src
| LI Reg Imm -- Load Immediate dst, src
@@ -277,6 +279,8 @@ data Instr
| NOP -- no operation, PowerPC 64 bit
-- needs this as place holder to
-- reload TOC pointer
+ | UPDATE_SP Format Imm -- expand/shrink spill area on C stack
+ -- pseudo-instruction
-- | Get the registers that are being used by this instruction.
-- regUsage doesn't need to do any trickery for jumps and such.
@@ -288,8 +292,10 @@ ppc_regUsageOfInstr :: Platform -> Instr -> RegUsage
ppc_regUsageOfInstr platform instr
= case instr of
LD _ reg addr -> usage (regAddr addr, [reg])
+ LDFAR _ reg addr -> usage (regAddr addr, [reg])
LA _ reg addr -> usage (regAddr addr, [reg])
ST _ reg addr -> usage (reg : regAddr addr, [])
+ STFAR _ reg addr -> usage (reg : regAddr addr, [])
STU _ reg addr -> usage (reg : regAddr addr, [])
LIS reg _ -> usage ([], [reg])
LI reg _ -> usage ([], [reg])
@@ -349,6 +355,7 @@ ppc_regUsageOfInstr platform instr
MFLR reg -> usage ([], [reg])
FETCHPC reg -> usage ([], [reg])
FETCHTOC reg _ -> usage ([], [reg])
+ UPDATE_SP _ _ -> usage ([], [sp])
_ -> noUsage
where
usage (src, dst) = RU (filter (interesting platform) src)
@@ -373,8 +380,10 @@ ppc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
ppc_patchRegsOfInstr instr env
= case instr of
LD fmt reg addr -> LD fmt (env reg) (fixAddr addr)
+ LDFAR fmt reg addr -> LDFAR fmt (env reg) (fixAddr addr)
LA fmt reg addr -> LA fmt (env reg) (fixAddr addr)
ST fmt reg addr -> ST fmt (env reg) (fixAddr addr)
+ STFAR fmt reg addr -> STFAR fmt (env reg) (fixAddr addr)
STU fmt reg addr -> STU fmt (env reg) (fixAddr addr)
LIS reg imm -> LIS (env reg) imm
LI reg imm -> LI (env reg) imm
@@ -505,7 +514,11 @@ ppc_mkSpillInstr dflags reg delta slot
_ -> II64
RcDouble -> FF64
_ -> panic "PPC.Instr.mkSpillInstr: no match"
- in ST fmt reg (AddrRegImm sp (ImmInt (off-delta)))
+ instr = case makeImmediate W32 True (off-delta) of
+ Just _ -> ST
+ Nothing -> STFAR -- pseudo instruction: 32 bit offsets
+
+ in instr fmt reg (AddrRegImm sp (ImmInt (off-delta)))
ppc_mkLoadInstr
@@ -526,7 +539,11 @@ ppc_mkLoadInstr dflags reg delta slot
_ -> II64
RcDouble -> FF64
_ -> panic "PPC.Instr.mkLoadInstr: no match"
- in LD fmt reg (AddrRegImm sp (ImmInt (off-delta)))
+ instr = case makeImmediate W32 True (off-delta) of
+ Just _ -> LD
+ Nothing -> LDFAR -- pseudo instruction: 32 bit offsets
+
+ in instr fmt reg (AddrRegImm sp (ImmInt (off-delta)))
-- | The maximum number of bytes required to spill a register. PPC32
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
index 6b9150a2d1..e5147794ce 100644
--- a/compiler/nativeGen/PPC/Ppr.hs
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -246,10 +246,10 @@ pprFormat x
FF32 -> sLit "fs"
FF64 -> sLit "fd"
_ -> panic "PPC.Ppr.pprFormat: no match")
-
-
+
+
pprCond :: Cond -> SDoc
-pprCond c
+pprCond c
= ptext (case c of {
ALWAYS -> sLit "";
EQQ -> sLit "eq"; NE -> sLit "ne";
@@ -373,7 +373,7 @@ pprDataItem lit
ppr_item II64 (CmmInt x _) dflags
| not(archPPC_64 dflags) =
[ptext (sLit "\t.long\t")
- <> int (fromIntegral
+ <> int (fromIntegral
(fromIntegral (x `shiftR` 32) :: Word32)),
ptext (sLit "\t.long\t")
<> int (fromIntegral (fromIntegral x :: Word32))]
@@ -437,6 +437,15 @@ pprInstr (LD fmt reg addr) = hcat [
ptext (sLit ", "),
pprAddr addr
]
+pprInstr (LDFAR fmt reg (AddrRegImm source off)) =
+ sdocWithPlatform $ \platform -> vcat [
+ pprInstr (ADDIS (tmpReg platform) source (HA off)),
+ pprInstr (LD fmt reg (AddrRegImm (tmpReg platform) (LO off)))
+ ]
+
+pprInstr (LDFAR _ _ _) =
+ panic "PPC.Ppr.pprInstr LDFAR: no match"
+
pprInstr (LA fmt reg addr) = hcat [
char '\t',
ptext (sLit "l"),
@@ -467,6 +476,14 @@ pprInstr (ST fmt reg addr) = hcat [
ptext (sLit ", "),
pprAddr addr
]
+pprInstr (STFAR fmt reg (AddrRegImm source off)) =
+ sdocWithPlatform $ \platform -> vcat [
+ pprInstr (ADDIS (tmpReg platform) source (HA off)),
+ pprInstr (ST fmt reg (AddrRegImm (tmpReg platform) (LO off)))
+ ]
+
+pprInstr (STFAR _ _ _) =
+ panic "PPC.Ppr.pprInstr STFAR: no match"
pprInstr (STU fmt reg addr) = hcat [
char '\t',
ptext (sLit "st"),
@@ -494,7 +511,7 @@ pprInstr (LI reg imm) = hcat [
ptext (sLit ", "),
pprImm imm
]
-pprInstr (MR reg1 reg2)
+pprInstr (MR reg1 reg2)
| reg1 == reg2 = empty
| otherwise = hcat [
char '\t',
@@ -693,6 +710,21 @@ pprInstr (EXTS fmt reg1 reg2) = hcat [
pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
+pprInstr (SR II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 =
+ -- Handle the case where we are asked to shift a 32 bit register by
+ -- less than zero or more than 31 bits. We convert this into a clear
+ -- of the destination register.
+ -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/5900
+ pprInstr (XOR reg1 reg2 (RIReg reg2))
+
+pprInstr (SL II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 =
+ -- As aboce for SR, but for left shifts.
+ -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/10870
+ pprInstr (XOR reg1 reg2 (RIReg reg2))
+
+pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 =
+ pprInstr (XOR reg1 reg2 (RIReg reg2))
+
pprInstr (SL fmt reg1 reg2 ri) =
let op = case fmt of
II32 -> "slw"
@@ -700,12 +732,6 @@ pprInstr (SL fmt reg1 reg2 ri) =
_ -> panic "PPC.Ppr.pprInstr: shift illegal size"
in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
-pprInstr (SR II32 reg1 reg2 (RIImm (ImmInt i))) | i > 31 || i < 0 =
- -- Handle the case where we are asked to shift a 32 bit register by
- -- less than zero or more than 31 bits. We convert this into a clear
- -- of the destination register.
- -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/5900
- pprInstr (XOR reg1 reg2 (RIReg reg2))
pprInstr (SR fmt reg1 reg2 ri) =
let op = case fmt of
II32 -> "srw"
@@ -732,7 +758,7 @@ pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
ptext (sLit ", "),
int me
]
-
+
pprInstr (FADD fmt reg1 reg2 reg3) = pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3
pprInstr (FSUB fmt reg1 reg2 reg3) = pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3
pprInstr (FMUL fmt reg1 reg2 reg3) = pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3
@@ -799,6 +825,22 @@ pprInstr LWSYNC = ptext (sLit "\tlwsync")
pprInstr NOP = ptext (sLit "\tnop")
+pprInstr (UPDATE_SP fmt amount@(ImmInt offset))
+ | fits16Bits offset = vcat [
+ pprInstr (LD fmt r0 (AddrRegImm sp (ImmInt 0))),
+ pprInstr (STU fmt r0 (AddrRegImm sp amount))
+ ]
+
+pprInstr (UPDATE_SP fmt amount)
+ = sdocWithPlatform $ \platform ->
+ let tmp = tmpReg platform in
+ vcat [
+ pprInstr (LD fmt r0 (AddrRegImm sp (ImmInt 0))),
+ pprInstr (ADDIS tmp sp (HA amount)),
+ pprInstr (ADD tmp tmp (RIImm (LO amount))),
+ pprInstr (STU fmt r0 (AddrRegReg sp tmp))
+ ]
+
-- pprInstr _ = panic "pprInstr (ppc)"
@@ -841,7 +883,7 @@ pprBinaryF op fmt reg1 reg2 reg3 = hcat [
ptext (sLit ", "),
pprReg reg3
]
-
+
pprRI :: RI -> SDoc
pprRI (RIReg r) = pprReg r
pprRI (RIImm r) = pprImm r
diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs
index 05efaeb1f4..14bdab734b 100644
--- a/compiler/nativeGen/PPC/Regs.hs
+++ b/compiler/nativeGen/PPC/Regs.hs
@@ -37,7 +37,8 @@ module PPC.Regs (
fits16Bits,
makeImmediate,
fReg,
- sp, toc, r3, r4, r11, r12, r27, r28, r30,
+ r0, sp, toc, r3, r4, r11, r12, r27, r28, r30,
+ tmpReg,
f1, f20, f21,
allocatableRegs
@@ -304,7 +305,8 @@ point registers.
fReg :: Int -> RegNo
fReg x = (32 + x)
-sp, toc, r3, r4, r11, r12, r27, r28, r30, f1, f20, f21 :: Reg
+r0, sp, toc, r3, r4, r11, r12, r27, r28, r30, f1, f20, f21 :: Reg
+r0 = regSingle 0
sp = regSingle 1
toc = regSingle 2
r3 = regSingle 3
@@ -325,3 +327,11 @@ allocatableRegs :: Platform -> [RealReg]
allocatableRegs platform
= let isFree i = freeReg platform i
in map RealRegSingle $ filter isFree allMachRegNos
+
+-- temporary register for compiler use
+tmpReg :: Platform -> Reg
+tmpReg platform =
+ case platformArch platform of
+ ArchPPC -> regSingle 13
+ ArchPPC_64 _ -> regSingle 30
+ _ -> panic "PPC.Regs.tmpReg: unknowm arch"
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index d582b53f5a..1d517b95dd 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -42,7 +42,7 @@ import Platform
-- Our intermediate code:
import BasicTypes
import BlockId
-import Module ( primPackageKey )
+import Module ( primUnitId )
import PprCmm ()
import CmmUtils
import CmmSwitch
@@ -1818,7 +1818,7 @@ genCCall dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]
genCCall dflags is32Bit target dest_regs args
where
format = intFormat width
- lbl = mkCmmCodeLabel primPackageKey (fsLit (popCntLabel width))
+ lbl = mkCmmCodeLabel primUnitId (fsLit (popCntLabel width))
genCCall dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src]
| is32Bit && width == W64 = do
@@ -1850,7 +1850,7 @@ genCCall dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src]
bw = widthInBits width
platform = targetPlatform dflags
format = if width == W8 then II16 else intFormat width
- lbl = mkCmmCodeLabel primPackageKey (fsLit (clzLabel width))
+ lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width))
genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src]
| is32Bit, width == W64 = do
@@ -1914,7 +1914,7 @@ genCCall dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args = do
CmmMayReturn)
genCCall dflags is32Bit target dest_regs args
where
- lbl = mkCmmCodeLabel primPackageKey (fsLit (word2FloatLabel width))
+ lbl = mkCmmCodeLabel primUnitId (fsLit (word2FloatLabel width))
genCCall dflags is32Bit (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = do
Amode amode addr_code <-
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index ae2e966090..db2d8473cc 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -1765,7 +1765,7 @@ getPState = P $ \s -> POk s s
instance HasDynFlags P where
getDynFlags = P $ \s -> POk s (dflags s)
-withThisPackage :: (PackageKey -> a) -> P a
+withThisPackage :: (UnitId -> a) -> P a
withThisPackage f
= do pkg <- liftM thisPackage getDynFlags
return $ f pkg
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 9cfce67efd..e24d1cbcea 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1148,7 +1148,7 @@ pattern_synonym_decl :: { LHsDecl RdrName }
pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName)) }
: con vars0 { ($1, PrefixPatSyn $2) }
- | varid consym varid { ($2, InfixPatSyn $1 $3) }
+ | varid conop varid { ($2, InfixPatSyn $1 $3) }
vars0 :: { [Located RdrName] }
: {- empty -} { [] }
@@ -2182,37 +2182,6 @@ exp10 :: { LHsExpr RdrName }
-- hdaume: core annotation
| fexp { $1 }
- -- parsing error messages go below here
- | '\\' apat apats opt_asig '->' error {% parseErrorSDoc (combineLocs $1 $5) $ text
- "parse error in lambda: no expression after '->'"
- }
- | '\\' error {% parseErrorSDoc (getLoc $1) $ text
- "parse error: naked lambda expression '\'"
- }
- | 'let' binds 'in' error {% parseErrorSDoc (combineLocs $1 $2) $ text
- "parse error in let binding: missing expression after 'in'"
- }
- | 'let' binds error {% parseErrorSDoc (combineLocs $1 $2) $ text
- "parse error in let binding: missing required 'in'"
- }
- | 'let' error {% parseErrorSDoc (getLoc $1) $ text
- "parse error: naked let binding"
- }
- | 'if' exp optSemi 'then' exp optSemi
- 'else' error {% hintIf (combineLocs $1 $5) "else clause empty" }
- | 'if' exp optSemi 'then' exp optSemi error {% hintIf (combineLocs $1 $5) "missing required else clause" }
- | 'if' exp optSemi 'then' error {% hintIf (combineLocs $1 $2) "then clause empty" }
- | 'if' exp optSemi error {% hintIf (combineLocs $1 $2) "missing required then and else clauses" }
- | 'if' error {% hintIf (getLoc $1) "naked if statement" }
- | 'case' exp 'of' error {% parseErrorSDoc (combineLocs $1 $2) $ text
- "parse error in case statement: missing list after '->'"
- }
- | 'case' exp error {% parseErrorSDoc (combineLocs $1 $2) $ text
- "parse error in case statement: missing required 'of'"
- }
- | 'case' error {% parseErrorSDoc (getLoc $1) $ text
- "parse error: naked case statement"
- }
optSemi :: { ([Located a],Bool) }
: ';' { ([$1],True) }
| {- empty -} { ([],False) }
diff --git a/compiler/prelude/ForeignCall.hs b/compiler/prelude/ForeignCall.hs
index bec849f728..a08f64b621 100644
--- a/compiler/prelude/ForeignCall.hs
+++ b/compiler/prelude/ForeignCall.hs
@@ -114,7 +114,7 @@ data CCallTarget
-- See note [Pragma source text] in BasicTypes
CLabelString -- C-land name of label.
- (Maybe PackageKey) -- What package the function is in.
+ (Maybe UnitId) -- 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/PrelNames.hs b/compiler/prelude/PrelNames.hs
index be6396cf21..3808c4ecb8 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -370,7 +370,9 @@ genericTyConNames = [
compTyConName, rTyConName, pTyConName, dTyConName,
cTyConName, sTyConName, rec0TyConName, par0TyConName,
d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
- repTyConName, rep1TyConName
+ repTyConName, rep1TyConName, uRecTyConName,
+ uAddrTyConName, uCharTyConName, uDoubleTyConName,
+ uFloatTyConName, uIntTyConName, uWordTyConName
]
{-
@@ -458,8 +460,9 @@ gHC_PARR' = mkBaseModule (fsLit "GHC.PArr")
gHC_SRCLOC :: Module
gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc")
-gHC_STACK :: Module
+gHC_STACK, gHC_STACK_TYPES :: Module
gHC_STACK = mkBaseModule (fsLit "GHC.Stack")
+gHC_STACK_TYPES = mkBaseModule (fsLit "GHC.Stack.Types")
gHC_STATICPTR :: Module
gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr")
@@ -473,7 +476,7 @@ rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation
mkInteractiveModule :: Int -> Module
-- (mkInteractiveMoudule 9) makes module 'interactive:M9'
-mkInteractiveModule n = mkModule interactivePackageKey (mkModuleName ("Ghci" ++ show n))
+mkInteractiveModule n = mkModule interactiveUnitId (mkModuleName ("Ghci" ++ show n))
pRELUDE_NAME, mAIN_NAME :: ModuleName
pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude")
@@ -484,28 +487,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 primPackageKey (mkModuleNameFS m)
+mkPrimModule m = mkModule primUnitId (mkModuleNameFS m)
mkIntegerModule :: FastString -> Module
-mkIntegerModule m = mkModule integerPackageKey (mkModuleNameFS m)
+mkIntegerModule m = mkModule integerUnitId (mkModuleNameFS m)
mkBaseModule :: FastString -> Module
-mkBaseModule m = mkModule basePackageKey (mkModuleNameFS m)
+mkBaseModule m = mkModule baseUnitId (mkModuleNameFS m)
mkBaseModule_ :: ModuleName -> Module
-mkBaseModule_ m = mkModule basePackageKey m
+mkBaseModule_ m = mkModule baseUnitId m
mkThisGhcModule :: FastString -> Module
-mkThisGhcModule m = mkModule thisGhcPackageKey (mkModuleNameFS m)
+mkThisGhcModule m = mkModule thisGhcUnitId (mkModuleNameFS m)
mkThisGhcModule_ :: ModuleName -> Module
-mkThisGhcModule_ m = mkModule thisGhcPackageKey m
+mkThisGhcModule_ m = mkModule thisGhcUnitId m
mkMainModule :: FastString -> Module
-mkMainModule m = mkModule mainPackageKey (mkModuleNameFS m)
+mkMainModule m = mkModule mainUnitId (mkModuleNameFS m)
mkMainModule_ :: ModuleName -> Module
-mkMainModule_ m = mkModule mainPackageKey m
+mkMainModule_ m = mkModule mainUnitId m
{-
************************************************************************
@@ -686,7 +689,11 @@ u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,
conName_RDR, conFixity_RDR, conIsRecord_RDR,
noArityDataCon_RDR, arityDataCon_RDR, selName_RDR,
prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR,
- rightAssocDataCon_RDR, notAssocDataCon_RDR :: RdrName
+ rightAssocDataCon_RDR, notAssocDataCon_RDR,
+ uAddrDataCon_RDR, uCharDataCon_RDR, uDoubleDataCon_RDR,
+ uFloatDataCon_RDR, uIntDataCon_RDR, uWordDataCon_RDR,
+ uAddrHash_RDR, uCharHash_RDR, uDoubleHash_RDR,
+ uFloatHash_RDR, uIntHash_RDR, uWordHash_RDR :: RdrName
u1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "U1")
par1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Par1")
@@ -727,6 +734,19 @@ leftAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative")
rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative")
notAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative")
+uAddrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UAddr")
+uCharDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UChar")
+uDoubleDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UDouble")
+uFloatDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UFloat")
+uIntDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UInt")
+uWordDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UWord")
+
+uAddrHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uAddr#")
+uCharHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uChar#")
+uDoubleHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uDouble#")
+uFloatHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uFloat#")
+uIntHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uInt#")
+uWordHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uWord#")
fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, foldMap_RDR,
traverse_RDR, mempty_RDR, mappend_RDR :: RdrName
@@ -788,7 +808,9 @@ v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
compTyConName, rTyConName, pTyConName, dTyConName,
cTyConName, sTyConName, rec0TyConName, par0TyConName,
d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
- repTyConName, rep1TyConName :: Name
+ repTyConName, rep1TyConName, uRecTyConName,
+ uAddrTyConName, uCharTyConName, uDoubleTyConName,
+ uFloatTyConName, uIntTyConName, uWordTyConName :: Name
v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey
u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey
@@ -817,6 +839,14 @@ noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey
repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey
rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey
+uRecTyConName = tcQual gHC_GENERICS (fsLit "URec") uRecTyConKey
+uAddrTyConName = tcQual gHC_GENERICS (fsLit "UAddr") uAddrTyConKey
+uCharTyConName = tcQual gHC_GENERICS (fsLit "UChar") uCharTyConKey
+uDoubleTyConName = tcQual gHC_GENERICS (fsLit "UDouble") uDoubleTyConKey
+uFloatTyConName = tcQual gHC_GENERICS (fsLit "UFloat") uFloatTyConKey
+uIntTyConName = tcQual gHC_GENERICS (fsLit "UInt") uIntTyConKey
+uWordTyConName = tcQual gHC_GENERICS (fsLit "UWord") uWordTyConKey
+
-- Base strings Strings
unpackCStringName, unpackCStringFoldrName,
unpackCStringUtf8Name, eqStringName, stringTyConName :: Name
@@ -1178,11 +1208,11 @@ knownSymbolClassName = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolCl
-- Source Locations
callStackDataConName, callStackTyConName, srcLocDataConName :: Name
callStackDataConName
- = dcQual gHC_TYPES (fsLit "CallStack") callStackDataConKey
+ = dcQual gHC_STACK_TYPES (fsLit "CallStack") callStackDataConKey
callStackTyConName
- = tcQual gHC_TYPES (fsLit "CallStack") callStackTyConKey
+ = tcQual gHC_STACK_TYPES (fsLit "CallStack") callStackTyConKey
srcLocDataConName
- = dcQual gHC_TYPES (fsLit "SrcLoc") srcLocDataConKey
+ = dcQual gHC_STACK_TYPES (fsLit "SrcLoc") srcLocDataConKey
-- plugins
pLUGINS :: Module
@@ -1468,7 +1498,9 @@ v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,
compTyConKey, rTyConKey, pTyConKey, dTyConKey,
cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey,
d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey,
- repTyConKey, rep1TyConKey :: Unique
+ repTyConKey, rep1TyConKey, uRecTyConKey,
+ uAddrTyConKey, uCharTyConKey, uDoubleTyConKey,
+ uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique
v1TyConKey = mkPreludeTyConUnique 135
u1TyConKey = mkPreludeTyConUnique 136
@@ -1497,21 +1529,29 @@ noSelTyConKey = mkPreludeTyConUnique 154
repTyConKey = mkPreludeTyConUnique 155
rep1TyConKey = mkPreludeTyConUnique 156
+uRecTyConKey = mkPreludeTyConUnique 157
+uAddrTyConKey = mkPreludeTyConUnique 158
+uCharTyConKey = mkPreludeTyConUnique 159
+uDoubleTyConKey = mkPreludeTyConUnique 160
+uFloatTyConKey = mkPreludeTyConUnique 161
+uIntTyConKey = mkPreludeTyConUnique 162
+uWordTyConKey = mkPreludeTyConUnique 163
+
-- Type-level naturals
typeNatKindConNameKey, typeSymbolKindConNameKey,
typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey,
typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey
, typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey
:: Unique
-typeNatKindConNameKey = mkPreludeTyConUnique 160
-typeSymbolKindConNameKey = mkPreludeTyConUnique 161
-typeNatAddTyFamNameKey = mkPreludeTyConUnique 162
-typeNatMulTyFamNameKey = mkPreludeTyConUnique 163
-typeNatExpTyFamNameKey = mkPreludeTyConUnique 164
-typeNatLeqTyFamNameKey = mkPreludeTyConUnique 165
-typeNatSubTyFamNameKey = mkPreludeTyConUnique 166
-typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 167
-typeNatCmpTyFamNameKey = mkPreludeTyConUnique 168
+typeNatKindConNameKey = mkPreludeTyConUnique 164
+typeSymbolKindConNameKey = mkPreludeTyConUnique 165
+typeNatAddTyFamNameKey = mkPreludeTyConUnique 166
+typeNatMulTyFamNameKey = mkPreludeTyConUnique 167
+typeNatExpTyFamNameKey = mkPreludeTyConUnique 168
+typeNatLeqTyFamNameKey = mkPreludeTyConUnique 169
+typeNatSubTyFamNameKey = mkPreludeTyConUnique 170
+typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 171
+typeNatCmpTyFamNameKey = mkPreludeTyConUnique 172
ntTyConKey:: Unique
ntTyConKey = mkPreludeTyConUnique 174
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index d44c224479..f87dce4798 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -241,19 +241,19 @@ primOpRules nm CharGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ]
primOpRules nm CharLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ]
primOpRules nm CharLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ]
-primOpRules nm FloatGtOp = mkFloatingRelOpRule nm (>) []
-primOpRules nm FloatGeOp = mkFloatingRelOpRule nm (>=) []
-primOpRules nm FloatLeOp = mkFloatingRelOpRule nm (<=) []
-primOpRules nm FloatLtOp = mkFloatingRelOpRule nm (<) []
-primOpRules nm FloatEqOp = mkFloatingRelOpRule nm (==) [ litEq True ]
-primOpRules nm FloatNeOp = mkFloatingRelOpRule nm (/=) [ litEq False ]
-
-primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>) []
-primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=) []
-primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=) []
-primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<) []
-primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==) [ litEq True ]
-primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=) [ litEq False ]
+primOpRules nm FloatGtOp = mkFloatingRelOpRule nm (>)
+primOpRules nm FloatGeOp = mkFloatingRelOpRule nm (>=)
+primOpRules nm FloatLeOp = mkFloatingRelOpRule nm (<=)
+primOpRules nm FloatLtOp = mkFloatingRelOpRule nm (<)
+primOpRules nm FloatEqOp = mkFloatingRelOpRule nm (==)
+primOpRules nm FloatNeOp = mkFloatingRelOpRule nm (/=)
+
+primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>)
+primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=)
+primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=)
+primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<)
+primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==)
+primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=)
primOpRules nm WordGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ]
primOpRules nm WordGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ]
@@ -284,29 +284,49 @@ mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules)
mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
-> [RuleM CoreExpr] -> Maybe CoreRule
mkRelOpRule nm cmp extra
- = mkPrimOpRule nm 2 $ rules ++ extra
+ = mkPrimOpRule nm 2 $
+ binaryCmpLit cmp : equal_rule : extra
where
- rules = [ binaryCmpLit cmp
- , do equalArgs
- -- x `cmp` x does not depend on x, so
- -- compute it for the arbitrary value 'True'
- -- and use that result
- dflags <- getDynFlags
- return (if cmp True True
- then trueValInt dflags
- else falseValInt dflags) ]
-
--- Note [Rules for floating-point comparisons]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- We need different rules for floating-point values because for floats
--- it is not true that x = x. The special case when this does not occur
--- are NaNs.
+ -- x `cmp` x does not depend on x, so
+ -- compute it for the arbitrary value 'True'
+ -- and use that result
+ equal_rule = do { equalArgs
+ ; dflags <- getDynFlags
+ ; return (if cmp True True
+ then trueValInt dflags
+ else falseValInt dflags) }
+
+{- Note [Rules for floating-point comparisons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need different rules for floating-point values because for floats
+it is not true that x = x (for NaNs); so we do not want the equal_rule
+rule that mkRelOpRule uses.
+
+Note also that, in the case of equality/inequality, we do /not/
+want to switch to a case-expression. For example, we do not want
+to convert
+ case (eqFloat# x 3.8#) of
+ True -> this
+ False -> that
+to
+ case x of
+ 3.8#::Float# -> this
+ _ -> that
+See Trac #9238. Reason: comparing floating-point values for equality
+delicate, and we don't want to implement that delicacy in the code for
+case expressions. So we make it an invariant of Core that a case
+expression never scrutinises a Float# or Double#.
+
+This transformation is what the litEq rule does;
+see Note [The litEq rule: converting equality to case].
+So we /refrain/ from using litEq for mkFloatingRelOpRule.
+-}
mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)
- -> [RuleM CoreExpr] -> Maybe CoreRule
-mkFloatingRelOpRule nm cmp extra -- See Note [Rules for floating-point comparisons]
- = mkPrimOpRule nm 2 $ binaryCmpLit cmp : extra
+ -> Maybe CoreRule
+-- See Note [Rules for floating-point comparisons]
+mkFloatingRelOpRule nm cmp
+ = mkPrimOpRule nm 2 [binaryCmpLit cmp]
-- common constants
zeroi, onei, zerow, onew :: DynFlags -> Literal
@@ -428,24 +448,27 @@ doubleOp2 op dflags (MachDouble f1) (MachDouble f2)
doubleOp2 _ _ _ _ = Nothing
--------------------------
--- This stuff turns
--- n ==# 3#
--- into
--- case n of
--- 3# -> True
--- m -> False
---
--- This is a Good Thing, because it allows case-of case things
--- to happen, and case-default absorption to happen. For
--- example:
---
--- if (n ==# 3#) || (n ==# 4#) then e1 else e2
--- will transform to
--- case n of
--- 3# -> e1
--- 4# -> e1
--- m -> e2
--- (modulo the usual precautions to avoid duplicating e1)
+{- Note [The litEq rule: converting equality to case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This stuff turns
+ n ==# 3#
+into
+ case n of
+ 3# -> True
+ m -> False
+
+This is a Good Thing, because it allows case-of case things
+to happen, and case-default absorption to happen. For
+example:
+
+ if (n ==# 3#) || (n ==# 4#) then e1 else e2
+will transform to
+ case n of
+ 3# -> e1
+ 4# -> e1
+ m -> e2
+(modulo the usual precautions to avoid duplicating e1)
+-}
litEq :: Bool -- True <=> equality, False <=> inequality
-> RuleM CoreExpr
diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs
index 6b012ee5ea..202fd815d5 100644
--- a/compiler/prelude/PrimOp.hs
+++ b/compiler/prelude/PrimOp.hs
@@ -39,7 +39,7 @@ import ForeignCall ( CLabelString )
import Unique ( Unique, mkPrimOpIdUnique )
import Outputable
import FastString
-import Module ( PackageKey )
+import Module ( UnitId )
{-
************************************************************************
@@ -617,7 +617,7 @@ pprPrimOp other_op = pprOccName (primOpOcc other_op)
************************************************************************
-}
-data PrimCall = PrimCall CLabelString PackageKey
+data PrimCall = PrimCall CLabelString UnitId
instance Outputable PrimCall where
ppr (PrimCall lbl pkgId)
diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs
index d3deb49ba2..9c39564147 100644
--- a/compiler/prelude/THNames.hs
+++ b/compiler/prelude/THNames.hs
@@ -7,7 +7,7 @@
module THNames where
import PrelNames( mk_known_key_name )
-import Module( Module, mkModuleNameFS, mkModule, thPackageKey )
+import Module( Module, mkModuleNameFS, mkModule, thUnitId )
import Name( Name )
import OccName( tcName, clsName, dataName, varName )
import RdrName( RdrName, nameRdrName )
@@ -145,7 +145,7 @@ thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")
qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
mkTHModule :: FastString -> Module
-mkTHModule m = mkModule thPackageKey (mkModuleNameFS m)
+mkTHModule m = mkModule thUnitId (mkModuleNameFS m)
libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name
libFun = mk_known_key_name OccName.varName thLib
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index d469207282..c371d47067 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -222,7 +222,7 @@ rnImportDecl this_mod
-- c.f. GHC.findModule, and Trac #9997
Nothing -> True
Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" ||
- fsToPackageKey pkg_fs == modulePackageKey this_mod))
+ fsToUnitId pkg_fs == moduleUnitId this_mod))
(addErr (ptext (sLit "A module cannot import itself:") <+> ppr imp_mod_name))
-- Check for a missing import list (Opt_WarnMissingImportList also
@@ -337,7 +337,7 @@ calculateAvails dflags iface mod_safe' want_boot =
imp_mod : dep_finsts deps
| otherwise = dep_finsts deps
- pkg = modulePackageKey (mi_module iface)
+ pkg = moduleUnitId (mi_module iface)
-- Does this import mean we now require our own pkg
-- to be trusted? See Note [Trust Own Package]
@@ -1601,18 +1601,16 @@ extendImportMap_Field rdr_env (FieldOcc rdr sel) =
where
lbl = occNameFS (rdrNameOcc rdr)
--- For a single used GRE, find all the import decls that brought
+-- For each of a list of used GREs, find all the import decls that brought
-- it into scope; choose one of them (bestImport), and record
-- the RdrName in that import decl's entry in the ImportMap
extendImportMap_GRE :: [GlobalRdrElt] -> ImportMap -> ImportMap
extendImportMap_GRE gres imp_map
- | [gre] <- gres
- , GRE { gre_lcl = lcl, gre_imp = imps } <- gre
- , not lcl
- = add_imp gre (bestImport imps) imp_map
- | otherwise
- = imp_map
+ = foldr recordRdrName imp_map nonLocalGREs
where
+ recordRdrName gre m = add_imp gre (bestImport (gre_imp gre)) m
+ nonLocalGREs = filter (not . gre_lcl) gres
+
add_imp :: GlobalRdrElt -> ImportSpec -> ImportMap -> ImportMap
add_imp gre (ImpSpec { is_decl = imp_decl_spec }) imp_map
= Map.insertWith add decl_loc [avail] imp_map
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 18eb24dfbf..f89f1b2ceb 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -391,8 +391,8 @@ rnHsForeignDecl (ForeignImport name ty _ spec)
; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty
-- Mark any PackageTarget style imports as coming from the current package
- ; let packageKey = thisPackage $ hsc_dflags topEnv
- spec' = patchForeignImport packageKey spec
+ ; let unitId = thisPackage $ hsc_dflags topEnv
+ spec' = patchForeignImport unitId spec
; return (ForeignImport name' ty' noForeignImportCoercionYet spec', fvs) }
@@ -409,21 +409,21 @@ rnHsForeignDecl (ForeignExport name ty _ spec)
-- package, so if they get inlined across a package boundry we'll still
-- know where they're from.
--
-patchForeignImport :: PackageKey -> ForeignImport -> ForeignImport
-patchForeignImport packageKey (CImport cconv safety fs spec src)
- = CImport cconv safety fs (patchCImportSpec packageKey spec) src
+patchForeignImport :: UnitId -> ForeignImport -> ForeignImport
+patchForeignImport unitId (CImport cconv safety fs spec src)
+ = CImport cconv safety fs (patchCImportSpec unitId spec) src
-patchCImportSpec :: PackageKey -> CImportSpec -> CImportSpec
-patchCImportSpec packageKey spec
+patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec
+patchCImportSpec unitId spec
= case spec of
- CFunction callTarget -> CFunction $ patchCCallTarget packageKey callTarget
+ CFunction callTarget -> CFunction $ patchCCallTarget unitId callTarget
_ -> spec
-patchCCallTarget :: PackageKey -> CCallTarget -> CCallTarget
-patchCCallTarget packageKey callTarget =
+patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget
+patchCCallTarget unitId callTarget =
case callTarget of
StaticTarget src label Nothing isFun
- -> StaticTarget src label (Just packageKey) isFun
+ -> StaticTarget src label (Just unitId) isFun
_ -> callTarget
{-
diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs
index 1e086027ba..1e485aee1e 100644
--- a/compiler/simplCore/OccurAnal.hs
+++ b/compiler/simplCore/OccurAnal.hs
@@ -253,7 +253,7 @@ always in scope.
* Note [Rule dependency info]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
- The VarSet in a SpecInfo is used for dependency analysis in the
+ The VarSet in a RuleInfo is used for dependency analysis in the
occurrence analyser. We must track free vars in *both* lhs and rhs.
Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.
Why both? Consider
diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs
index de02e27c2b..d873cc5e15 100644
--- a/compiler/simplCore/SetLevels.hs
+++ b/compiler/simplCore/SetLevels.hs
@@ -1015,7 +1015,7 @@ abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
-- We are going to lambda-abstract, so nuke any IdInfo,
-- and add the tyvars of the Id (if necessary)
zap v | isId v = WARN( isStableUnfolding (idUnfolding v) ||
- not (isEmptySpecInfo (idSpecialisation v)),
+ not (isEmptyRuleInfo (idSpecialisation v)),
text "absVarsOf: discarding info on" <+> ppr v )
setIdInfo v vanillaIdInfo
| otherwise = v
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index 90233d608a..dddb24d335 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -15,7 +15,7 @@ import CoreSyn
import HscTypes
import CSE ( cseProgram )
import Rules ( mkRuleBase, unionRuleBase,
- extendRuleBaseList, ruleCheckProgram, addSpecInfo, )
+ extendRuleBaseList, ruleCheckProgram, addRuleInfo, )
import PprCore ( pprCoreBindings, pprCoreExpr )
import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import IdInfo
@@ -871,7 +871,7 @@ shortOutIndirections binds
-- These exported Ids are the subjects of the indirection-elimination
exp_ids = map fst $ varEnvElts ind_env
exp_id_set = mkVarSet exp_ids
- no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
+ no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids
binds' = concatMap zap binds
zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
@@ -929,7 +929,7 @@ hasShortableIdInfo :: Id -> Bool
-- so we can safely discard it
-- See Note [Messing up the exported Id's IdInfo]
hasShortableIdInfo id
- = isEmptySpecInfo (specInfo info)
+ = isEmptyRuleInfo (ruleInfo info)
&& isDefaultInlinePragma (inlinePragInfo info)
&& not (isStableUnfolding (unfoldingInfo info))
where
@@ -951,8 +951,8 @@ transferIdInfo exported_id local_id
transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info
`setUnfoldingInfo` unfoldingInfo local_info
`setInlinePragInfo` inlinePragInfo local_info
- `setSpecInfo` addSpecInfo (specInfo exp_info) new_info
- new_info = setSpecInfoHead (idName exported_id)
- (specInfo local_info)
+ `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info
+ new_info = setRuleInfoHead (idName exported_id)
+ (ruleInfo local_info)
-- Remember to set the function-name field of the
-- rules as we transfer them from one function to another
diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs
index effd2121e9..1577efda37 100644
--- a/compiler/simplCore/SimplUtils.hs
+++ b/compiler/simplCore/SimplUtils.hs
@@ -14,7 +14,7 @@ module SimplUtils (
preInlineUnconditionally, postInlineUnconditionally,
activeUnfolding, activeRule,
getUnfoldingInRuleMatch,
- simplEnvForGHCi, updModeForStableUnfoldings, updModeForRuleLHS,
+ simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules,
-- The continuation type
SimplCont(..), DupFlag(..),
@@ -701,24 +701,25 @@ updModeForStableUnfoldings inline_rule_act current_mode
phaseFromActivation (ActiveAfter n) = Phase n
phaseFromActivation _ = InitialPhase
-updModeForRuleLHS :: SimplifierMode -> SimplifierMode
--- See Note [Simplifying rule LHSs]
-updModeForRuleLHS current_mode
+updModeForRules :: SimplifierMode -> SimplifierMode
+-- See Note [Simplifying rules]
+updModeForRules current_mode
= current_mode { sm_phase = InitialPhase
, sm_inline = False
, sm_rules = False
, sm_eta_expand = False }
-{- Note [Simplifying rule LHSs]
+{- Note [Simplifying rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When simplifying on the LHS of a rule, refrain from all inlining and
-all RULES. Doing anything to the LHS is plain confusing, because it
-means that what the rule matches is not what the user wrote.
-c.f. Trac #10595, and #10528.
+When simplifying a rule, refrain from any inlining or applying of other RULES.
+Doing anything to the LHS is plain confusing, because it means that what the
+rule matches is not what the user wrote. c.f. Trac #10595, and #10528.
Moreover, inlining (or applying rules) on rule LHSs risks introducing
Ticks into the LHS, which makes matching trickier. Trac #10665, #10745.
+Doing this to either side confounds tools like HERMIT, which seek to reason
+about and apply the RULES as originally written. See Trac #10829.
Note [Inlining in gentle mode]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1522,6 +1523,30 @@ as we would normally do.
That's why the whole transformation is part of the same process that
floats let-bindings and constructor arguments out of RHSs. In particular,
it is guarded by the doFloatFromRhs call in simplLazyBind.
+
+Note [Which type variables to abstract over]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Abstract only over the type variables free in the rhs wrt which the
+new binding is abstracted. Note that
+
+ * The naive approach of abstracting wrt the
+ tyvars free in the Id's /type/ fails. Consider:
+ /\ a b -> let t :: (a,b) = (e1, e2)
+ x :: a = fst t
+ in ...
+ Here, b isn't free in x's type, but we must nevertheless
+ abstract wrt b as well, because t's type mentions b.
+ Since t is floated too, we'd end up with the bogus:
+ poly_t = /\ a b -> (e1, e2)
+ poly_x = /\ a -> fst (poly_t a *b*)
+
+ * We must do closeOverKinds. Example (Trac #10934):
+ f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ...
+ Here we want to float 't', but we must remember to abstract over
+ 'k' as well, even though it is not explicitly mentioned in the RHS,
+ otherwise we get
+ t = /\ (f:k->*) (a:k). AccFailure @ (f a)
+ which is obviously bogus.
-}
abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExpr)
@@ -1542,23 +1567,12 @@ abstractFloats main_tvs body_env body
; return (subst', (NonRec poly_id poly_rhs)) }
where
rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
- tvs_here = varSetElemsKvsFirst (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
-
- -- Abstract only over the type variables free in the rhs
- -- wrt which the new binding is abstracted. But the naive
- -- approach of abstract wrt the tyvars free in the Id's type
- -- fails. Consider:
- -- /\ a b -> let t :: (a,b) = (e1, e2)
- -- x :: a = fst t
- -- in ...
- -- Here, b isn't free in x's type, but we must nevertheless
- -- abstract wrt b as well, because t's type mentions b.
- -- Since t is floated too, we'd end up with the bogus:
- -- poly_t = /\ a b -> (e1, e2)
- -- poly_x = /\ a -> fst (poly_t a *b*)
- -- So for now we adopt the even more naive approach of
- -- abstracting wrt *all* the tyvars. We'll see if that
- -- gives rise to problems. SLPJ June 98
+
+ -- tvs_here: see Note [Which type variables to abstract over]
+ tvs_here = varSetElemsKvsFirst $
+ intersectVarSet main_tv_set $
+ closeOverKinds $
+ exprSomeFreeVars isTyVar rhs'
abstract subst (Rec prs)
= do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly tvs_here) ids
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 07bc0041a1..2c73f8e119 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -36,7 +36,7 @@ import CoreUnfold
import CoreUtils
import CoreArity
--import PrimOp ( tagToEnumKey ) -- temporalily commented out. See #8326
-import Rules ( mkSpecInfo, lookupRule, getRules )
+import Rules ( mkRuleInfo, lookupRule, getRules )
import TysPrim ( voidPrimTy ) --, intPrimTy ) -- temporalily commented out. See #8326
import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..) )
import MonadUtils ( foldlM, mapAccumLM, liftIO )
@@ -2957,10 +2957,10 @@ addBndrRules env in_id out_id
= return (env, out_id)
| otherwise
= do { new_rules <- simplRules env (Just (idName out_id)) old_rules
- ; let final_id = out_id `setIdSpecialisation` mkSpecInfo new_rules
+ ; let final_id = out_id `setIdSpecialisation` mkRuleInfo new_rules
; return (modifyInScope env final_id, final_id) }
where
- old_rules = specInfoRules (idSpecialisation in_id)
+ old_rules = ruleInfoRules (idSpecialisation in_id)
simplRules :: SimplEnv -> Maybe Name -> [CoreRule] -> SimplM [CoreRule]
simplRules env mb_new_nm rules
@@ -2970,13 +2970,11 @@ simplRules env mb_new_nm rules
= return rule
simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args
- , ru_fn = fn_name, ru_rhs = rhs
- , ru_act = act })
- = do { (env, bndrs') <- simplBinders env bndrs
- ; let lhs_env = updMode updModeForRuleLHS env
- rhs_env = updMode (updModeForStableUnfoldings act) env
- ; args' <- mapM (simplExpr lhs_env) args
- ; rhs' <- simplExpr rhs_env rhs
+ , ru_fn = fn_name, ru_rhs = rhs })
+ = do { (env', bndrs') <- simplBinders env bndrs
+ ; let rule_env = updMode updModeForRules env'
+ ; args' <- mapM (simplExpr rule_env) args
+ ; rhs' <- simplExpr rule_env rhs
; return (rule { ru_bndrs = bndrs'
, ru_fn = mb_new_nm `orElse` fn_name
, ru_args = args'
diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs
index dd48832864..9b5d3cf763 100644
--- a/compiler/specialise/Rules.hs
+++ b/compiler/specialise/Rules.hs
@@ -16,8 +16,8 @@ module Rules (
-- ** Checking rule applications
ruleCheckProgram,
- -- ** Manipulating 'SpecInfo' rules
- mkSpecInfo, extendSpecInfo, addSpecInfo,
+ -- ** Manipulating 'RuleInfo' rules
+ mkRuleInfo, extendRuleInfo, addRuleInfo,
addIdSpecialisations,
-- * Misc. CoreRule helpers
@@ -43,7 +43,7 @@ import TysPrim ( anyTypeOfKind )
import Coercion
import CoreTidy ( tidyRules )
import Id
-import IdInfo ( SpecInfo( SpecInfo ) )
+import IdInfo ( RuleInfo( RuleInfo ) )
import Var
import VarEnv
import VarSet
@@ -180,7 +180,6 @@ mkRule this_mod is_auto is_local name act fn bndrs args rhs
-- A rule is an orphan only if none of the variables
-- mentioned on its left-hand side are locally defined
lhs_names = nameSetElems (extendNameSet (exprsOrphNames args) fn)
- -- TODO: copied from ruleLhsOrphNames
-- Since rules get eventually attached to one of the free names
-- from the definition when compiling the ABI hash, we should make
@@ -268,30 +267,30 @@ pprRulesForUser rules
{-
************************************************************************
* *
- SpecInfo: the rules in an IdInfo
+ RuleInfo: the rules in an IdInfo
* *
************************************************************************
-}
--- | Make a 'SpecInfo' containing a number of 'CoreRule's, suitable
+-- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable
-- for putting into an 'IdInfo'
-mkSpecInfo :: [CoreRule] -> SpecInfo
-mkSpecInfo rules = SpecInfo rules (rulesFreeVars rules)
+mkRuleInfo :: [CoreRule] -> RuleInfo
+mkRuleInfo rules = RuleInfo rules (rulesFreeVars rules)
-extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo
-extendSpecInfo (SpecInfo rs1 fvs1) rs2
- = SpecInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1)
+extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo
+extendRuleInfo (RuleInfo rs1 fvs1) rs2
+ = RuleInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1)
-addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo
-addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2)
- = SpecInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2)
+addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo
+addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2)
+ = RuleInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2)
addIdSpecialisations :: Id -> [CoreRule] -> Id
addIdSpecialisations id []
= id
addIdSpecialisations id rules
= setIdSpecialisation id $
- extendSpecInfo (idSpecialisation id) rules
+ extendRuleInfo (idSpecialisation id) rules
-- | Gather all the rules for locally bound identifiers from the supplied bindings
rulesOfBinds :: [CoreBind] -> [CoreRule]
diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs
index 5435920e5c..cb3830bb6b 100644
--- a/compiler/specialise/SpecConstr.hs
+++ b/compiler/specialise/SpecConstr.hs
@@ -1246,7 +1246,7 @@ scExpr' env (Let (NonRec bndr rhs) body)
; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
`combineUsage` spec_usg, -- Note [spec_usg includes rhs_usg]
- mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body')
+ mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body')
}
@@ -1269,7 +1269,7 @@ scExpr' env (Let (Rec prs) body)
-- See Note [Local recursive groups]
; let all_usg = spec_usg `combineUsage` body_usg -- Note [spec_usg includes rhs_usg]
- bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs))
+ bind' = Rec (concat (zipWith ruleInfoBinds rhs_infos specs))
; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
Let bind' body') }
@@ -1379,7 +1379,7 @@ scTopBind env body_usage (Rec prs)
body_usage rhs_infos
; return (body_usage `combineUsage` spec_usage,
- Rec (concat (zipWith specInfoBinds rhs_infos specs))) }
+ Rec (concat (zipWith ruleInfoBinds rhs_infos specs))) }
where
(bndrs,rhss) = unzip prs
force_spec = any (forceSpecBndr env) bndrs
@@ -1406,8 +1406,8 @@ scRecRhs env (bndr,rhs)
-- Two pats are the same if they match both ways
----------------------
-specInfoBinds :: RhsInfo -> [OneSpec] -> [(Id,CoreExpr)]
-specInfoBinds (RI { ri_fn = fn, ri_new_rhs = new_rhs }) specs
+ruleInfoBinds :: RhsInfo -> [OneSpec] -> [(Id,CoreExpr)]
+ruleInfoBinds (RI { ri_fn = fn, ri_new_rhs = new_rhs }) specs
= [(id,rhs) | OS _ _ id rhs <- specs] ++
-- First the specialised bindings
@@ -1434,7 +1434,7 @@ data RhsInfo
, ri_arg_occs :: [ArgOcc] -- Info on how the xs occur in body
}
-data SpecInfo = SI [OneSpec] -- The specialisations we have generated
+data RuleInfo = SI [OneSpec] -- The specialisations we have generated
Int -- Length of specs; used for numbering them
@@ -1505,13 +1505,13 @@ specialise
:: ScEnv
-> CallEnv -- Info on newly-discovered calls to this function
-> RhsInfo
- -> SpecInfo -- Original RHS plus patterns dealt with
- -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage
+ -> RuleInfo -- Original RHS plus patterns dealt with
+ -> UniqSM (ScUsage, RuleInfo) -- New specialised versions and their usage
-- See Note [spec_usg includes rhs_usg]
-- Note: this only generates *specialised* bindings
--- The original binding is added by specInfoBinds
+-- The original binding is added by ruleInfoBinds
--
-- Note: the rhs here is the optimised version of the original rhs
-- So when we make a specialised copy of the RHS, we're starting
@@ -1692,7 +1692,7 @@ calcSpecStrictness fn qvars pats
Note [spec_usg includes rhs_usg]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In calls to 'specialise', the returned ScUsage must include the rhs_usg in
-the passed-in SpecInfo, unless there are no calls at all to the function.
+the passed-in RuleInfo, unless there are no calls at all to the function.
The caller can, indeed must, assume this. He should not combine in rhs_usg
himself, or he'll get rhs_usg twice -- and that can lead to an exponential
diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs
index e3501dfd38..008561c4b3 100644
--- a/compiler/specialise/Specialise.hs
+++ b/compiler/specialise/Specialise.hs
@@ -449,7 +449,7 @@ The SpecEnv of an Id maps a list of types (the template) to an expression
[Type] |-> Expr
-For example, if f has this SpecInfo:
+For example, if f has this RuleInfo:
[Int, a] -> \d:Ord Int. f' a
@@ -1324,6 +1324,26 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs
; return (Just ((spec_f_w_arity, spec_rhs), final_uds, spec_env_rule)) } }
+{-
+Note [Orphans and auto-generated rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we specialise an INLINEABLE function, or when we have
+-fspecialise-aggressively, we auto-generate RULES that are orphans.
+We don't want to warn about these, or we'd generate a lot of warnings.
+Thus, we only warn about user-specified orphan rules.
+
+Indeed, we don't even treat the module as an orphan module if it has
+auto-generated *rule* orphans. Orphan modules are read every time we
+compile, so they are pretty obtrusive and slow down every compilation,
+even non-optimised ones. (Reason: for type class instances it's a
+type correctness issue.) But specialisation rules are strictly for
+*optimisation* only so it's fine not to read the interface.
+
+What this means is that a SPEC rules from auto-specialisation in
+module M will be used in other modules only if M.hi has been read for
+some other reason, which is actually pretty likely.
+-}
+
bindAuxiliaryDicts
:: SpecEnv
-> [DictId] -> [CoreExpr] -- Original dict bndrs, and the witnessing expressions
diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
index 538c5cf1f9..84dd3a5da1 100644
--- a/compiler/typecheck/Inst.hs
+++ b/compiler/typecheck/Inst.hs
@@ -408,6 +408,9 @@ syntaxNameCtxt name orig ty tidy_env
-}
getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
+-- Construct the OverlapFlag from the global module flags,
+-- but if the overlap_mode argument is (Just m),
+-- set the OverlapMode to 'm'
getOverlapFlag overlap_mode
= do { dflags <- getDynFlags
; let overlap_ok = xopt Opt_OverlappingInstances dflags
@@ -439,7 +442,21 @@ newClsInst overlap_mode dfun_name tvs theta clas tys
-- Not sure if this is really the right place to do so,
-- but it'll do fine
; oflag <- getOverlapFlag overlap_mode
- ; return (mkLocalInstance dfun oflag tvs' clas tys') }
+ ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
+ ; dflags <- getDynFlags
+ ; warnIf (isOrphan (is_orphan inst) && wopt Opt_WarnOrphans dflags) (instOrphWarn inst)
+ ; return inst }
+
+instOrphWarn :: ClsInst -> SDoc
+instOrphWarn inst
+ = hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst)
+ $$ text "To avoid this"
+ $$ nest 4 (vcat possibilities)
+ where
+ possibilities =
+ text "move the instance declaration to the module of the class or of the type, or" :
+ text "wrap the type with a newtype and declare the instance on the new type." :
+ []
tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
-- Add new locally-defined instances
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 48abcc805c..f927ffa2df 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -653,7 +653,7 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
sig_qtvs = [ tv | (_, Just sig, _) <- mono_infos
, (_, tv) <- sig_tvs sig ]
; traceTc "simplifyInfer call" (ppr name_taus $$ ppr wanted)
- ; (qtvs, givens, _mr_bites, ev_binds)
+ ; (qtvs, givens, ev_binds)
<- simplifyInfer tclvl mono sig_qtvs name_taus wanted
; let inferred_theta = map evVarPred givens
diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs
index bb4159a4be..2409b7b4e5 100644
--- a/compiler/typecheck/TcClassDcl.hs
+++ b/compiler/typecheck/TcClassDcl.hs
@@ -12,7 +12,8 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
findMethodBind, instantiateMethod,
tcClassMinimalDef,
HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs,
- tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr
+ tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr,
+ tcATDefault
) where
#include "HsVersions.h"
@@ -30,13 +31,21 @@ import TcType
import TcRnMonad
import BuildTyCl( TcMethInfo )
import Class
+import Coercion ( pprCoAxiom )
+import DynFlags
+import FamInst
+import FamInstEnv
import Id
import Name
import NameEnv
import NameSet
import Var
+import VarEnv
+import VarSet
import Outputable
import SrcLoc
+import TyCon
+import TypeRep
import Maybes
import BasicTypes
import Bag
@@ -45,6 +54,7 @@ import BooleanFormula
import Util
import Control.Monad
+import Data.List ( mapAccumL )
{-
Dictionary handling
@@ -418,3 +428,64 @@ warningMinimalDefIncomplete mindef
= vcat [ ptext (sLit "The MINIMAL pragma does not require:")
, nest 2 (pprBooleanFormulaNice mindef)
, ptext (sLit "but there is no default implementation.") ]
+
+tcATDefault :: Bool -- If a warning should be emitted when a default instance
+ -- definition is not provided by the user
+ -> SrcSpan
+ -> TvSubst
+ -> NameSet
+ -> ClassATItem
+ -> TcM [FamInst]
+-- ^ Construct default instances for any associated types that
+-- aren't given a user definition
+-- Returns [] or singleton
+tcATDefault emit_warn loc 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, _loc) <- 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 (L loc (tyConName fam_tc)) pat_tys'
+ ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs'
+ fam_tc pat_tys' rhs'
+ -- NB: no validity check. We check validity of default instances
+ -- in the class definition. Because type instance arguments cannot
+ -- be type family applications and cannot be polytypes, the
+ -- validity check is redundant.
+
+ ; 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 { when emit_warn $ warnMissingAT (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)
+
+warnMissingAT :: Name -> TcM ()
+warnMissingAT name
+ = do { warn <- woptM Opt_WarnMissingMethods
+ ; traceTc "warn" (ppr name <+> ppr warn)
+ ; warnTc warn -- Warn only if -fwarn-missing-methods
+ (ptext (sLit "No explicit") <+> text "associated type"
+ <+> ptext (sLit "or default declaration for ")
+ <+> quotes (ppr name)) }
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 2b1b77491e..05d689a203 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -19,7 +19,7 @@ import TcRnMonad
import FamInst
import TcErrors( reportAllUnsolved )
import TcValidity( validDerivPred )
-import TcClassDcl( tcMkDeclCtxt )
+import TcClassDcl( tcATDefault, tcMkDeclCtxt )
import TcEnv
import TcGenDeriv -- Deriv stuff
import TcGenGenerics
@@ -52,6 +52,7 @@ import NameSet
import TyCon
import TcType
import Var
+import VarEnv
import VarSet
import PrelNames
import THNames ( liftClassKey )
@@ -1986,6 +1987,7 @@ genInst comauxs
| otherwise
= do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas
dfun_name rep_tycon
+ tys tvs
(lookupNameEnv comauxs
(tyConName rep_tycon))
; inst_spec <- newDerivClsInst theta spec
@@ -2001,12 +2003,15 @@ genInst comauxs
where
rhs_ty = newTyConInstRhs rep_tycon rep_tc_args
-genDerivStuff :: SrcSpan -> Class -> Name -> TyCon
+-- Generate the bindings needed for a derived class that isn't handled by
+-- -XGeneralizedNewtypeDeriving.
+genDerivStuff :: SrcSpan -> Class -> Name -> TyCon -> [Type] -> [TyVar]
-> Maybe CommonAuxiliary
-> TcM (LHsBinds RdrName, BagDerivStuff)
-genDerivStuff loc clas dfun_name tycon comaux_maybe
+genDerivStuff loc clas dfun_name tycon inst_tys tyvars comaux_maybe
+ -- Special case for DeriveGeneric
| let ck = classKey clas
- , -- Special case because monadic
+ ,
Just gk <- lookup ck [(genClassKey, Gen0), (gen1ClassKey, Gen1)]
= let -- TODO NSF: correctly identify when we're building Both instead of One
Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst
@@ -2014,10 +2019,35 @@ genDerivStuff loc clas dfun_name tycon comaux_maybe
(binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule dfun_name)
return (binds, unitBag (DerivFamInst faminst))
- | otherwise -- Non-monadic generators
+ -- Not deriving Generic(1), so we first check if the compiler has built-in
+ -- support for deriving the class in question.
+ | otherwise
= do { dflags <- getDynFlags
; fix_env <- getDataConFixityFun tycon
- ; return (genDerivedBinds dflags fix_env clas loc tycon) }
+ ; case hasBuiltinDeriving dflags fix_env clas of
+ Just gen_fn -> return (gen_fn loc tycon)
+ Nothing -> genDerivAnyClass dflags }
+
+ where
+ genDerivAnyClass :: DynFlags -> TcM (LHsBinds RdrName, BagDerivStuff)
+ genDerivAnyClass dflags =
+ do { -- If there isn't compiler support for deriving the class, our last
+ -- resort is -XDeriveAnyClass (since -XGeneralizedNewtypeDeriving
+ -- fell through).
+ let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)
+ mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
+
+ ; tyfam_insts <-
+ ASSERT2( isNothing (canDeriveAnyClass dflags tycon clas)
+ , ppr "genDerivStuff: bad derived class" <+> ppr clas )
+ mapM (tcATDefault False loc mini_subst emptyNameSet)
+ (classATItems clas)
+ ; return ( emptyBag -- No method bindings are needed...
+ , listToBag (map DerivFamInst (concat tyfam_insts))
+ -- ...but we may need to generate binding for associated type
+ -- family default instances.
+ -- See Note [DeriveAnyClass and default family instances]
+ ) }
getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
-- If the TyCon is locally defined, we want the local fixity env;
@@ -2057,6 +2087,31 @@ representation type.
See the paper "Safe zero-cost coercions for Hsakell".
+Note [DeriveAnyClass and default family instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When a class has a associated type family with a default instance, e.g.:
+
+ class C a where
+ type T a
+ type T a = Char
+
+then there are a couple of scenarios in which a user would expect T a to
+default to Char. One is when an instance declaration for C is given without
+an implementation for T:
+
+ instance C Int
+
+Another scenario in which this can occur is when the -XDeriveAnyClass extension
+is used:
+
+ data Example = Example deriving (C, Generic)
+
+In the latter case, we must take care to check if C has any associated type
+families with default instances, because -XDeriveAnyClass will never provide
+an implementation for them. We "fill in" the default instances using the
+tcATDefault function from TcClsDcl (which is also used in TcInstDcls to handle
+the empty instance declaration case).
************************************************************************
* *
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 86c93ee764..a11b0c2abd 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -798,7 +798,7 @@ mkWrapperName what nameBase
thisMod <- getModule
let -- Note [Generating fresh names for ccall wrapper]
wrapperRef = nextWrapperNum dflags
- pkg = packageKeyString (modulePackageKey thisMod)
+ pkg = unitIdString (moduleUnitId thisMod)
mod = moduleNameString (moduleName thisMod)
wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->
let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index 7ef0d94331..c0a3350b46 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -1062,7 +1062,7 @@ mkEqInfoMsg ct ty1 ty2
mb_fun2 = isTyFun_maybe ty2
ambig_msg | isJust mb_fun1 || isJust mb_fun2
- = snd (mkAmbigMsg ct)
+ = snd (mkAmbigMsg False ct)
| otherwise = empty
tyfun_msg | Just tc1 <- mb_fun1
@@ -1379,7 +1379,7 @@ sameOccExtra ty1 ty2
, let n1 = tyConName tc1
n2 = tyConName tc2
same_occ = nameOccName n1 == nameOccName n2
- same_pkg = modulePackageKey (nameModule n1) == modulePackageKey (nameModule n2)
+ same_pkg = moduleUnitId (nameModule n1) == moduleUnitId (nameModule n2)
, n1 /= n2 -- Different Names
, same_occ -- but same OccName
= ptext (sLit "NB:") <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2)
@@ -1393,10 +1393,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 == mainPackageKey) $
+ , ppUnless (same_pkg || pkg == mainUnitId) $
nest 4 $ ptext (sLit "in package") <+> quotes (ppr pkg) ])
where
- pkg = modulePackageKey mod
+ pkg = moduleUnitId mod
mod = nameModule nm
loc = nameSrcSpan nm
@@ -1521,23 +1521,50 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped))
givens = getUserGivens ctxt
all_tyvars = all isTyVarTy tys
+
cannot_resolve_msg :: Ct -> SDoc -> SDoc
cannot_resolve_msg ct binds_msg
- = vcat [ addArising orig no_inst_msg
+ = vcat [ no_inst_msg
, nest 2 extra_note
, vcat (pp_givens givens)
, ppWhen (has_ambig_tvs && not (null unifiers && null givens))
- (vcat [ ambig_msg, binds_msg, potential_msg ])
+ (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ])
, show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes) ]
where
- (has_ambig_tvs, ambig_msg) = mkAmbigMsg ct
orig = ctOrigin ct
-
- potential_msg
- = ppWhen (not (null unifiers) && want_potential orig) $
- sdocWithDynFlags $ \dflags ->
- getPprStyle $ \sty ->
- pprPotentials dflags sty (ptext (sLit "Potential instances:")) unifiers
+ -- See Note [Highlighting ambiguous type variables]
+ lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs)
+ && not (null unifiers) && null givens
+
+ (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct
+ ambig_tvs = getAmbigTkvs ct
+
+ no_inst_msg
+ | lead_with_ambig
+ = ambig_msg <+> pprArising orig
+ $$ text "prevents the constraint" <+> quotes (pprParendType pred)
+ <+> text "from being solved."
+
+ | null givens
+ = addArising orig $ text "No instance for"
+ <+> pprParendType pred
+
+ | otherwise
+ = addArising orig $ text "Could not deduce"
+ <+> pprParendType pred
+
+ potential_msg
+ = ppWhen (not (null unifiers) && want_potential orig) $
+ sdocWithDynFlags $ \dflags ->
+ getPprStyle $ \sty ->
+ pprPotentials dflags sty potential_hdr unifiers
+
+ potential_hdr
+ = vcat [ ppWhen lead_with_ambig $
+ text "Probable fix: use a type annotation to specify what"
+ <+> pprQuotedList ambig_tvs <+> text "should be."
+ , ptext (sLit "These potential instance") <> plural unifiers
+ <+> text "exist:"]
-- Report "potential instances" only when the constraint arises
-- directly from the user's use of an overloaded function
@@ -1557,10 +1584,6 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped))
ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
ppr_skol skol_info = ppr skol_info
- no_inst_msg
- | null givens && null matches = ptext (sLit "No instance for") <+> pprParendType pred
- | otherwise = ptext (sLit "Could not deduce") <+> pprParendType pred
-
extra_note | any isFunTy (filterOut isKind tys)
= ptext (sLit "(maybe you haven't applied a function to enough arguments?)")
| className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T)
@@ -1648,6 +1671,24 @@ mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped))
]
]
+{- Note [Highlighting ambiguous type variables]
+-----------------------------------------------
+When we encounter ambiguous type variables (i.e. type variables
+that remain metavariables after type inference), we need a few more
+conditions before we can reason that *ambiguity* prevents constraints
+from being solved:
+ - We can't have any givens, as encountering a typeclass error
+ with given constraints just means we couldn't deduce
+ a solution satisfying those constraints and as such couldn't
+ bind the type variable to a known type.
+ - If we don't have any unifiers, we don't even have potential
+ instances from which an ambiguity could arise.
+ - Lastly, I don't want to mess with error reporting for
+ unknown runtime types so we just fall back to the old message there.
+Once these conditions are satisfied, we can safely say that ambiguity prevents
+the constraint from being solved. -}
+
+
usefulContext :: ReportErrCtxt -> TcPredType -> [SkolemInfo]
usefulContext ctxt pred
= go (cec_encl ctxt)
@@ -1814,19 +1855,19 @@ This test suggests -fprint-explicit-kinds when all the ambiguous type
variables are kind variables.
-}
-mkAmbigMsg :: Ct -> (Bool, SDoc)
-mkAmbigMsg ct
+mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence
+ -> Ct -> (Bool, SDoc)
+mkAmbigMsg prepend_msg ct
| null ambig_tkvs = (False, empty)
| otherwise = (True, msg)
where
- ambig_tkv_set = filterVarSet isAmbiguousTyVar (tyVarsOfCt ct)
- ambig_tkvs = varSetElems ambig_tkv_set
+ ambig_tkvs = getAmbigTkvs ct
(ambig_kvs, ambig_tvs) = partition isKindVar ambig_tkvs
msg | any isRuntimeUnkSkol ambig_tkvs -- See Note [Runtime skolems]
- = vcat [ ptext (sLit "Cannot resolve unknown runtime type") <> plural ambig_tvs
- <+> pprQuotedList ambig_tvs
- , ptext (sLit "Use :print or :force to determine these types")]
+ = vcat [ ptext (sLit "Cannot resolve unknown runtime type")
+ <> plural ambig_tvs <+> pprQuotedList ambig_tvs
+ , ptext (sLit "Use :print or :force to determine these types")]
| not (null ambig_tvs)
= pp_ambig (ptext (sLit "type")) ambig_tvs
@@ -1836,6 +1877,11 @@ mkAmbigMsg ct
, sdocWithDynFlags suggest_explicit_kinds ]
pp_ambig what tkvs
+ | prepend_msg -- "Ambiguous type variable 't0'"
+ = ptext (sLit "Ambiguous") <+> what <+> ptext (sLit "variable")
+ <> plural tkvs <+> pprQuotedList tkvs
+
+ | otherwise -- "The type variable 't0' is ambiguous"
= ptext (sLit "The") <+> what <+> ptext (sLit "variable") <> plural tkvs
<+> pprQuotedList tkvs <+> is_or_are tkvs <+> ptext (sLit "ambiguous")
@@ -1846,6 +1892,13 @@ mkAmbigMsg ct
| gopt Opt_PrintExplicitKinds dflags = empty
| otherwise = ptext (sLit "Use -fprint-explicit-kinds to see the kind arguments")
+getAmbigTkvs :: Ct -> [Var]
+getAmbigTkvs ct
+ = varSetElems ambig_tkv_set
+ where
+ ambig_tkv_set = filterVarSet isAmbiguousTyVar (tyVarsOfCt ct)
+
+
pprSkol :: SkolemInfo -> SrcLoc -> SDoc
pprSkol UnkSkol _
= ptext (sLit "is an unknown type variable")
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index c859e1f4c8..753ea052d0 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -18,8 +18,7 @@ This is where we do all the grimy bindings' generation.
module TcGenDeriv (
BagDerivStuff, DerivStuff(..),
- canDeriveAnyClass,
- genDerivedBinds,
+ hasBuiltinDeriving, canDeriveAnyClass,
FFoldType(..), functorLikeTraverse,
deepSubtypesContaining, foldDataConArgs,
mkCoerceClassMethEqn,
@@ -46,7 +45,7 @@ import MkCore ( eRROR_ID )
import PrelNames hiding (error_RDR)
import THNames
import Module ( moduleName, moduleNameString
- , modulePackageKey, packageKeyString )
+ , moduleUnitId, unitIdString )
import MkId ( coerceId )
import PrimOp
import SrcLoc
@@ -75,7 +74,6 @@ import StaticFlags( opt_PprStyle_Debug )
import ListSetOps ( assocMaybe )
import Data.List ( partition, intersperse )
-import Data.Maybe ( isNothing )
type BagDerivStuff = Bag DerivStuff
@@ -101,26 +99,26 @@ data DerivStuff -- Please add this auxiliary stuff
{-
************************************************************************
* *
- Top level function
+ Class deriving diagnostics
* *
************************************************************************
--}
-genDerivedBinds :: DynFlags -> (Name -> Fixity) -> Class -> SrcSpan -> TyCon
- -> ( LHsBinds RdrName -- The method bindings of the instance declaration
- , BagDerivStuff) -- Specifies extra top-level declarations needed
- -- to support the instance declaration
-genDerivedBinds dflags fix_env clas loc tycon
- | Just gen_fn <- assocMaybe gen_list (getUnique clas)
- = gen_fn loc tycon
+Only certain blessed classes can be used in a deriving clause. These classes
+are listed below in the definition of hasBuiltinDeriving (with the exception
+of Generic and Generic1, which are handled separately in TcGenGenerics).
- | otherwise
- -- Deriving any class simply means giving an empty instance, so no
- -- bindings have to be generated.
- = ASSERT2( isNothing (canDeriveAnyClass dflags tycon clas)
- , ppr "genDerivStuff: bad derived class" <+> ppr clas )
- (emptyBag, emptyBag)
+A class might be able to be used in a deriving clause if it -XDeriveAnyClass
+is willing to support it. The canDeriveAnyClass function checks if this is
+the case.
+-}
+hasBuiltinDeriving :: DynFlags
+ -> (Name -> Fixity)
+ -> Class
+ -> Maybe (SrcSpan
+ -> TyCon
+ -> (LHsBinds RdrName, BagDerivStuff))
+hasBuiltinDeriving dflags fix_env clas = assocMaybe gen_list (getUnique clas)
where
gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
gen_list = [ (eqClassKey, gen_Eq_binds)
@@ -1952,7 +1950,7 @@ gen_Lift_binds loc tycon
(primLitOp (mkBoxExp (nlHsVar a)))
where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
- pkg_name = packageKeyString . modulePackageKey
+ pkg_name = unitIdString . moduleUnitId
. nameModule $ tycon_name
mod_name = moduleNameString . moduleName . nameModule $ tycon_name
con_name = occNameString . nameOccName . dataConName $ data_con
diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs
index 9f260c986a..f69c137762 100644
--- a/compiler/typecheck/TcGenGenerics.hs
+++ b/compiler/typecheck/TcGenGenerics.hs
@@ -14,7 +14,6 @@ module TcGenGenerics (canDoGenerics, canDoGenerics1,
MetaTyCons, genGenericMetaTyCons,
gen_Generic_binds, get_gen1_constrained_tys) where
-import DynFlags
import HsSyn
import Type
import Kind ( isKind )
@@ -25,28 +24,29 @@ import TyCon
import FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom )
import FamInst
import Module ( Module, moduleName, moduleNameString
- , modulePackageKey, packageKeyString, getModule )
+ , moduleUnitId, unitIdString, getModule )
import IfaceEnv ( newGlobalBinder )
import Name hiding ( varName )
import RdrName
import BasicTypes
+import TysPrim
import TysWiredIn
import PrelNames
-import InstEnv
import TcEnv
-import MkId
import TcRnMonad
import HscTypes
import ErrUtils( Validity(..), andValid )
import BuildTyCl
import SrcLoc
import Bag
+import Inst
import VarSet (elemVarSet)
import Outputable
import FastString
import Util
import Control.Monad (mplus,forM)
+import Data.Maybe (isJust)
#include "HsVersions.h"
@@ -111,8 +111,7 @@ genGenericMetaTyCons tc =
-- both the tycon declarations and related instances
metaTyConsToDerivStuff :: TyCon -> MetaTyCons -> TcM BagDerivStuff
metaTyConsToDerivStuff tc metaDts =
- do dflags <- getDynFlags
- dClas <- tcLookupClass datatypeClassName
+ do dClas <- tcLookupClass datatypeClassName
d_dfun_name <- newDFunName' dClas tc
cClas <- tcLookupClass constructorClassName
c_dfun_names <- sequence [ (conTy,) <$> newDFunName' cClas tc
@@ -127,16 +126,18 @@ metaTyConsToDerivStuff tc metaDts =
let
(dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
mk_inst clas tc dfun_name
- = mkLocalInstance (mkDictFunId dfun_name [] [] clas tys)
- OverlapFlag { overlapMode = (NoOverlap "")
- , isSafeOverlap = safeLanguageOn dflags }
- [] clas tys
+ = newClsInst (Just (NoOverlap "")) dfun_name [] [] clas tys
where
tys = [mkTyConTy tc]
+
+ let d_metaTycon = metaD metaDts
+ d_inst <- mk_inst dClas d_metaTycon d_dfun_name
+ c_insts <- sequence [ mk_inst cClas c ds | (c, ds) <- c_dfun_names ]
+ s_insts <- mapM (mapM (\(s,ds) -> mk_inst sClas s ds)) s_dfun_names
+
+ let
-- Datatype
- d_metaTycon = metaD metaDts
- d_inst = mk_inst dClas d_metaTycon d_dfun_name
d_binds = InstBindings { ib_binds = dBinds
, ib_tyvars = []
, ib_pragmas = []
@@ -145,7 +146,6 @@ metaTyConsToDerivStuff tc metaDts =
d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds })
-- Constructor
- c_insts = [ mk_inst cClas c ds | (c, ds) <- c_dfun_names ]
c_binds = [ InstBindings { ib_binds = c
, ib_tyvars = []
, ib_pragmas = []
@@ -156,7 +156,6 @@ metaTyConsToDerivStuff tc metaDts =
| (is,bs) <- myZip1 c_insts c_binds ]
-- Selector
- s_insts = map (map (\(s,ds) -> mk_inst sClas s ds)) s_dfun_names
s_binds = [ [ InstBindings { ib_binds = s
, ib_tyvars = []
, ib_pragmas = []
@@ -278,14 +277,19 @@ 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 (NotValid (ppr dc <+> text "must not have unlifted or polymorphic arguments"))
+ then (NotValid (ppr dc <+> text
+ "must not have exotic unlifted or polymorphic arguments"))
else (if (not (isVanillaDataCon dc))
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)
+ bad_arg_type ty = (isUnLiftedType ty && not (allowedUnliftedTy ty))
+ || not (isTauTy ty)
+
+allowedUnliftedTy :: Type -> Bool
+allowedUnliftedTy = isJust . unboxedRepRDRs
mergeErrors :: [Validity] -> Validity
mergeErrors [] = IsValid
@@ -586,23 +590,29 @@ tc_mkRepTy :: -- Gen0_ or Gen1_, for Rep or Rep1
-> TcM Type
tc_mkRepTy gk_ tycon metaDts =
do
- d1 <- tcLookupTyCon d1TyConName
- c1 <- tcLookupTyCon c1TyConName
- s1 <- tcLookupTyCon s1TyConName
- nS1 <- tcLookupTyCon noSelTyConName
- rec0 <- tcLookupTyCon rec0TyConName
- rec1 <- tcLookupTyCon rec1TyConName
- par1 <- tcLookupTyCon par1TyConName
- u1 <- tcLookupTyCon u1TyConName
- v1 <- tcLookupTyCon v1TyConName
- plus <- tcLookupTyCon sumTyConName
- times <- tcLookupTyCon prodTyConName
- comp <- tcLookupTyCon compTyConName
+ d1 <- tcLookupTyCon d1TyConName
+ c1 <- tcLookupTyCon c1TyConName
+ s1 <- tcLookupTyCon s1TyConName
+ nS1 <- tcLookupTyCon noSelTyConName
+ rec0 <- tcLookupTyCon rec0TyConName
+ rec1 <- tcLookupTyCon rec1TyConName
+ par1 <- tcLookupTyCon par1TyConName
+ u1 <- tcLookupTyCon u1TyConName
+ v1 <- tcLookupTyCon v1TyConName
+ plus <- tcLookupTyCon sumTyConName
+ times <- tcLookupTyCon prodTyConName
+ comp <- tcLookupTyCon compTyConName
+ uAddr <- tcLookupTyCon uAddrTyConName
+ uChar <- tcLookupTyCon uCharTyConName
+ uDouble <- tcLookupTyCon uDoubleTyConName
+ uFloat <- tcLookupTyCon uFloatTyConName
+ uInt <- tcLookupTyCon uIntTyConName
+ uWord <- tcLookupTyCon uWordTyConName
let mkSum' a b = mkTyConApp plus [a,b]
mkProd a b = mkTyConApp times [a,b]
mkComp a b = mkTyConApp comp [a,b]
- mkRec0 a = mkTyConApp rec0 [a]
+ mkRec0 a = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 a
mkRec1 a = mkTyConApp rec1 [a]
mkPar1 = mkTyConTy par1
mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)]
@@ -650,6 +660,28 @@ tc_mkRepTy gk_ tycon metaDts =
return (mkD tycon)
+-- Given the TyCons for each URec-related type synonym, check to see if the
+-- given type is an unlifted type that generics understands. If so, return
+-- its representation type. Otherwise, return Rec0.
+-- See Note [Generics and unlifted types]
+mkBoxTy :: TyCon -- UAddr
+ -> TyCon -- UChar
+ -> TyCon -- UDouble
+ -> TyCon -- UFloat
+ -> TyCon -- UInt
+ -> TyCon -- UWord
+ -> TyCon -- Rec0
+ -> Type
+ -> Type
+mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 ty
+ | ty == addrPrimTy = mkTyConTy uAddr
+ | ty == charPrimTy = mkTyConTy uChar
+ | ty == doublePrimTy = mkTyConTy uDouble
+ | ty == floatPrimTy = mkTyConTy uFloat
+ | ty == intPrimTy = mkTyConTy uInt
+ | ty == wordPrimTy = mkTyConTy uWord
+ | otherwise = mkTyConApp rec0 [ty]
+
--------------------------------------------------------------------------------
-- Meta-information
--------------------------------------------------------------------------------
@@ -716,7 +748,7 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
$ tyConName_user
moduleName_matches = mkStringLHS . moduleNameString . moduleName
. nameModule . tyConName $ tycon
- pkgName_matches = mkStringLHS . packageKeyString . modulePackageKey
+ pkgName_matches = mkStringLHS . unitIdString . moduleUnitId
. nameModule . tyConName $ tycon
isNewtype_matches = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
@@ -781,22 +813,22 @@ mk1Sum gk_ us i n datacon = (from_alt, to_alt)
from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E gk_ us' datacon_varTys))
- to_alt = (mkM1_P (genLR_P i n (mkProd_P gk us' datacon_vars)), to_alt_rhs)
- -- These M1s are meta-information for the datatype
+ to_alt = ( mkM1_P (genLR_P i n (mkProd_P gk us' datacon_varTys))
+ , to_alt_rhs
+ ) -- These M1s are meta-information for the datatype
to_alt_rhs = case gk_ of
Gen0_DC -> nlHsVarApps datacon_rdr datacon_vars
Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys
where
argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where
converter = argTyFold argVar $ ArgTyAlg
- {ata_rec0 = const $ nlHsVar unK1_RDR,
+ {ata_rec0 = nlHsVar . unboxRepRDR,
ata_par1 = nlHsVar unPar1_RDR,
ata_rec1 = const $ nlHsVar unRec1_RDR,
ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)
`nlHsCompose` nlHsVar unComp1_RDR}
-
-- Generates the L1/R1 sum pattern
genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
genLR_P i n p
@@ -832,35 +864,54 @@ mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
prod a b = prodDataCon_RDR `nlHsApps` [a,b]
wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr RdrName
-wrapArg_E Gen0_DC (var, _) = mkM1_E (k1DataCon_RDR `nlHsVarApps` [var])
+wrapArg_E Gen0_DC (var, ty) = mkM1_E $
+ boxRepRDR ty `nlHsVarApps` [var]
-- This M1 is meta-information for the selector
-wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $ converter ty `nlHsApp` nlHsVar var
+wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $
+ converter ty `nlHsApp` nlHsVar var
-- This M1 is meta-information for the selector
where converter = argTyFold argVar $ ArgTyAlg
- {ata_rec0 = const $ nlHsVar k1DataCon_RDR,
+ {ata_rec0 = nlHsVar . boxRepRDR,
ata_par1 = nlHsVar par1DataCon_RDR,
ata_rec1 = const $ nlHsVar rec1DataCon_RDR,
ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`
(nlHsVar fmap_RDR `nlHsApp` cnv)}
+boxRepRDR :: Type -> RdrName
+boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs
+unboxRepRDR :: Type -> RdrName
+unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs
+
+-- Retrieve the RDRs associated with each URec data family instance
+-- constructor. See Note [Generics and unlifted types]
+unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName)
+unboxedRepRDRs ty
+ | ty == addrPrimTy = Just (uAddrDataCon_RDR, uAddrHash_RDR)
+ | ty == charPrimTy = Just (uCharDataCon_RDR, uCharHash_RDR)
+ | ty == doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR)
+ | ty == floatPrimTy = Just (uFloatDataCon_RDR, uFloatHash_RDR)
+ | ty == intPrimTy = Just (uIntDataCon_RDR, uIntHash_RDR)
+ | ty == wordPrimTy = Just (uWordDataCon_RDR, uWordHash_RDR)
+ | otherwise = Nothing
-- Build a product pattern
-mkProd_P :: GenericKind -- Gen0 or Gen1
- -> US -- Base for unique names
- -> [RdrName] -- List of variables to match
- -> LPat RdrName -- Resulting product pattern
-mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR)
-mkProd_P gk _ vars = mkM1_P (foldBal prod appVars)
+mkProd_P :: GenericKind -- Gen0 or Gen1
+ -> US -- Base for unique names
+ -> [(RdrName, Type)] -- List of variables to match,
+ -- along with their types
+ -> LPat RdrName -- Resulting product pattern
+mkProd_P _ _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR)
+mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars)
-- These M1s are meta-information for the constructor
where
- appVars = map (wrapArg_P gk) vars
+ appVars = unzipWith (wrapArg_P gk) varTys
prod a b = prodDataCon_RDR `nlConPat` [a,b]
-wrapArg_P :: GenericKind -> RdrName -> LPat RdrName
-wrapArg_P Gen0 v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
+wrapArg_P :: GenericKind -> RdrName -> Type -> LPat RdrName
+wrapArg_P Gen0 v ty = mkM1_P (boxRepRDR ty `nlConVarPat` [v])
-- This M1 is meta-information for the selector
-wrapArg_P Gen1 v = m1DataCon_RDR `nlConVarPat` [v]
+wrapArg_P Gen1 v _ = m1DataCon_RDR `nlConVarPat` [v]
mkGenericLocal :: US -> RdrName
mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
@@ -883,3 +934,17 @@ foldBal' _ x [] = x
foldBal' _ _ [y] = y
foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l
in foldBal' op x a `op` foldBal' op x b
+
+{-
+Note [Generics and unlifted types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Normally, all constants are marked with K1/Rec0. The exception to this rule is
+when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In
+that case, we must use a data family instance of URec (from GHC.Generics) to
+mark it. As a result, before we can generate K1 or unK1, we must first check
+to see if the type is actually one of the unlifted types for which URec has a
+data family instance; if so, we generate that instead.
+
+See wiki:Commentary/Compiler/GenericDeriving#Handlingunliftedtypes for more
+details on why URec is implemented the way it is.
+-}
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index d5dee95b00..c97e4e128c 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -15,7 +15,7 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
import HsSyn
import TcBinds
import TcTyClsDecls
-import TcClassDcl( tcClassDecl2,
+import TcClassDcl( tcClassDecl2, tcATDefault,
HsSigFun, lookupHsSig, mkHsSigFun,
findMethodBind, instantiateMethod )
import TcPat ( TcIdSigInfo, addInlinePrags, completeIdSigPolyId, lookupPragEnv, emptyPragEnv )
@@ -32,7 +32,6 @@ import TcDeriv
import TcEnv
import TcHsType
import TcUnify
-import Coercion ( pprCoAxiom {- , isReflCo, mkSymCo, mkSubCo -} )
import MkCore ( nO_METHOD_BINDING_ERROR_ID )
import Type
import TcEvidence
@@ -62,7 +61,7 @@ import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )
import Control.Monad
import Maybes
-import Data.List ( mapAccumL, partition )
+import Data.List ( partition )
{-
Typechecking instance declarations is done in two passes. The first
@@ -537,7 +536,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)
`unionNameSet`
mkNameSet (map (unLoc . dfid_tycon . unLoc) adts)
- ; tyfam_insts1 <- mapM (tcATDefault loc mini_subst defined_ats)
+ ; tyfam_insts1 <- mapM (tcATDefault True loc mini_subst defined_ats)
(classATItems clas)
-- Finally, construct the Core representation of the instance.
@@ -559,51 +558,6 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
, deriv_infos ) }
-tcATDefault :: SrcSpan -> TvSubst -> NameSet -> ClassATItem -> TcM [FamInst]
--- ^ Construct default instances for any associated types that
--- aren't given a user definition
--- Returns [] or singleton
-tcATDefault loc 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, _loc) <- 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 (L loc (tyConName fam_tc)) pat_tys'
- ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' fam_tc pat_tys' rhs'
- -- NB: no validity check. We check validity of default instances
- -- in the class definition. Because type instance arguments cannot
- -- be type family applications and cannot be polytypes, the
- -- validity check is redundant.
-
- ; 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)
-
{-
************************************************************************
* *
@@ -1576,16 +1530,6 @@ derivBindCtxt sel_id clas tys
<+> quotes (pprClassPred clas tys) <> colon)
, nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
-warnMissingMethodOrAT :: String -> Name -> TcM ()
-warnMissingMethodOrAT what name
- = do { warn <- woptM Opt_WarnMissingMethods
- ; traceTc "warn" (ppr name <+> ppr warn <+> ppr (not (startsWithUnderscore (getOccName name))))
- ; warnTc (warn -- Warn only if -fwarn-missing-methods
- && not (startsWithUnderscore (getOccName name)))
- -- Don't warn about _foo methods
- (ptext (sLit "No explicit") <+> text what <+> ptext (sLit "or default declaration for")
- <+> quotes (ppr name)) }
-
warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM ()
warnUnsatisfiedMinimalDefinition mindef
= do { warn <- woptM Opt_WarnMissingMethods
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index ebb7797673..70afae44ae 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -890,6 +890,8 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
; let fun_ty = mkFunTys pat_tys body_ty
-- NB. do the <$>,<*> operators first, we don't want type errors here
+ -- i.e. goOps before goArgs
+ -- See Note [Treat rebindable syntax first]
; let (ops, args) = unzip pairs
; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys)
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index b4bc78205c..529e6b200b 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -76,7 +76,7 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args
- ; (qtvs, req_dicts, _mr_bites, ev_binds) <- simplifyInfer tclvl False [] named_taus wanted
+ ; (qtvs, req_dicts, ev_binds) <- simplifyInfer tclvl False [] named_taus wanted
; (ex_vars, prov_dicts) <- tcCollectEx lpat'
; let univ_tvs = filter (not . (`elemVarSet` ex_vars)) qtvs
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 9a1d9e118f..35ac44f0bd 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -1789,13 +1789,13 @@ tcRnExpr hsc_env rdr_expr
let { fresh_it = itName uniq (getLoc rdr_expr) } ;
((_tc_expr, res_ty), tclvl, lie) <- pushLevelAndCaptureConstraints $
tcInferRho rn_expr ;
- ((qtvs, dicts, _, _), lie_top) <- captureConstraints $
- {-# SCC "simplifyInfer" #-}
- simplifyInfer tclvl
- False {- No MR for now -}
- [] {- No sig vars -}
- [(fresh_it, res_ty)]
- lie ;
+ ((qtvs, dicts, _), lie_top) <- captureConstraints $
+ {-# SCC "simplifyInfer" #-}
+ simplifyInfer tclvl
+ False {- No MR for now -}
+ [] {- No sig vars -}
+ [(fresh_it, res_ty)]
+ lie ;
-- Wanted constraints from static forms
stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
@@ -2071,7 +2071,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 stablePackageKeyCmp $ imp_dep_pkgs imports)]
+ ppr (sortBy stableUnitIdCmp $ 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.hs b/compiler/typecheck/TcRnMonad.hs
index 90e4bb98f4..601b030f74 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -125,7 +125,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
tcg_rdr_env = emptyGlobalRdrEnv,
tcg_fix_env = emptyNameEnv,
tcg_field_env = emptyNameEnv,
- tcg_default = if modulePackageKey mod == primPackageKey
+ tcg_default = if moduleUnitId mod == primUnitId
then Just [] -- See Note [Default types]
else Nothing,
tcg_type_env = emptyNameEnv,
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index d25fdb4425..d1f3c0dbd8 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -28,6 +28,9 @@ module TcRnTypes(
IfGblEnv(..), IfLclEnv(..),
tcVisibleOrphanMods,
+ -- Frontend types (shouldn't really be here)
+ FrontendResult(..),
+
-- Renamer types
ErrCtxt, RecFieldEnv,
ImportAvails(..), emptyImportAvails, plusImportAvails,
@@ -327,6 +330,18 @@ data DsMetaVal
************************************************************************
-}
+-- | 'FrontendResult' describes the result of running the
+-- frontend of a Haskell module. Usually, you'll get
+-- a 'FrontendTypecheck', since running the frontend involves
+-- typechecking a program, but for an hs-boot merge you'll
+-- just get a ModIface, since no actual typechecking occurred.
+--
+-- This data type really should be in HscTypes, but it needs
+-- to have a TcGblEnv which is only defined here.
+data FrontendResult
+ = FrontendTypecheck TcGblEnv
+ | FrontendMerge ModIface
+
-- | 'TcGblEnv' describes the top-level of the module at the
-- point at which the typechecker is finished work.
-- It is this structure that is handed on to the desugarer
@@ -985,17 +1000,17 @@ data ImportAvails
-- compiling M might not need to consult X.hi, but X
-- is still listed in M's dependencies.
- imp_dep_pkgs :: [PackageKey],
+ imp_dep_pkgs :: [UnitId],
-- ^ 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 :: [PackageKey],
+ imp_trust_pkgs :: [UnitId],
-- ^ 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 (PackageKey, Bool)
+ -- While perhaps making imp_dep_pkgs a tuple of (UnitId, 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.
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index 8babe0fc7d..f97d191dee 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -8,7 +8,7 @@ module TcSimplify(
simplifyTop, simplifyInteractive,
solveWantedsTcM,
- -- For Rules we need these twoo
+ -- For Rules we need these two
solveWanteds, runTcS
) where
@@ -18,6 +18,7 @@ import Bag
import Class ( classKey )
import Class ( Class )
import DynFlags ( ExtensionFlag( Opt_AllowAmbiguousTypes )
+ , WarningFlag ( Opt_WarnMonomorphism )
, DynFlags( solverIterations ) )
import Inst
import Id ( idType )
@@ -76,7 +77,7 @@ simplifyTop wanteds
; unless (isEmptyCts unsafe_ol) $ do {
-- grab current error messages and clear, warnAllUnsolved will
-- update error messages which we'll grab and then restore saved
- -- messges.
+ -- messages.
; errs_var <- getErrsVar
; saved_msg <- TcRn.readTcRef errs_var
; TcRn.writeTcRef errs_var emptyMessages
@@ -181,15 +182,15 @@ We have considered two design choices for where/when to apply defaulting.
(i) Do it in SimplCheck mode only /whenever/ you try to solve some
simple constraints, maybe deep inside the context of implications.
This used to be the case in GHC 7.4.1.
- (ii) Do it in a tight loop at simplifyTop, once all other constraint has
+ (ii) Do it in a tight loop at simplifyTop, once all other constraints have
finished. This is the current story.
Option (i) had many disadvantages:
- a) First it was deep inside the actual solver,
- b) Second it was dependent on the context (Infer a type signature,
+ a) Firstly, it was deep inside the actual solver.
+ b) Secondly, it was dependent on the context (Infer a type signature,
or Check a type signature, or Interactive) since we did not want
to always start defaulting when inferring (though there is an exception to
- this see Note [Default while Inferring])
+ this, see Note [Default while Inferring]).
c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs:
f :: Int -> Bool
f x = const True (\y -> let w :: a -> a
@@ -202,7 +203,8 @@ Option (i) had many disadvantages:
Instead our new defaulting story is to pull defaulting out of the solver loop and
go with option (i), implemented at SimplifyTop. Namely:
- - First have a go at solving the residual constraint of the whole program
+ - First, have a go at solving the residual constraint of the whole
+ program
- Try to approximate it with a simple constraint
- Figure out derived defaulting equations for that simple constraint
- Go round the loop again if you did manage to get some equations
@@ -257,7 +259,7 @@ than one path, this alternative doesn't work.
Note [Safe Haskell Overlapping Instances Implementation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-How is this implemented? It's compilcated! So we'll step through it all:
+How is this implemented? It's complicated! So we'll step through it all:
1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where
we check if a particular type-class method call is safe or unsafe. We do this
@@ -265,19 +267,20 @@ How is this implemented? It's compilcated! So we'll step through it all:
list of instances that are unsafe to overlap. When the method call is safe,
the list is null.
- 2) `TcInteract.matchClassInst` -- This module drives the instance resolution /
- dictionary generation. The return type is `LookupInstResult`, which either
- says no instance matched, or one found and if it was a safe or unsafe overlap.
+ 2) `TcInteract.matchClassInst` -- This module drives the instance resolution
+ / dictionary generation. The return type is `LookupInstResult`, which either
+ says no instance matched, or one found, and if it was a safe or unsafe
+ overlap.
3) `TcInteract.doTopReactDict` -- Takes a dictionary / class constraint and
tries to resolve it by calling (in part) `matchClassInst`. The resolving
mechanism has a work list (of constraints) that it process one at a time. If
the constraint can't be resolved, it's added to an inert set. When compiling
- an `-XSafe` or `-XTrustworthy` module we follow this approach as we know
+ an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know
compilation should fail. These are handled as normal constraint resolution
failures from here-on (see step 6).
- Otherwise, we may be inferring safety (or using `-fwarn-unsafe`) and
+ Otherwise, we may be inferring safety (or using `-fwarn-unsafe`), and
compilation should succeed, but print warnings and/or mark the compiled module
as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds
the unsafe (but resolved!) constraint to the `inert_safehask` field of
@@ -297,12 +300,12 @@ How is this implemented? It's compilcated! So we'll step through it all:
instance constraints, it calls `TcErrors.warnAllUnsolved`. Both functions
convert constraints into a warning message for the user.
- 6) `TcErrors.*Unsolved` -- Generates error messages for conastraints by
+ 6) `TcErrors.*Unsolved` -- Generates error messages for constraints by
actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we
- know is the constraint that is unresolved or unsafe. For dictionary, this is
- know we need a dictionary of type C, but not what instances are available and
- how they overlap. So we once again call `lookupInstEnv` to figure that out so
- we can generate a helpful error message.
+ know is the constraint that is unresolved or unsafe. For dictionary, all we
+ know is that we need a dictionary of type C, but not what instances are
+ available and how they overlap. So we once again call `lookupInstEnv` to
+ figure that out so we can generate a helpful error message.
7) `TcSimplify.simplifyTop` -- In the case of `warnAllUnsolved` for resolved,
but unsafe dictionary constraints, we collect the generated warning message
@@ -344,7 +347,7 @@ simplifyInteractive wanteds
------------------
simplifyDefault :: ThetaType -- Wanted; has no type variables in it
- -> TcM () -- Succeeds iff the constraint is soluble
+ -> TcM () -- Succeeds if the constraint is soluble
simplifyDefault theta
= do { traceTc "simplifyInteractive" empty
; wanted <- newWanteds DefaultOrigin theta
@@ -393,16 +396,13 @@ simplifyInfer :: TcLevel -- Used when generating the constraints
-> WantedConstraints
-> TcM ([TcTyVar], -- Quantify over these type variables
[EvVar], -- ... and these constraints (fully zonked)
- Bool, -- The monomorphism restriction did something
- -- so the results type is not as general as
- -- it could be
TcEvBinds) -- ... binding these evidence variables
simplifyInfer rhs_tclvl apply_mr sig_qtvs name_taus wanteds
| isEmptyWC wanteds
= do { gbl_tvs <- tcGetGlobalTyVars
; qtkvs <- quantifyTyVars gbl_tvs (tyVarsOfTypes (map snd name_taus))
; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)
- ; return (qtkvs, [], False, emptyTcEvBinds) }
+ ; return (qtkvs, [], emptyTcEvBinds) }
| otherwise
= do { traceTc "simplifyInfer {" $ vcat
@@ -413,7 +413,7 @@ simplifyInfer rhs_tclvl apply_mr sig_qtvs name_taus wanteds
]
-- Historical note: Before step 2 we used to have a
- -- HORRIBLE HACK described in Note [Avoid unecessary
+ -- HORRIBLE HACK described in Note [Avoid unnecessary
-- constraint simplification] but, as described in Trac
-- #4361, we have taken in out now. That's why we start
-- with step 2!
@@ -451,7 +451,7 @@ simplifyInfer rhs_tclvl apply_mr sig_qtvs name_taus wanteds
; gbl_tvs <- tcGetGlobalTyVars
-- Miminise quant_cand. We are not interested in any evidence
-- produced, because we are going to simplify wanted_transformed
- -- again later. All we want here is the predicates over which to
+ -- again later. All we want here are the predicates over which to
-- quantify.
--
-- If any meta-tyvar unifications take place (unlikely), we'll
@@ -473,8 +473,8 @@ simplifyInfer rhs_tclvl apply_mr sig_qtvs name_taus wanteds
-- Decide what type variables and constraints to quantify
; zonked_taus <- mapM (TcM.zonkTcType . snd) name_taus
; let zonked_tau_tvs = tyVarsOfTypes zonked_taus
- ; (qtvs, bound_theta, mr_bites)
- <- decideQuantification apply_mr sig_qtvs quant_pred_candidates zonked_tau_tvs
+ ; (qtvs, bound_theta) <- decideQuantification apply_mr sig_qtvs name_taus
+ quant_pred_candidates zonked_tau_tvs
-- Emit an implication constraint for the
-- remaining constraints from the RHS
@@ -525,11 +525,10 @@ simplifyInfer rhs_tclvl apply_mr sig_qtvs name_taus wanteds
, ptext (sLit "promote_tvs=") <+> ppr promote_tvs
, ptext (sLit "bound_theta =") <+> vcat [ ppr v <+> dcolon <+> ppr (idType v)
| v <- bound_ev_vars]
- , ptext (sLit "mr_bites =") <+> ppr mr_bites
, ptext (sLit "qtvs =") <+> ppr qtvs
, ptext (sLit "implic =") <+> ppr implic ]
- ; return ( qtvs, bound_ev_vars, mr_bites, TcEvBinds ev_binds_var) }
+ ; return ( qtvs, bound_ev_vars, TcEvBinds ev_binds_var) }
{-
************************************************************************
@@ -561,26 +560,36 @@ If the monomorphism restriction does not apply, then we quantify as follows:
created skolems.
If the MR does apply, mono_tvs includes all the constrained tyvars,
-and the quantified constraints are empty.
+and the quantified constraints are empty/insoluble
-}
decideQuantification
:: Bool -- Apply monomorphism restriction
-> [TcTyVar]
+ -> [(Name, TcTauType)] -- Variables to be generalised (just for error msg)
-> [PredType] -> TcTyVarSet -- Constraints and type variables from RHS
- -> TcM ( [TcTyVar] -- Quantify over these tyvars (skolems)
- , [PredType] -- and this context (fully zonked)
- , Bool ) -- Did the MR bite?
+ -> TcM ( [TcTyVar] -- Quantify over these tyvars (skolems)
+ , [PredType]) -- and this context (fully zonked)
-- See Note [Deciding quantification]
-decideQuantification apply_mr sig_qtvs constraints zonked_tau_tvs
+decideQuantification apply_mr sig_qtvs name_taus constraints zonked_tau_tvs
| apply_mr -- Apply the Monomorphism restriction
= do { gbl_tvs <- tcGetGlobalTyVars
; let constrained_tvs = tyVarsOfTypes constraints
mono_tvs = gbl_tvs `unionVarSet` constrained_tvs
mr_bites = constrained_tvs `intersectsVarSet` zonked_tau_tvs
; qtvs <- quantify_tvs mono_tvs zonked_tau_tvs
- ; traceTc "decideQuantification 1" (vcat [ppr constraints, ppr gbl_tvs, ppr mono_tvs, ppr qtvs])
- ; return (qtvs, [], mr_bites) }
+ ; traceTc "decideQuantification 1" (vcat [ppr constraints, ppr gbl_tvs, ppr mono_tvs
+ , ppr qtvs, ppr mr_bites])
+
+ -- Warn about the monomorphism restriction
+ ; warn_mono <- woptM Opt_WarnMonomorphism
+ ; warnTc (warn_mono && mr_bites) $
+ hang (ptext (sLit "The Monomorphism Restriction applies to the binding")
+ <> plural bndrs <+> ptext (sLit "for") <+> pp_bndrs)
+ 2 (ptext (sLit "Consider giving a type signature for")
+ <+> if isSingleton bndrs then pp_bndrs else ptext (sLit "these binders"))
+
+ ; return (qtvs, []) }
| otherwise
= do { gbl_tvs <- tcGetGlobalTyVars
@@ -596,9 +605,11 @@ decideQuantification apply_mr sig_qtvs constraints zonked_tau_tvs
; traceTc "decideQuantification 2" (vcat [ppr constraints, ppr gbl_tvs, ppr mono_tvs
, ppr tau_tvs_plus, ppr qtvs, ppr min_theta])
- ; return (qtvs, min_theta, False) }
+ ; return (qtvs, min_theta) }
where
+ bndrs = map fst name_taus
+ pp_bndrs = pprWithCommas (quotes . ppr) bndrs
quantify_tvs mono_tvs tau_tvs -- See Note [Which type variable to quantify]
| null sig_qtvs = quantifyTyVars mono_tvs tau_tvs
| otherwise = quantifyTyVars (mono_tvs `delVarSetList` sig_qtvs)
@@ -608,7 +619,7 @@ decideQuantification apply_mr sig_qtvs constraints zonked_tau_tvs
pickQuantifiablePreds :: TyVarSet -- Quantifying over these
-> TcThetaType -- Proposed constraints to quantify
-> TcM TcThetaType -- A subset that we can actually quantify
--- This function decides whether a particular constraint shoudl be
+-- This function decides whether a particular constraint should be
-- quantified over, given the type variables that are being quantified
pickQuantifiablePreds qtvs theta
= do { let flex_ctxt = True -- Quantify over non-tyvar constraints, even without
@@ -666,11 +677,11 @@ When choosing type variables to quantify, the basic plan is to
quantify over all type variables that are
* free in the tau_tvs, and
* not forced to be monomorphic (mono_tvs),
- for example by being free in the environment
+ for example by being free in the environment.
-However, for a pattern binding, or with wildards, we might
+However, for a pattern binding, or with wildcards, we might
be doing inference *in the presence of a type signature*.
-Mostly, if there is a signature we use CheckGen, not InferGen,
+Mostly, if there is a signature, we use CheckGen, not InferGen,
but with pattern bindings or wildcards we might do inference
and still have a type signature. For example:
f :: _ -> a
@@ -696,7 +707,7 @@ its call site. (At worst, imagine (Int ~ Bool)).
However, consider this
forall a. (F [a] ~ Int) => blah
-Should we quantify over the (F [a] ~ Int). Perhaps yes, because at the call
+Should we quantify over the (F [a] ~ Int)? Perhaps yes, because at the call
site we will know 'a', and perhaps we have instance F [Bool] = Int.
So we *do* quantify over a type-family equality where the arguments mention
the quantified variables.
@@ -704,7 +715,7 @@ the quantified variables.
Note [Growing the tau-tvs using constraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(growThetaTyVars insts tvs) is the result of extending the set
- of tyvars tvs using all conceivable links from pred
+ of tyvars, tvs, using all conceivable links from pred
E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e}
Then growThetaTyVars preds tvs = {a,b,c}
@@ -757,7 +768,7 @@ it before doing the isInsolubleWC test! (Trac #8262)
Note [Default while Inferring]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Our current plan is that defaulting only happens at simplifyTop and
-not simplifyInfer. This may lead to some insoluble deferred constraints
+not simplifyInfer. This may lead to some insoluble deferred constraints.
Example:
instance D g => C g Int b
@@ -769,14 +780,14 @@ Now, if we try to default (alpha := Int) we will be able to refine the implicati
(forall b. 0 => C gamma Int b)
which can then be simplified further to
(forall b. 0 => D gamma)
-Finally we /can/ approximate this implication with (D gamma) and infer the quantified
+Finally, we /can/ approximate this implication with (D gamma) and infer the quantified
type: forall g. D g => g -> g
Instead what will currently happen is that we will get a quantified type
(forall g. g -> g) and an implication:
forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha
-which, even if the simplifyTop defaults (alpha := Int) we will still be left with an
+Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an
unsolvable implication:
forall g. 0 => (forall b. 0 => D g)
@@ -784,8 +795,8 @@ The concrete example would be:
h :: C g a s => g -> a -> ST s a
f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1)
-But it is quite tedious to do defaulting and resolve the implication constraints and
-we have not observed code breaking because of the lack of defaulting in inference so
+But it is quite tedious to do defaulting and resolve the implication constraints, and
+we have not observed code breaking because of the lack of defaulting in inference, so
we don't do it for now.
@@ -801,7 +812,7 @@ mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint
to check the original wanted.
-Note [Avoid unecessary constraint simplification]
+Note [Avoid unnecessary constraint simplification]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-------- NB NB NB (Jun 12) -------------
This note not longer applies; see the notes with Trac #4361.
@@ -864,9 +875,9 @@ to compile, and it will run fine unless we evaluate `a`. This is what
`deferErrorsToRuntime` does.
It does this by keeping track of which errors correspond to which coercion
-in TcErrors (with ErrEnv). TcErrors.reportTidyWanteds does not print the errors
-and does not fail if -fdefer-type-errors is on, so that we can continue
-compilation. The errors are turned into warnings in `reportUnsolved`.
+in TcErrors (with ErrEnv). TcErrors.reportTidyWanteds does not print the
+errors, and does not fail if -fdefer-type-errors is on, so that we can
+continue compilation. The errors are turned into warnings in `reportUnsolved`.
-}
solveWantedsTcM :: [CtEvidence] -> TcM WantedConstraints
@@ -1128,10 +1139,10 @@ neededEvVars :: EvBindMap -> VarSet -> VarSet
-- Find all the evidence variables that are "needed",
-- and then delete all those bound by the evidence bindings
-- A variable is "needed" if
--- a) it is free in the RHS of a Wanted EvBind (add_wanted)
--- b) it is free in the RHS of an EvBind whose LHS is needed (transClo)
+-- a) it is free in the RHS of a Wanted EvBind (add_wanted),
+-- b) it is free in the RHS of an EvBind whose LHS is needed (transClo),
-- c) it is in the ic_need_evs of a nested implication (initial_seeds)
--- (after removing the givens)
+-- (after removing the givens).
neededEvVars ev_binds initial_seeds
= needed `minusVarSet` bndrs
where
@@ -1168,7 +1179,7 @@ constraints of a type signature (or instance declaration) are
redundant, and can be omitted. Here is an overview of how it
works:
------ What is a redudant constraint?
+----- What is a redundant constraint?
* The things that can be redundant are precisely the Given
constraints of an implication.
@@ -1180,7 +1191,7 @@ works:
b) It is not needed by the Wanted constraints covered by the
implication E.g.
f :: Eq a => a -> Bool
- f x = True -- Equality not uesd
+ f x = True -- Equality not used
* To find (a), when we have two Given constraints,
we must be careful to drop the one that is a naked variable (if poss).
@@ -1200,20 +1211,20 @@ works:
* When the constraint solver finishes solving all the wanteds in
an implication, it sets its status to IC_Solved
- - The ics_dead field of IC_Solved records the subset of the ic_given
- of this implication that are redundant (not needed).
+ - The ics_dead field, of IC_Solved, records the subset of this implication's
+ ic_given that are redundant (not needed).
- The ics_need field of IC_Solved then records all the
- in-scope (given) evidence variables, bound by the context, that
+ in-scope (given) evidence variables bound by the context, that
were needed to solve this implication, including all its nested
implications. (We remove the ic_given of this implication from
the set, of course.)
* We compute which evidence variables are needed by an implication
in setImplicationStatus. A variable is needed if
- a) it is free in the RHS of a Wanted EvBind
- b) it is free in the RHS of an EvBind whose LHS is needed
- c) it is in the ics_need of a nested implication
+ a) it is free in the RHS of a Wanted EvBind,
+ b) it is free in the RHS of an EvBind whose LHS is needed,
+ c) it is in the ics_need of a nested implication.
* We need to be careful not to discard an implication
prematurely, even one that is fully solved, because we might
@@ -1221,7 +1232,7 @@ works:
report a constraint as redundant. But we can discard it once
its free vars have been incorporated into its parent; or if it
simply has no free vars. This careful discarding is also
- handled in setImplicationStatus
+ handled in setImplicationStatus.
----- Reporting redundant constraints
@@ -1569,7 +1580,7 @@ We generate constraint, for (x::T alpha) and (y :: beta):
If we float the equality (beta ~ Int) outside of the first implication and
the equality (beta ~ Bool) out of the second we get an insoluble constraint.
-But if we just leave them inside the implications we unify alpha := beta and
+But if we just leave them inside the implications, we unify alpha := beta and
solve everything.
Principle:
@@ -1644,7 +1655,7 @@ Which of the simple 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
+The second constraint doesn't mention 'a'. But if we float it,
we'll promote gamma[2] 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
@@ -1669,7 +1680,7 @@ happen. In particular:
Float out equalities of form (alpaha ~ ty) or (ty ~ alpha), where
- * alpha is a meta-tyvar
+ * alpha is a meta-tyvar.
* And the equality is kind-compatible
@@ -1850,5 +1861,5 @@ Here, we get a complaint when checking the type signature for g,
that g isn't polymorphic enough; but then we get another one when
dealing with the (Num a) context arising from f's definition;
we try to unify a with Int (to default it), but find that it's
-already been unified with the rigid variable from g's type sig
+already been unified with the rigid variable from g's type sig.
-}
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 1486dfa1cb..1dbe7a84c9 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -773,7 +773,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 = packageKeyString (modulePackageKey m)
+ , TH.loc_package = unitIdString (moduleUnitId m)
, TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
, TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
@@ -1514,7 +1514,7 @@ reifyName thing
where
name = getName thing
mod = ASSERT( isExternalName name ) nameModule name
- pkg_str = packageKeyString (modulePackageKey mod)
+ pkg_str = unitIdString (moduleUnitId mod)
mod_str = moduleNameString (moduleName mod)
occ_str = occNameString occ
occ = nameOccName name
@@ -1545,7 +1545,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 (stringToPackageKey $ TH.pkgString pn) (mkModuleName $ TH.modString mn)
+ mkModule (stringToUnitId $ TH.pkgString pn) (mkModuleName $ TH.modString mn)
reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a]
reifyAnnotations th_name
@@ -1559,13 +1559,13 @@ reifyAnnotations th_name
------------------------------
modToTHMod :: Module -> TH.Module
-modToTHMod m = TH.Module (TH.PkgName $ packageKeyString $ modulePackageKey m)
+modToTHMod m = TH.Module (TH.PkgName $ unitIdString $ moduleUnitId 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 (stringToPackageKey pkgString) (mkModuleName mString)
+ let reifMod = mkModule (stringToUnitId pkgString) (mkModuleName mString)
if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod
where
reifyThisModule = do
@@ -1575,10 +1575,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 (modulePackageKey reifMod) usage] ]
+ Just m <- [usageToModule (moduleUnitId reifMod) usage] ]
return $ TH.ModuleInfo usages
- usageToModule :: PackageKey -> Usage -> Maybe Module
+ usageToModule :: UnitId -> 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/TcType.hs b/compiler/typecheck/TcType.hs
index ffaef16cac..bb937c687b 100644
--- a/compiler/typecheck/TcType.hs
+++ b/compiler/typecheck/TcType.hs
@@ -65,7 +65,7 @@ module TcType (
eqType, eqTypes, eqPred, cmpType, cmpTypes, cmpPred, eqTypeX,
tcEqType, tcEqKind,
isSigmaTy, isRhoTy, isOverloadedTy,
- isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
+ isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
isIntegerTy, isBoolTy, isUnitTy, isCharTy,
isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
isPredTy, isTyVarClassPred, isTyVarExposed, isTyVarUnderDatatype,
@@ -433,6 +433,7 @@ data UserTypeCtxt
newtype TcLevel = TcLevel Int deriving( Eq, Ord )
-- See Note [TcLevel and untouchable type variables] for what this Int is
+ -- See also Note [TcLevel assignment]
{-
Note [TcLevel and untouchable type variables]
@@ -458,7 +459,6 @@ Note [TcLevel and untouchable type variables]
implication are all untouchable; ie their level
numbers are LESS THAN the ic_tclvl of the implication
-
Note [Skolem escape prevention]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We only unify touchable unification variables. Because of
@@ -491,15 +491,35 @@ emerges. If we (wrongly) spontaneously solved it to get uf := beta,
the whole implication disappears but when we pop out again we are left with
(F Int ~ uf) which will be unified by our final zonking stage and
uf will get unified *once more* to (F Int).
+
+Note [TcLevel assignment]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+We arrange the TcLevels like this
+
+ 1 Top level
+ 2 Flatten-meta-vars of level 3
+ 3 First-level implication constraints
+ 4 Flatten-meta-vars of level 5
+ 5 Second-level implication constraints
+ ...etc...
+
+The even-numbered levels are for the flatten-meta-variables assigned
+at the next level in. Eg for a second-level implication conststraint
+(level 5), the flatten meta-vars are level 4, which makes them untouchable.
+The flatten meta-vars could equally well all have level 0, or just NotALevel
+since they do not live across implications.
-}
fmvTcLevel :: TcLevel -> TcLevel
+-- See Note [TcLevel assignment]
fmvTcLevel (TcLevel n) = TcLevel (n-1)
topTcLevel :: TcLevel
+-- See Note [TcLevel assignment]
topTcLevel = TcLevel 1 -- 1 = outermost level
pushTcLevel :: TcLevel -> TcLevel
+-- See Note [TcLevel assignment]
pushTcLevel (TcLevel us) = TcLevel (us + 2)
strictlyDeeperThan :: TcLevel -> TcLevel -> Bool
@@ -1439,6 +1459,11 @@ isUnitTy = is_tc unitTyConKey
isCharTy = is_tc charTyConKey
isAnyTy = is_tc anyTyConKey
+-- | Does a type represent a floating-point number?
+isFloatingTy :: Type -> Bool
+isFloatingTy ty = isFloatTy ty || isDoubleTy ty
+
+-- | Is a type 'String'?
isStringTy :: Type -> Bool
isStringTy ty
= case tcSplitTyConApp_maybe ty of
diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs
index 2e3834e3cb..8042cc58c3 100644
--- a/compiler/typecheck/TcUnify.hs
+++ b/compiler/typecheck/TcUnify.hs
@@ -850,7 +850,7 @@ We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically,
and yet its consistency is undetermined. Previously, there was no way to still
make it consistent. So a mismatch error was issued.
-Now these unfications are deferred until constraint simplification, where type
+Now these unifications are deferred until constraint simplification, where type
family instances and given equations may (or may not) establish the consistency.
Deferred unifications are of the form
F ... ~ ...
@@ -860,7 +860,7 @@ E.g.
id :: x ~ y => x -> y
id e = e
-involves the unfication x = y. It is deferred until we bring into account the
+involves the unification x = y. It is deferred until we bring into account the
context x ~ y to establish that it holds.
If available, we defer original types (rather than those where closed type
diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs
index b8a3e6aa3f..56df3a52ba 100644
--- a/compiler/types/InstEnv.hs
+++ b/compiler/types/InstEnv.hs
@@ -203,7 +203,9 @@ instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec))
mkLocalInstance :: DFunId -> OverlapFlag
-> [TyVar] -> Class -> [Type]
-> ClsInst
--- Used for local instances, where we can safely pull on the DFunId
+-- Used for local instances, where we can safely pull on the DFunId.
+-- Consider using newClsInst instead; this will also warn if
+-- the instance is an orphan.
mkLocalInstance dfun oflag tvs cls tys
= ClsInst { is_flag = oflag, is_dfun = dfun
, is_tvs = tvs
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index a730cdfdcf..23fa37d77a 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -82,7 +82,7 @@ import {-# SOURCE #-} DynFlags( DynFlags,
targetPlatform, pprUserLength, pprCols,
useUnicode, useUnicodeSyntax,
unsafeGlobalDynFlags )
-import {-# SOURCE #-} Module( PackageKey, Module, ModuleName, moduleName )
+import {-# SOURCE #-} Module( UnitId, Module, ModuleName, moduleName )
import {-# SOURCE #-} OccName( OccName )
import {-# SOURCE #-} StaticFlags( opt_PprStyle_Debug, opt_NoDebugOutput )
@@ -169,8 +169,8 @@ type QueryQualifyName = Module -> OccName -> QualifyName
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
+-- the unit id to disambiguate it.
+type QueryQualifyPackage = UnitId -> Bool
-- See Note [Printing original names] in HscTypes
data QualifyName -- Given P:M.T
diff --git a/compiler/utils/Panic.hs b/compiler/utils/Panic.hs
index e1c848d540..782333633a 100644
--- a/compiler/utils/Panic.hs
+++ b/compiler/utils/Panic.hs
@@ -36,7 +36,6 @@ import Control.Concurrent
import Data.Dynamic
import Debug.Trace ( trace )
import System.IO.Unsafe
-import System.Exit
import System.Environment
#ifndef mingw32_HOST_OS
@@ -63,11 +62,8 @@ import System.Mem.Weak ( Weak, deRefWeak )
-- assumed to contain a location already, so we don't print one).
data GhcException
- = PhaseFailed String -- name of phase
- ExitCode -- an external phase (eg. cpp) failed
-
-- | Some other fatal signal (SIGHUP,SIGTERM)
- | Signal Int
+ = Signal Int
-- | Prints the short usage msg after the error
| UsageError String
@@ -135,11 +131,6 @@ showGhcException exception
UsageError str
-> showString str . showChar '\n' . showString short_usage
- PhaseFailed phase code
- -> showString "phase `" . showString phase .
- showString "' failed (exitcode = " . shows (int_code code) .
- showString ")"
-
CmdLineError str -> showString str
PprProgramError str _ ->
showGhcException (ProgramError (str ++ "\n<<details unavailable>>"))
@@ -164,11 +155,6 @@ showGhcException exception
++ " (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
++ s ++ "\n"
- where int_code code =
- case code of
- ExitSuccess -> (0::Int)
- ExitFailure x -> x
-
throwGhcException :: GhcException -> a
throwGhcException = Exception.throw