diff options
Diffstat (limited to 'compiler')
174 files changed, 6780 insertions, 4946 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 9a92b003bc..2f86db7796 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -41,7 +41,8 @@ module BasicTypes( TopLevelFlag(..), isTopLevel, isNotTopLevel, - OverlapFlag(..), + OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, + hasOverlappingFlag, hasOverlappableFlag, Boxity(..), isBoxed, @@ -447,39 +448,92 @@ instance Outputable Origin where -- | The semantics allowed for overlapping instances for a particular -- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.lhs`) for a -- explanation of the `isSafeOverlap` field. -data OverlapFlag - -- | This instance must not overlap another - = NoOverlap { isSafeOverlap :: Bool } - - -- | Silently ignore this instance if you find a - -- more specific one that matches the constraint - -- you are trying to resolve - -- - -- Example: constraint (Foo [Int]) - -- instances (Foo [Int]) - -- (Foo [a]) OverlapOk - -- Since the second instance has the OverlapOk flag, - -- the first instance will be chosen (otherwise - -- its ambiguous which to choose) - | OverlapOk { isSafeOverlap :: Bool } - - -- | Silently ignore this instance if you find any other that matches the - -- constraing you are trying to resolve, including when checking if there are - -- instances that do not match, but unify. - -- - -- Example: constraint (Foo [b]) - -- instances (Foo [Int]) Incoherent - -- (Foo [a]) - -- Without the Incoherent flag, we'd complain that - -- instantiating 'b' would change which instance - -- was chosen. See also note [Incoherent instances] - | Incoherent { isSafeOverlap :: Bool } +data OverlapFlag = OverlapFlag + { overlapMode :: OverlapMode + , isSafeOverlap :: Bool + } deriving (Eq, Data, Typeable) + +setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag +setOverlapModeMaybe f Nothing = f +setOverlapModeMaybe f (Just m) = f { overlapMode = m } + +hasOverlappableFlag :: OverlapMode -> Bool +hasOverlappableFlag mode = + case mode of + Overlappable -> True + Overlaps -> True + Incoherent -> True + _ -> False + +hasOverlappingFlag :: OverlapMode -> Bool +hasOverlappingFlag mode = + case mode of + Overlapping -> True + Overlaps -> True + Incoherent -> True + _ -> False + +data OverlapMode -- See Note [Rules for instance lookup] in InstEnv + = NoOverlap + -- ^ This instance must not overlap another `NoOverlap` instance. + -- However, it may be overlapped by `Overlapping` instances, + -- and it may overlap `Overlappable` instances. + + + | Overlappable + -- ^ Silently ignore this instance if you find a + -- more specific one that matches the constraint + -- you are trying to resolve + -- + -- Example: constraint (Foo [Int]) + -- instance Foo [Int] + -- instance {-# OVERLAPPABLE #-} Foo [a] + -- + -- Since the second instance has the Overlappable flag, + -- the first instance will be chosen (otherwise + -- its ambiguous which to choose) + + + | Overlapping + -- ^ Silently ignore any more general instances that may be + -- used to solve the constraint. + -- + -- Example: constraint (Foo [Int]) + -- instance {-# OVERLAPPING #-} Foo [Int] + -- instance Foo [a] + -- + -- Since the first instance has the Overlapping flag, + -- the second---more general---instance will be ignored (otherwise + -- it is ambiguous which to choose) + + + | Overlaps + -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. + + | Incoherent + -- ^ Behave like Overlappable and Overlapping, and in addition pick + -- an an arbitrary one if there are multiple matching candidates, and + -- don't worry about later instantiation + -- + -- Example: constraint (Foo [b]) + -- instance {-# INCOHERENT -} Foo [Int] + -- instance Foo [a] + -- Without the Incoherent flag, we'd complain that + -- instantiating 'b' would change which instance + -- was chosen. See also note [Incoherent instances] in InstEnv + deriving (Eq, Data, Typeable) + instance Outputable OverlapFlag where - ppr (NoOverlap b) = empty <+> pprSafeOverlap b - ppr (OverlapOk b) = ptext (sLit "[overlap ok]") <+> pprSafeOverlap b - ppr (Incoherent b) = ptext (sLit "[incoherent]") <+> pprSafeOverlap b + ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) + +instance Outputable OverlapMode where + ppr NoOverlap = empty + ppr Overlappable = ptext (sLit "[overlappable]") + ppr Overlapping = ptext (sLit "[overlapping]") + ppr Overlaps = ptext (sLit "[overlap ok]") + ppr Incoherent = ptext (sLit "[incoherent]") pprSafeOverlap :: Bool -> SDoc pprSafeOverlap True = ptext $ sLit "[safe]" @@ -761,7 +815,7 @@ data InlinePragma -- Note [InlinePragma] , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? } deriving( Eq, Data, Typeable ) -data InlineSpec -- What the user's INLINE pragama looked like +data InlineSpec -- What the user's INLINE pragma looked like = Inline | Inlinable | NoInline diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 0dcf98f6c5..771aa303a1 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -942,7 +942,7 @@ dataConRepArgTys (MkData { dcRep = rep -- to its info table and used by the GHCi debugger and the heap profiler dataConIdentity :: DataCon -> [Word8] -- We want this string to be UTF-8, so we get the bytes directly from the FastStrings. -dataConIdentity dc = bytesFS (packageIdFS (modulePackageId mod)) ++ +dataConIdentity dc = bytesFS (packageKeyFS (modulePackageKey mod)) ++ fromIntegral (ord ':') : bytesFS (moduleNameFS (moduleName mod)) ++ fromIntegral (ord '.') : bytesFS (occNameFS (nameOccName name)) where name = dataConName dc diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index f3615bca64..ed055b5808 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -66,7 +66,7 @@ import BasicTypes import Binary import Maybes ( orElse ) -import Type ( Type ) +import Type ( Type, isUnLiftedType ) import TyCon ( isNewTyCon, isClassTyCon ) import DataCon ( splitDataProductType_maybe ) import FastString @@ -1201,13 +1201,18 @@ type DeferAndUse -- Describes how to degrade a result type type DeferAndUseM = Maybe DeferAndUse -- Nothing <=> absent-ify the result type; it will never be used -toCleanDmd :: Demand -> (CleanDemand, DeferAndUseM) --- See Note [Analyzing with lazy demand and lambdas] -toCleanDmd (JD { strd = s, absd = u }) +toCleanDmd :: Demand -> Type -> (CleanDemand, DeferAndUseM) +toCleanDmd (JD { strd = s, absd = u }) expr_ty = case (s,u) of - (Str s', Use c u') -> (CD { sd = s', ud = u' }, Just (False, c)) - (Lazy, Use c u') -> (CD { sd = HeadStr, ud = u' }, Just (True, c)) - (_, Abs) -> (CD { sd = HeadStr, ud = Used }, Nothing) + (Str s', Use c u') -> -- The normal case + (CD { sd = s', ud = u' }, Just (False, c)) + + (Lazy, Use c u') -> -- See Note [Analyzing with lazy demand and lambdas] + (CD { sd = HeadStr, ud = u' }, Just (True, c)) + + (_, Abs) -- See Note [Analysing with absent demand] + | isUnLiftedType expr_ty -> (CD { sd = HeadStr, ud = Used }, Just (False, One)) + | otherwise -> (CD { sd = HeadStr, ud = Used }, Nothing) -- This is used in dmdAnalStar when post-processing -- a function's argument demand. So we only care about what @@ -1382,13 +1387,13 @@ cardinality analysis of the following example: {-# NOINLINE build #-} build g = (g (:) [], g (:) []) -h c z = build (\x -> - let z1 = z ++ z +h c z = build (\x -> + let z1 = z ++ z in if c then \y -> x (y ++ z1) else \y -> x (z1 ++ y)) -One can see that `build` assigns to `g` demand <L,C(C1(U))>. +One can see that `build` assigns to `g` demand <L,C(C1(U))>. Therefore, when analyzing the lambda `(\x -> ...)`, we expect each lambda \y -> ... to be annotated as "one-shot" one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a @@ -1397,6 +1402,46 @@ demand <C(C(..), C(C1(U))>. This is achieved by, first, converting the lazy demand L into the strict S by the second clause of the analysis. +Note [Analysing with absent demand] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we analyse an expression with demand <L,A>. The "A" means +"absent", so this expression will never be needed. What should happen? +There are several wrinkles: + +* We *do* want to analyse the expression regardless. + Reason: Note [Always analyse in virgin pass] + + But we can post-process the results to ignore all the usage + demands coming back. This is done by postProcessDmdTypeM. + +* But in the case of an *unlifted type* we must be extra careful, + because unlifted values are evaluated even if they are not used. + Example (see Trac #9254): + f :: (() -> (# Int#, () #)) -> () + -- Strictness signature is + -- <C(S(LS)), 1*C1(U(A,1*U()))> + -- I.e. calls k, but discards first component of result + f k = case k () of (# _, r #) -> r + + g :: Int -> () + g y = f (\n -> (# case y of I# y2 -> y2, n #)) + + Here f's strictness signature says (correctly) that it calls its + argument function and ignores the first component of its result. + This is correct in the sense that it'd be fine to (say) modify the + function so that always returned 0# in the first component. + + But in function g, we *will* evaluate the 'case y of ...', because + it has type Int#. So 'y' will be evaluated. So we must record this + usage of 'y', else 'g' will say 'y' is absent, and will w/w so that + 'y' is bound to an aBSENT_ERROR thunk. + + An alternative would be to replace the 'case y of ...' with (say) 0#, + but I have not tried that. It's not a common situation, but it is + not theoretical: unsafePerformIO's implementation is very very like + 'f' above. + + %************************************************************************ %* * Demand signatures diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index 080ae47ac9..8f21d66bc1 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -23,30 +23,31 @@ module Module mkModuleNameFS, stableModuleNameCmp, - -- * The PackageId type - PackageId, - fsToPackageId, - packageIdFS, - stringToPackageId, - packageIdString, - stablePackageIdCmp, - - -- * Wired-in PackageIds + -- * The PackageKey type + PackageKey, + fsToPackageKey, + packageKeyFS, + stringToPackageKey, + packageKeyString, + stablePackageKeyCmp, + + -- * Wired-in PackageKeys -- $wired_in_packages - primPackageId, - integerPackageId, - basePackageId, - rtsPackageId, - thPackageId, - dphSeqPackageId, - dphParPackageId, - mainPackageId, - thisGhcPackageId, - interactivePackageId, isInteractiveModule, + primPackageKey, + integerPackageKey, + basePackageKey, + rtsPackageKey, + thPackageKey, + dphSeqPackageKey, + dphParPackageKey, + mainPackageKey, + thisGhcPackageKey, + interactivePackageKey, isInteractiveModule, + wiredInPackageKeys, -- * The Module type Module, - modulePackageId, moduleName, + modulePackageKey, moduleName, pprModule, mkModule, stableModuleCmp, @@ -82,6 +83,7 @@ import UniqFM import FastString import Binary import Util +import {-# SOURCE #-} Packages import Data.Data import Data.Map (Map) @@ -228,15 +230,15 @@ moduleNameColons = dots_to_colons . moduleNameString %************************************************************************ \begin{code} --- | A Module is a pair of a 'PackageId' and a 'ModuleName'. +-- | A Module is a pair of a 'PackageKey' and a 'ModuleName'. data Module = Module { - modulePackageId :: !PackageId, -- pkg-1.0 + modulePackageKey :: !PackageKey, -- pkg-1.0 moduleName :: !ModuleName -- A.B.C } deriving (Eq, Ord, Typeable) instance Uniquable Module where - getUnique (Module p n) = getUnique (packageIdFS p `appendFS` moduleNameFS n) + getUnique (Module p n) = getUnique (packageKeyFS p `appendFS` moduleNameFS n) instance Outputable Module where ppr = pprModule @@ -256,25 +258,25 @@ instance Data Module where -- not be stable from run to run of the compiler. stableModuleCmp :: Module -> Module -> Ordering stableModuleCmp (Module p1 n1) (Module p2 n2) - = (p1 `stablePackageIdCmp` p2) `thenCmp` + = (p1 `stablePackageKeyCmp` p2) `thenCmp` (n1 `stableModuleNameCmp` n2) -mkModule :: PackageId -> ModuleName -> Module +mkModule :: PackageKey -> ModuleName -> Module mkModule = Module pprModule :: Module -> SDoc pprModule mod@(Module p n) = pprPackagePrefix p mod <> pprModuleName n -pprPackagePrefix :: PackageId -> Module -> SDoc +pprPackagePrefix :: PackageKey -> Module -> SDoc pprPackagePrefix p mod = getPprStyle doc where doc sty | codeStyle sty = - if p == mainPackageId + if p == mainPackageKey then empty -- never qualify the main package in code - else ztext (zEncodeFS (packageIdFS p)) <> char '_' - | qualModule sty mod = ftext (packageIdFS (modulePackageId mod)) <> char ':' + else ztext (zEncodeFS (packageKeyFS p)) <> char '_' + | qualModule sty mod = ppr (modulePackageKey mod) <> char ':' -- the PrintUnqualified tells us which modules have to -- be qualified with package names | otherwise = empty @@ -288,51 +290,59 @@ class HasModule m where %************************************************************************ %* * -\subsection{PackageId} +\subsection{PackageKey} %* * %************************************************************************ \begin{code} --- | Essentially just a string identifying a package, including the version: e.g. parsec-1.0 -newtype PackageId = PId FastString deriving( Eq, Typeable ) +-- | A string which uniquely identifies a package. For wired-in packages, +-- it is just the package name, but for user compiled packages, it is a hash. +-- ToDo: when the key is a hash, we can do more clever things than store +-- the hex representation and hash-cons those strings. +newtype PackageKey = PId FastString deriving( Eq, Typeable ) -- here to avoid module loops with PackageConfig -instance Uniquable PackageId where - getUnique pid = getUnique (packageIdFS pid) +instance Uniquable PackageKey where + getUnique pid = getUnique (packageKeyFS pid) -- Note: *not* a stable lexicographic ordering, a faster unique-based -- ordering. -instance Ord PackageId where +instance Ord PackageKey where nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2 -instance Data PackageId where +instance Data PackageKey where -- don't traverse? - toConstr _ = abstractConstr "PackageId" + toConstr _ = abstractConstr "PackageKey" gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "PackageId" + dataTypeOf _ = mkNoRepType "PackageKey" -stablePackageIdCmp :: PackageId -> PackageId -> Ordering +stablePackageKeyCmp :: PackageKey -> PackageKey -> Ordering -- ^ Compares package ids lexically, rather than by their 'Unique's -stablePackageIdCmp p1 p2 = packageIdFS p1 `compare` packageIdFS p2 +stablePackageKeyCmp p1 p2 = packageKeyFS p1 `compare` packageKeyFS p2 -instance Outputable PackageId where - ppr pid = text (packageIdString pid) +instance Outputable PackageKey where + ppr pk = getPprStyle $ \sty -> sdocWithDynFlags $ \dflags -> + text (packageKeyPackageIdString dflags pk) + -- Don't bother qualifying if it's wired in! + <> (if qualPackage sty pk && not (pk `elem` wiredInPackageKeys) + then char '@' <> ftext (packageKeyFS pk) + else empty) -instance Binary PackageId where - put_ bh pid = put_ bh (packageIdFS pid) - get bh = do { fs <- get bh; return (fsToPackageId fs) } +instance Binary PackageKey where + put_ bh pid = put_ bh (packageKeyFS pid) + get bh = do { fs <- get bh; return (fsToPackageKey fs) } -fsToPackageId :: FastString -> PackageId -fsToPackageId = PId +fsToPackageKey :: FastString -> PackageKey +fsToPackageKey = PId -packageIdFS :: PackageId -> FastString -packageIdFS (PId fs) = fs +packageKeyFS :: PackageKey -> FastString +packageKeyFS (PId fs) = fs -stringToPackageId :: String -> PackageId -stringToPackageId = fsToPackageId . mkFastString +stringToPackageKey :: String -> PackageKey +stringToPackageKey = fsToPackageKey . mkFastString -packageIdString :: PackageId -> String -packageIdString = unpackFS . packageIdFS +packageKeyString :: PackageKey -> String +packageKeyString = unpackFS . packageKeyFS -- ----------------------------------------------------------------------------- @@ -348,7 +358,7 @@ packageIdString = unpackFS . packageIdFS -- versions of them installed. However, for each invocation of GHC, -- only a single instance of each wired-in package will be recognised -- (the desired one is selected via @-package@\/@-hide-package@), and GHC --- will use the unversioned 'PackageId' below when referring to it, +-- will use the unversioned 'PackageKey' below when referring to it, -- including in .hi files and object file symbols. Unselected -- versions of wired-in packages will be ignored, as will any other -- package that depends directly or indirectly on it (much as if you @@ -356,27 +366,37 @@ packageIdString = unpackFS . packageIdFS -- Make sure you change 'Packages.findWiredInPackages' if you add an entry here -integerPackageId, primPackageId, - basePackageId, rtsPackageId, - thPackageId, dphSeqPackageId, dphParPackageId, - mainPackageId, thisGhcPackageId, interactivePackageId :: PackageId -primPackageId = fsToPackageId (fsLit "ghc-prim") -integerPackageId = fsToPackageId (fsLit cIntegerLibrary) -basePackageId = fsToPackageId (fsLit "base") -rtsPackageId = fsToPackageId (fsLit "rts") -thPackageId = fsToPackageId (fsLit "template-haskell") -dphSeqPackageId = fsToPackageId (fsLit "dph-seq") -dphParPackageId = fsToPackageId (fsLit "dph-par") -thisGhcPackageId = fsToPackageId (fsLit ("ghc-" ++ cProjectVersion)) -interactivePackageId = fsToPackageId (fsLit "interactive") +integerPackageKey, primPackageKey, + basePackageKey, rtsPackageKey, + thPackageKey, dphSeqPackageKey, dphParPackageKey, + mainPackageKey, thisGhcPackageKey, interactivePackageKey :: PackageKey +primPackageKey = fsToPackageKey (fsLit "ghc-prim") +integerPackageKey = fsToPackageKey (fsLit cIntegerLibrary) +basePackageKey = fsToPackageKey (fsLit "base") +rtsPackageKey = fsToPackageKey (fsLit "rts") +thPackageKey = fsToPackageKey (fsLit "template-haskell") +dphSeqPackageKey = fsToPackageKey (fsLit "dph-seq") +dphParPackageKey = fsToPackageKey (fsLit "dph-par") +thisGhcPackageKey = fsToPackageKey (fsLit "ghc") +interactivePackageKey = fsToPackageKey (fsLit "interactive") -- | This is the package Id for the current program. It is the default -- package Id if you don't specify a package name. We don't add this prefix -- to symbol names, since there can be only one main package per program. -mainPackageId = fsToPackageId (fsLit "main") +mainPackageKey = fsToPackageKey (fsLit "main") isInteractiveModule :: Module -> Bool -isInteractiveModule mod = modulePackageId mod == interactivePackageId +isInteractiveModule mod = modulePackageKey mod == interactivePackageKey + +wiredInPackageKeys :: [PackageKey] +wiredInPackageKeys = [ primPackageKey, + integerPackageKey, + basePackageKey, + rtsPackageKey, + thPackageKey, + thisGhcPackageKey, + dphSeqPackageKey, + dphParPackageKey ] \end{code} %************************************************************************ diff --git a/compiler/basicTypes/Module.lhs-boot b/compiler/basicTypes/Module.lhs-boot index 63839b55bc..6d194d6a2a 100644 --- a/compiler/basicTypes/Module.lhs-boot +++ b/compiler/basicTypes/Module.lhs-boot @@ -3,8 +3,8 @@ module Module where data Module data ModuleName -data PackageId +data PackageKey moduleName :: Module -> ModuleName -modulePackageId :: Module -> PackageId -packageIdString :: PackageId -> String +modulePackageKey :: Module -> PackageKey +packageKeyString :: PackageKey -> String \end{code} diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index c2e7aeabdc..7651c7c749 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -503,7 +503,7 @@ pprModulePrefix sty mod occ = sdocWithDynFlags $ \dflags -> case qualName sty mod occ of -- See Outputable.QualifyName: NameQual modname -> ppr modname <> dot -- Name is in scope NameNotInScope1 -> ppr mod <> dot -- Not in scope - NameNotInScope2 -> ppr (modulePackageId mod) <> colon -- Module not in + NameNotInScope2 -> ppr (modulePackageKey mod) <> colon -- Module not in <> ppr (moduleName mod) <> dot -- scope either _otherwise -> empty diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index ebfb71aa65..d4afaf10fc 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -817,7 +817,7 @@ data ImpDeclSpec -- the defining module for this thing! -- TODO: either should be Module, or there - -- should be a Maybe PackageId here too. + -- should be a Maybe PackageKey here too. is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) is_qual :: Bool, -- ^ Was this import qualified? is_dloc :: SrcSpan -- ^ The location of the entire import declaration diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 407002f1c7..02ad026249 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -158,14 +158,14 @@ data CLabel -- | A label from a .cmm file that is not associated with a .hs level Id. | CmmLabel - PackageId -- what package the label belongs to. + PackageKey -- what package the label belongs to. FastString -- identifier giving the prefix of the label CmmLabelInfo -- encodes the suffix of the label -- | A label with a baked-in \/ algorithmically generated name that definitely -- comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so -- If it doesn't have an algorithmically generated name then use a CmmLabel - -- instead and give it an appropriate PackageId argument. + -- instead and give it an appropriate PackageKey argument. | RtsLabel RtsLabelInfo @@ -237,7 +237,7 @@ data CLabel data ForeignLabelSource -- | Label is in a named package - = ForeignLabelInPackage PackageId + = ForeignLabelInPackage PackageKey -- | Label is in some external, system package that doesn't also -- contain compiled Haskell code, and is not associated with any .hi files. @@ -411,27 +411,27 @@ mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel, mkArrWords_infoLabel, mkSMAP_FROZEN_infoLabel, mkSMAP_FROZEN0_infoLabel, mkSMAP_DIRTY_infoLabel :: CLabel mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction -mkSplitMarkerLabel = CmmLabel rtsPackageId (fsLit "__stg_split_marker") CmmCode -mkUpdInfoLabel = CmmLabel rtsPackageId (fsLit "stg_upd_frame") CmmInfo -mkBHUpdInfoLabel = CmmLabel rtsPackageId (fsLit "stg_bh_upd_frame" ) CmmInfo -mkIndStaticInfoLabel = CmmLabel rtsPackageId (fsLit "stg_IND_STATIC") CmmInfo -mkMainCapabilityLabel = CmmLabel rtsPackageId (fsLit "MainCapability") CmmData -mkMAP_FROZEN_infoLabel = CmmLabel rtsPackageId (fsLit "stg_MUT_ARR_PTRS_FROZEN") CmmInfo -mkMAP_FROZEN0_infoLabel = CmmLabel rtsPackageId (fsLit "stg_MUT_ARR_PTRS_FROZEN0") CmmInfo -mkMAP_DIRTY_infoLabel = CmmLabel rtsPackageId (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo -mkEMPTY_MVAR_infoLabel = CmmLabel rtsPackageId (fsLit "stg_EMPTY_MVAR") CmmInfo -mkTopTickyCtrLabel = CmmLabel rtsPackageId (fsLit "top_ct") CmmData -mkCAFBlackHoleInfoTableLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmInfo -mkCAFBlackHoleEntryLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmEntry -mkArrWords_infoLabel = CmmLabel rtsPackageId (fsLit "stg_ARR_WORDS") CmmInfo -mkSMAP_FROZEN_infoLabel = CmmLabel rtsPackageId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN") CmmInfo -mkSMAP_FROZEN0_infoLabel = CmmLabel rtsPackageId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN0") CmmInfo -mkSMAP_DIRTY_infoLabel = CmmLabel rtsPackageId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo +mkSplitMarkerLabel = CmmLabel rtsPackageKey (fsLit "__stg_split_marker") CmmCode +mkUpdInfoLabel = CmmLabel rtsPackageKey (fsLit "stg_upd_frame") CmmInfo +mkBHUpdInfoLabel = CmmLabel rtsPackageKey (fsLit "stg_bh_upd_frame" ) CmmInfo +mkIndStaticInfoLabel = CmmLabel rtsPackageKey (fsLit "stg_IND_STATIC") CmmInfo +mkMainCapabilityLabel = CmmLabel rtsPackageKey (fsLit "MainCapability") CmmData +mkMAP_FROZEN_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_MUT_ARR_PTRS_FROZEN") CmmInfo +mkMAP_FROZEN0_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_MUT_ARR_PTRS_FROZEN0") CmmInfo +mkMAP_DIRTY_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo +mkEMPTY_MVAR_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_EMPTY_MVAR") CmmInfo +mkTopTickyCtrLabel = CmmLabel rtsPackageKey (fsLit "top_ct") CmmData +mkCAFBlackHoleInfoTableLabel = CmmLabel rtsPackageKey (fsLit "stg_CAF_BLACKHOLE") CmmInfo +mkCAFBlackHoleEntryLabel = CmmLabel rtsPackageKey (fsLit "stg_CAF_BLACKHOLE") CmmEntry +mkArrWords_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_ARR_WORDS") CmmInfo +mkSMAP_FROZEN_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN") CmmInfo +mkSMAP_FROZEN0_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN0") CmmInfo +mkSMAP_DIRTY_infoLabel = CmmLabel rtsPackageKey (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo ----- mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel, mkCmmCodeLabel, mkCmmDataLabel, mkCmmClosureLabel - :: PackageId -> FastString -> CLabel + :: PackageKey -> FastString -> CLabel mkCmmInfoLabel pkg str = CmmLabel pkg str CmmInfo mkCmmEntryLabel pkg str = CmmLabel pkg str CmmEntry @@ -639,7 +639,7 @@ needsCDecl (RtsLabel _) = False needsCDecl (CmmLabel pkgId _ _) -- Prototypes for labels defined in the runtime system are imported -- into HC files via includes/Stg.h. - | pkgId == rtsPackageId = False + | pkgId == rtsPackageKey = False -- For other labels we inline one into the HC file directly. | otherwise = True @@ -849,11 +849,11 @@ idInfoLabelType info = -- @labelDynamic@ returns @True@ if the label is located -- in a DLL, be it a data reference or not. -labelDynamic :: DynFlags -> PackageId -> Module -> CLabel -> Bool +labelDynamic :: DynFlags -> PackageKey -> Module -> CLabel -> Bool labelDynamic dflags this_pkg this_mod lbl = case lbl of -- is the RTS in a DLL or not? - RtsLabel _ -> not (gopt Opt_Static dflags) && (this_pkg /= rtsPackageId) + RtsLabel _ -> not (gopt Opt_Static dflags) && (this_pkg /= rtsPackageKey) IdLabel n _ _ -> isDllName dflags this_pkg this_mod n @@ -886,7 +886,9 @@ labelDynamic dflags this_pkg this_mod lbl = -- libraries True - PlainModuleInitLabel m -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageId m) + PlainModuleInitLabel m -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageKey m) + + HpcTicksLabel m -> not (gopt Opt_Static dflags) && this_pkg /= (modulePackageKey m) -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves. _ -> False diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index e21efc13af..9e9bae93c6 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -80,10 +80,7 @@ data GenCmmDecl d h g -- registers will be correct in generated C-- code, but -- not in hand-written C-- code. However, -- splitAtProcPoints calculates correct liveness - -- information for CmmProc's. Right now only the LLVM - -- back-end relies on correct liveness information and - -- for that back-end we always call splitAtProcPoints, so - -- all is good. + -- information for CmmProcs. g -- Control-flow graph for the procedure's code | CmmData -- Static data diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index e10716a2ac..6521a84006 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -286,7 +286,7 @@ bundle :: Map CLabel CAFSet -> (CAFEnv, CmmDecl) -> (CAFSet, Maybe CLabel) -> (BlockEnv CAFSet, CmmDecl) -bundle flatmap (env, decl@(CmmProc infos lbl _ g)) (closure_cafs, mb_lbl) +bundle flatmap (env, decl@(CmmProc infos _lbl _ g)) (closure_cafs, mb_lbl) = ( mapMapWithKey get_cafs (info_tbls infos), decl ) where entry = g_entry g @@ -297,9 +297,13 @@ bundle flatmap (env, decl@(CmmProc infos lbl _ g)) (closure_cafs, mb_lbl) get_cafs l _ | l == entry = entry_cafs - | otherwise = if not (mapMember l env) - then pprPanic "bundle" (ppr l <+> ppr lbl <+> ppr (info_tbls infos) $$ ppr env $$ ppr decl) - else flatten flatmap $ expectJust "bundle" $ mapLookup l env + | Just info <- mapLookup l env = flatten flatmap info + | otherwise = Set.empty + -- the label might not be in the env if the code corresponding to + -- this info table was optimised away (perhaps because it was + -- unreachable). In this case it doesn't matter what SRT we + -- infer, since the info table will not appear in the generated + -- code. See #9329. bundle _flatmap (_, decl) _ = ( mapEmpty, decl ) diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index aae3ea1c71..3bfc728ac0 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -1,11 +1,4 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module CmmInfo ( mkEmptyContInfoTable, cmmToRawCmm, @@ -62,7 +55,7 @@ import Data.Word -- When we split at proc points, we need an empty info table. mkEmptyContInfoTable :: CLabel -> CmmInfoTable -mkEmptyContInfoTable info_lbl +mkEmptyContInfoTable info_lbl = CmmInfoTable { cit_lbl = info_lbl , cit_rep = mkStackRep [] , cit_prof = NoProfilingInfo @@ -84,31 +77,31 @@ cmmToRawCmm dflags cmms -- represented by a label+offset expression). -- -- With tablesNextToCode, the layout is --- <reversed variable part> --- <normal forward StgInfoTable, but without --- an entry point at the front> --- <code> +-- <reversed variable part> +-- <normal forward StgInfoTable, but without +-- an entry point at the front> +-- <code> -- -- Without tablesNextToCode, the layout of an info table is --- <entry label> --- <normal forward rest of StgInfoTable> --- <forward variable part> +-- <entry label> +-- <normal forward rest of StgInfoTable> +-- <forward variable part> -- --- See includes/rts/storage/InfoTables.h +-- See includes/rts/storage/InfoTables.h -- -- For return-points these are as follows -- -- Tables next to code: -- --- <srt slot> --- <standard info table> --- ret-addr --> <entry code (if any)> +-- <srt slot> +-- <standard info table> +-- ret-addr --> <entry code (if any)> -- -- Not tables-next-to-code: -- --- ret-addr --> <ptr to entry code> --- <standard info table> --- <srt slot> +-- ret-addr --> <ptr to entry code> +-- <standard info table> +-- <srt slot> -- -- * The SRT slot is only there if there is SRT info to record @@ -168,21 +161,21 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks) reverse rel_extra_bits ++ rel_std_info)) ----------------------------------------------------- -type InfoTableContents = ( [CmmLit] -- The standard part - , [CmmLit] ) -- The "extra bits" +type InfoTableContents = ( [CmmLit] -- The standard part + , [CmmLit] ) -- The "extra bits" -- These Lits have *not* had mkRelativeTo applied to them mkInfoTableContents :: DynFlags -> CmmInfoTable -> Maybe Int -- Override default RTS type tag? -> UniqSM ([RawCmmDecl], -- Auxiliary top decls - InfoTableContents) -- Info tbl + extra bits + InfoTableContents) -- Info tbl + extra bits mkInfoTableContents dflags info@(CmmInfoTable { cit_lbl = info_lbl , cit_rep = smrep , cit_prof = prof - , cit_srt = srt }) + , cit_srt = srt }) mb_rts_tag | RTSRep rts_tag rep <- smrep = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag) @@ -216,9 +209,9 @@ mkInfoTableContents dflags where mk_pieces :: ClosureTypeInfo -> [CmmLit] -> UniqSM ( Maybe StgHalfWord -- Override the SRT field with this - , Maybe CmmLit -- Override the layout field with this - , [CmmLit] -- "Extra bits" for info table - , [RawCmmDecl]) -- Auxiliary data decls + , Maybe CmmLit -- Override the layout field with this + , [CmmLit] -- "Extra bits" for info table + , [RawCmmDecl]) -- Auxiliary data decls mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor = do { (descr_lit, decl) <- newStringLit con_descr ; return ( Just (toStgHalfWord dflags (fromIntegral con_tag)) @@ -231,7 +224,7 @@ mkInfoTableContents dflags = return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags (fromIntegral offset)), [], []) -- Layout known (one free var); we use the layout field for offset - mk_pieces (Fun arity (ArgSpec fun_type)) srt_label + mk_pieces (Fun arity (ArgSpec fun_type)) srt_label = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label ; return (Nothing, Nothing, extra_bits, []) } @@ -281,7 +274,7 @@ mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap) ------------------------------------------------------------------------- -- --- Position independent code +-- Position independent code -- ------------------------------------------------------------------------- -- In order to support position independent code, we mustn't put absolute @@ -293,7 +286,7 @@ mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap) -- as we want to keep binary compatibility between PIC and non-PIC. makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit - + makeRelativeRefTo dflags info_lbl (CmmLabel lbl) | tablesNextToCode dflags = CmmLabelDiffOff lbl info_lbl 0 @@ -305,16 +298,16 @@ makeRelativeRefTo _ _ lit = lit ------------------------------------------------------------------------- -- --- Build a liveness mask for the stack layout +-- Build a liveness mask for the stack layout -- ------------------------------------------------------------------------- -- There are four kinds of things on the stack: -- --- - pointer variables (bound in the environment) --- - non-pointer variables (bound in the environment) --- - free slots (recorded in the stack free list) --- - non-pointer data slots (recorded in the stack free list) +-- - pointer variables (bound in the environment) +-- - non-pointer variables (bound in the environment) +-- - free slots (recorded in the stack free list) +-- - non-pointer data slots (recorded in the stack free list) -- -- The first two are represented with a 'Just' of a 'LocalReg'. -- The last two with one or more 'Nothing' constructors. @@ -332,7 +325,7 @@ mkLivenessBits dflags liveness | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word = do { uniq <- getUniqueUs ; let bitmap_lbl = mkBitmapLabel uniq - ; return (CmmLabel bitmap_lbl, + ; return (CmmLabel bitmap_lbl, [mkRODataLits bitmap_lbl lits]) } | otherwise -- Fits in one word @@ -343,10 +336,10 @@ mkLivenessBits dflags liveness bitmap :: Bitmap bitmap = mkBitmap dflags liveness - small_bitmap = case bitmap of + small_bitmap = case bitmap of [] -> toStgWord dflags 0 [b] -> b - _ -> panic "mkLiveness" + _ -> panic "mkLiveness" bitmap_word = toStgWord dflags (fromIntegral n_bits) .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags) @@ -357,7 +350,7 @@ mkLivenessBits dflags liveness ------------------------------------------------------------------------- -- --- Generating a standard info table +-- Generating a standard info table -- ------------------------------------------------------------------------- @@ -370,23 +363,23 @@ mkLivenessBits dflags liveness mkStdInfoTable :: DynFlags - -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling) + -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling) -> Int -- Closure RTS tag -> StgHalfWord -- SRT length - -> CmmLit -- layout field + -> CmmLit -- layout field -> [CmmLit] mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit - = -- Parallel revertible-black hole field + = -- Parallel revertible-black hole field prof_info - -- Ticky info (none at present) - -- Debug info (none at present) + -- Ticky info (none at present) + -- Debug info (none at present) ++ [layout_lit, type_lit] - where - prof_info - | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr] - | otherwise = [] + where + prof_info + | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr] + | otherwise = [] type_lit = packHalfWordsCLit dflags (toStgHalfWord dflags (fromIntegral cl_type)) srt_len @@ -417,7 +410,7 @@ srtEscape dflags = toStgHalfWord dflags (-1) ------------------------------------------------------------------------- -- --- Accessing fields of an info table +-- Accessing fields of an info table -- ------------------------------------------------------------------------- @@ -492,7 +485,7 @@ funInfoTable dflags info_ptr = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags) | otherwise = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags) - -- Past the entry code pointer + -- Past the entry code pointer -- Takes the info pointer of a function, returns the function's arity funInfoArity :: DynFlags -> CmmExpr -> CmmExpr @@ -515,7 +508,7 @@ funInfoArity dflags iptr -- Info table sizes & offsets -- ----------------------------------------------------------------------------- - + stdInfoTableSizeW :: DynFlags -> WordOff -- The size of a standard info table varies with profiling/ticky etc, -- so we can't get it from Constants @@ -547,15 +540,14 @@ stdInfoTableSizeB :: DynFlags -> ByteOff stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags stdSrtBitmapOffset :: DynFlags -> ByteOff --- Byte offset of the SRT bitmap half-word which is +-- Byte offset of the SRT bitmap half-word which is -- in the *higher-addressed* part of the type_lit stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags stdClosureTypeOffset :: DynFlags -> ByteOff --- Byte offset of the closure type half-word +-- Byte offset of the closure type half-word stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags - diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index db22deb639..c582b783f2 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -870,7 +870,7 @@ areaToSp _ _ _ _ other = other -- really the job of the stack layout algorithm, hence we do it now. optStackCheck :: CmmNode O C -> CmmNode O C -optStackCheck n = -- Note [null stack check] +optStackCheck n = -- Note [Always false stack check] case n of CmmCondBranch (CmmLit (CmmInt 0 _)) _true false -> CmmBranch false other -> other diff --git a/compiler/cmm/CmmLex.x b/compiler/cmm/CmmLex.x index bb5b4e3ae5..f56db7bd4c 100644 --- a/compiler/cmm/CmmLex.x +++ b/compiler/cmm/CmmLex.x @@ -44,7 +44,7 @@ $white_no_nl = $whitechar # \n $ascdigit = 0-9 $unidigit = \x01 -- Trick Alex into handling Unicode. See alexGetChar. $digit = [$ascdigit $unidigit] -$octit = 0-7 +$octit = 0-7 $hexit = [$digit A-F a-f] $unilarge = \x03 -- Trick Alex into handling Unicode. See alexGetChar. @@ -70,56 +70,56 @@ $namechar = [$namebegin $digit] cmm :- -$white_no_nl+ ; +$white_no_nl+ ; ^\# pragma .* \n ; -- Apple GCC 3.3 CPP generates pragmas in its output -^\# (line)? { begin line_prag } +^\# (line)? { begin line_prag } -- single-line line pragmas, of the form -- # <line> "<file>" <extra-stuff> \n -<line_prag> $digit+ { setLine line_prag1 } -<line_prag1> \" [^\"]* \" { setFile line_prag2 } -<line_prag2> .* { pop } +<line_prag> $digit+ { setLine line_prag1 } +<line_prag1> \" [^\"]* \" { setFile line_prag2 } +<line_prag2> .* { pop } <0> { - \n ; - - [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!] { special_char } - - ".." { kw CmmT_DotDot } - "::" { kw CmmT_DoubleColon } - ">>" { kw CmmT_Shr } - "<<" { kw CmmT_Shl } - ">=" { kw CmmT_Ge } - "<=" { kw CmmT_Le } - "==" { kw CmmT_Eq } - "!=" { kw CmmT_Ne } - "&&" { kw CmmT_BoolAnd } - "||" { kw CmmT_BoolOr } - - P@decimal { global_regN (\n -> VanillaReg n VGcPtr) } - R@decimal { global_regN (\n -> VanillaReg n VNonGcPtr) } - F@decimal { global_regN FloatReg } - D@decimal { global_regN DoubleReg } - L@decimal { global_regN LongReg } - Sp { global_reg Sp } - SpLim { global_reg SpLim } - Hp { global_reg Hp } - HpLim { global_reg HpLim } + \n ; + + [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!] { special_char } + + ".." { kw CmmT_DotDot } + "::" { kw CmmT_DoubleColon } + ">>" { kw CmmT_Shr } + "<<" { kw CmmT_Shl } + ">=" { kw CmmT_Ge } + "<=" { kw CmmT_Le } + "==" { kw CmmT_Eq } + "!=" { kw CmmT_Ne } + "&&" { kw CmmT_BoolAnd } + "||" { kw CmmT_BoolOr } + + P@decimal { global_regN (\n -> VanillaReg n VGcPtr) } + R@decimal { global_regN (\n -> VanillaReg n VNonGcPtr) } + F@decimal { global_regN FloatReg } + D@decimal { global_regN DoubleReg } + L@decimal { global_regN LongReg } + Sp { global_reg Sp } + SpLim { global_reg SpLim } + Hp { global_reg Hp } + HpLim { global_reg HpLim } CCCS { global_reg CCCS } CurrentTSO { global_reg CurrentTSO } CurrentNursery { global_reg CurrentNursery } - HpAlloc { global_reg HpAlloc } - BaseReg { global_reg BaseReg } - - $namebegin $namechar* { name } - - 0 @octal { tok_octal } - @decimal { tok_decimal } - 0[xX] @hexadecimal { tok_hexadecimal } - @floating_point { strtoken tok_float } - - \" @strchar* \" { strtoken tok_string } + HpAlloc { global_reg HpAlloc } + BaseReg { global_reg BaseReg } + + $namebegin $namechar* { name } + + 0 @octal { tok_octal } + @decimal { tok_decimal } + 0[xX] @hexadecimal { tok_hexadecimal } + @floating_point { strtoken tok_float } + + \" @strchar* \" { strtoken tok_string } } { @@ -171,9 +171,9 @@ data CmmToken | CmmT_float64 | CmmT_gcptr | CmmT_GlobalReg GlobalReg - | CmmT_Name FastString - | CmmT_String String - | CmmT_Int Integer + | CmmT_Name FastString + | CmmT_String String + | CmmT_Int Integer | CmmT_Float Rational | CmmT_EOF deriving (Show) @@ -196,88 +196,88 @@ kw :: CmmToken -> Action kw tok span buf len = return (L span tok) global_regN :: (Int -> GlobalReg) -> Action -global_regN con span buf len +global_regN con span buf len = return (L span (CmmT_GlobalReg (con (fromIntegral n)))) where buf' = stepOn buf - n = parseUnsignedInteger buf' (len-1) 10 octDecDigit + n = parseUnsignedInteger buf' (len-1) 10 octDecDigit global_reg :: GlobalReg -> Action global_reg r span buf len = return (L span (CmmT_GlobalReg r)) strtoken :: (String -> CmmToken) -> Action -strtoken f span buf len = +strtoken f span buf len = return (L span $! (f $! lexemeToString buf len)) name :: Action -name span buf len = +name span buf len = case lookupUFM reservedWordsFM fs of - Just tok -> return (L span tok) - Nothing -> return (L span (CmmT_Name fs)) + Just tok -> return (L span tok) + Nothing -> return (L span (CmmT_Name fs)) where - fs = lexemeToFastString buf len + fs = lexemeToFastString buf len reservedWordsFM = listToUFM $ - map (\(x, y) -> (mkFastString x, y)) [ - ( "CLOSURE", CmmT_CLOSURE ), - ( "INFO_TABLE", CmmT_INFO_TABLE ), - ( "INFO_TABLE_RET", CmmT_INFO_TABLE_RET ), - ( "INFO_TABLE_FUN", CmmT_INFO_TABLE_FUN ), - ( "INFO_TABLE_CONSTR", CmmT_INFO_TABLE_CONSTR ), - ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ), - ( "else", CmmT_else ), - ( "export", CmmT_export ), - ( "section", CmmT_section ), - ( "align", CmmT_align ), - ( "goto", CmmT_goto ), - ( "if", CmmT_if ), + map (\(x, y) -> (mkFastString x, y)) [ + ( "CLOSURE", CmmT_CLOSURE ), + ( "INFO_TABLE", CmmT_INFO_TABLE ), + ( "INFO_TABLE_RET", CmmT_INFO_TABLE_RET ), + ( "INFO_TABLE_FUN", CmmT_INFO_TABLE_FUN ), + ( "INFO_TABLE_CONSTR", CmmT_INFO_TABLE_CONSTR ), + ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ), + ( "else", CmmT_else ), + ( "export", CmmT_export ), + ( "section", CmmT_section ), + ( "align", CmmT_align ), + ( "goto", CmmT_goto ), + ( "if", CmmT_if ), ( "call", CmmT_call ), ( "jump", CmmT_jump ), ( "foreign", CmmT_foreign ), - ( "never", CmmT_never ), - ( "prim", CmmT_prim ), + ( "never", CmmT_never ), + ( "prim", CmmT_prim ), ( "reserve", CmmT_reserve ), ( "return", CmmT_return ), - ( "returns", CmmT_returns ), - ( "import", CmmT_import ), - ( "switch", CmmT_switch ), - ( "case", CmmT_case ), + ( "returns", CmmT_returns ), + ( "import", CmmT_import ), + ( "switch", CmmT_switch ), + ( "case", CmmT_case ), ( "default", CmmT_default ), ( "push", CmmT_push ), ( "bits8", CmmT_bits8 ), - ( "bits16", CmmT_bits16 ), - ( "bits32", CmmT_bits32 ), - ( "bits64", CmmT_bits64 ), - ( "bits128", CmmT_bits128 ), - ( "bits256", CmmT_bits256 ), - ( "bits512", CmmT_bits512 ), - ( "float32", CmmT_float32 ), - ( "float64", CmmT_float64 ), + ( "bits16", CmmT_bits16 ), + ( "bits32", CmmT_bits32 ), + ( "bits64", CmmT_bits64 ), + ( "bits128", CmmT_bits128 ), + ( "bits256", CmmT_bits256 ), + ( "bits512", CmmT_bits512 ), + ( "float32", CmmT_float32 ), + ( "float64", CmmT_float64 ), -- New forms - ( "b8", CmmT_bits8 ), - ( "b16", CmmT_bits16 ), - ( "b32", CmmT_bits32 ), - ( "b64", CmmT_bits64 ), - ( "b128", CmmT_bits128 ), - ( "b256", CmmT_bits256 ), - ( "b512", CmmT_bits512 ), - ( "f32", CmmT_float32 ), - ( "f64", CmmT_float64 ), - ( "gcptr", CmmT_gcptr ) - ] - -tok_decimal span buf len + ( "b8", CmmT_bits8 ), + ( "b16", CmmT_bits16 ), + ( "b32", CmmT_bits32 ), + ( "b64", CmmT_bits64 ), + ( "b128", CmmT_bits128 ), + ( "b256", CmmT_bits256 ), + ( "b512", CmmT_bits512 ), + ( "f32", CmmT_float32 ), + ( "f64", CmmT_float64 ), + ( "gcptr", CmmT_gcptr ) + ] + +tok_decimal span buf len = return (L span (CmmT_Int $! parseUnsignedInteger buf len 10 octDecDigit)) -tok_octal span buf len +tok_octal span buf len = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit)) -tok_hexadecimal span buf len +tok_hexadecimal span buf len = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit)) tok_float str = CmmT_Float $! readRational str tok_string str = CmmT_String (read str) - -- urk, not quite right, but it'll do for now + -- urk, not quite right, but it'll do for now -- ----------------------------------------------------------------------------- -- Line pragmas @@ -286,7 +286,7 @@ setLine :: Int -> Action setLine code span buf len = do let line = parseUnsignedInteger buf len 10 octDecDigit setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) - -- subtract one: the line number refers to the *following* line + -- subtract one: the line number refers to the *following* line -- trace ("setLine " ++ show line) $ do popLexState pushLexState code @@ -316,17 +316,17 @@ lexToken = do sc <- getLexState case alexScan inp sc of AlexEOF -> do let span = mkRealSrcSpan loc1 loc1 - setLastToken span 0 - return (L span CmmT_EOF) + setLastToken span 0 + return (L span CmmT_EOF) AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error" AlexSkip inp2 _ -> do - setInput inp2 - lexToken + setInput inp2 + lexToken AlexToken inp2@(end,buf2) len t -> do - setInput inp2 - let span = mkRealSrcSpan loc1 end - span `seq` setLastToken span len - t span buf len + setInput inp2 + let span = mkRealSrcSpan loc1 end + span `seq` setLastToken span len + t span buf len -- ----------------------------------------------------------------------------- -- Monad stuff @@ -351,7 +351,7 @@ alexGetByte (loc,s) where c = currentChar s b = fromIntegral $ ord $ c loc' = advanceSrcLoc loc c - s' = stepOn s + s' = stepOn s getInput :: P AlexInput getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (l,b) diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index c4ec393ad6..d8ce492de1 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -19,6 +19,9 @@ module CmmMachOp -- CallishMachOp , CallishMachOp(..), callishMachOpHints , pprCallishMachOp + + -- Atomic read-modify-write + , AtomicMachOp(..) ) where @@ -547,8 +550,24 @@ data CallishMachOp | MO_PopCnt Width | MO_BSwap Width + + -- Atomic read-modify-write. + | MO_AtomicRMW Width AtomicMachOp + | MO_AtomicRead Width + | MO_AtomicWrite Width + | MO_Cmpxchg Width deriving (Eq, Show) +-- | The operation to perform atomically. +data AtomicMachOp = + AMO_Add + | AMO_Sub + | AMO_And + | AMO_Nand + | AMO_Or + | AMO_Xor + deriving (Eq, Show) + pprCallishMachOp :: CallishMachOp -> SDoc pprCallishMachOp mo = text (show mo) diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 49143170c3..803333001c 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -573,7 +573,7 @@ importName -- A label imported with an explicit packageId. | STRING NAME - { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) } + { ($2, mkCmmCodeLabel (fsToPackageKey (mkFastString $1)) $2) } names :: { [FastString] } @@ -1101,7 +1101,7 @@ profilingInfo dflags desc_str ty_str else ProfilingInfo (stringToWord8s desc_str) (stringToWord8s ty_str) -staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> CmmParse () +staticClosure :: PackageKey -> FastString -> FastString -> [CmmLit] -> CmmParse () staticClosure pkg cl_label info payload = do dflags <- getDynFlags let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 4314695201..af4f62a4a8 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -326,10 +326,9 @@ _GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via. {- Note [unreachable blocks] The control-flow optimiser sometimes leaves unreachable blocks behind -containing junk code. If these blocks make it into the native code -generator then they trigger a register allocator panic because they -refer to undefined LocalRegs, so we must eliminate any unreachable -blocks before passing the code onwards. +containing junk code. These aren't necessarily a problem, but +removing them is good because it might save time in the native code +generator later. -} diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs index 4c025425ab..4dced9afd2 100644 --- a/compiler/cmm/CmmSink.hs +++ b/compiler/cmm/CmmSink.hs @@ -650,6 +650,10 @@ data AbsMem -- perhaps we ought to have a special annotation for calls that can -- modify heap/stack memory. For now we just use the conservative -- definition here. +-- +-- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and +-- therefore we should never float any memory operations across one of +-- these calls. bothMems :: AbsMem -> AbsMem -> AbsMem diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 47b247e278..455c79ba02 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -753,6 +753,10 @@ pprCallishMachOp_for_C mop MO_Memmove -> ptext (sLit "memmove") (MO_BSwap w) -> ptext (sLit $ bSwapLabel w) (MO_PopCnt w) -> ptext (sLit $ popCntLabel w) + (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop) + (MO_Cmpxchg w) -> ptext (sLit $ cmpxchgLabel w) + (MO_AtomicRead w) -> ptext (sLit $ atomicReadLabel w) + (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w) (MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w) MO_S_QuotRem {} -> unsupported diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index b5beb07ae9..cc3124028a 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -138,6 +138,9 @@ pprCmmGraph g $$ nest 2 (vcat $ map ppr blocks) $$ text "}" where blocks = postorderDfs g + -- postorderDfs has the side-effect of discarding unreachable code, + -- so pretty-printed Cmm will omit any unreachable blocks. This can + -- sometimes be confusing. --------------------------------------------- -- Outputting CmmNode and types which it contains diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index 1a69927b5c..edd064848f 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -190,7 +190,7 @@ buildDynCon' dflags platform binder _ _cc con [arg] , StgLitArg (MachInt val) <- arg , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer! , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto... - = do { let intlike_lbl = mkCmmClosureLabel rtsPackageId (fsLit "stg_INTLIKE") + = do { let intlike_lbl = mkCmmClosureLabel rtsPackageKey (fsLit "stg_INTLIKE") val_int = fromIntegral val :: Int offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1) -- INTLIKE closures consist of a header and one word payload @@ -205,7 +205,7 @@ buildDynCon' dflags platform binder _ _cc con [arg] , let val_int = ord val :: Int , val_int <= mAX_CHARLIKE dflags , val_int >= mIN_CHARLIKE dflags - = do { let charlike_lbl = mkCmmClosureLabel rtsPackageId (fsLit "stg_CHARLIKE") + = do { let charlike_lbl = mkCmmClosureLabel rtsPackageKey (fsLit "stg_CHARLIKE") offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1) -- CHARLIKE closures consist of a header and one word payload charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs index df1733978f..5f412b3cf8 100644 --- a/compiler/codeGen/StgCmmExtCode.hs +++ b/compiler/codeGen/StgCmmExtCode.hs @@ -57,7 +57,7 @@ data Named = VarN CmmExpr -- ^ Holds CmmLit(CmmLabel ..) which gives the label type, -- eg, RtsLabel, ForeignLabel, CmmLabel etc. - | FunN PackageId -- ^ A function name from this package + | FunN PackageKey -- ^ A function name from this package | LabelN BlockId -- ^ A blockid of some code or data. -- | An environment of named things. @@ -153,7 +153,7 @@ newBlockId = code F.newLabelC -- | Add add a local function to the environment. newFunctionName :: FastString -- ^ name of the function - -> PackageId -- ^ package of the current module + -> PackageKey -- ^ package of the current module -> ExtCode newFunctionName name pkg = addDecl name (FunN pkg) @@ -193,7 +193,7 @@ lookupName name = do case lookupUFM env name of Just (VarN e) -> e Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name)) - _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name)) + _other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey name)) -- | Lift an FCode computation into the CmmParse monad diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index d00dc6ec84..7ac2c7a0bd 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -516,7 +516,7 @@ generic_gc = mkGcLabel "stg_gc_noregs" -- | Create a CLabel for calling a garbage collector entry point mkGcLabel :: String -> CmmExpr -mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit s))) +mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit s))) ------------------------------- heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 99e926c987..d62101f27e 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -359,10 +359,10 @@ slowArgs dflags args -- careful: reps contains voids (V), but args does not (arg_pat, n) = slowCallPattern (map fst args) (call_args, rest_args) = splitAt n args - stg_ap_pat = mkCmmRetInfoLabel rtsPackageId arg_pat + stg_ap_pat = mkCmmRetInfoLabel rtsPackageKey arg_pat this_pat = (N, Just (mkLblExpr stg_ap_pat)) : call_args save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just curCCS)] - save_cccs_lbl = mkCmmRetInfoLabel rtsPackageId (fsLit "stg_restore_cccs") + save_cccs_lbl = mkCmmRetInfoLabel rtsPackageKey (fsLit "stg_restore_cccs") ------------------------------------------------------------------------- ---- Laying out objects on the heap and stack diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index cad261bcfb..22c89d7e05 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -494,7 +494,7 @@ withSelfLoop self_loop code = do instance HasDynFlags FCode where getDynFlags = liftM cgd_dflags getInfoDown -getThisPackage :: FCode PackageId +getThisPackage :: FCode PackageKey getThisPackage = liftM thisPackage getDynFlags withInfoDown :: FCode a -> CgInfoDownwards -> FCode a diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 40a5e3649b..e4c682bf02 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -769,6 +769,25 @@ emitPrimOp _ res PrefetchByteArrayOp0 args = doPrefetchByteArrayOp 0 res emitPrimOp _ res PrefetchMutableByteArrayOp0 args = doPrefetchByteArrayOp 0 res args emitPrimOp _ res PrefetchAddrOp0 args = doPrefetchAddrOp 0 res args +-- Atomic read-modify-write +emitPrimOp dflags [res] FetchAddByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Add mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchSubByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Sub mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchAndByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_And mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchNandByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Nand mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchOrByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Or mba ix (bWord dflags) n +emitPrimOp dflags [res] FetchXorByteArrayOp_Int [mba, ix, n] = + doAtomicRMW res AMO_Xor mba ix (bWord dflags) n +emitPrimOp dflags [res] AtomicReadByteArrayOp_Int [mba, ix] = + doAtomicReadByteArray res mba ix (bWord dflags) +emitPrimOp dflags [] AtomicWriteByteArrayOp_Int [mba, ix, val] = + doAtomicWriteByteArray mba ix (bWord dflags) val +emitPrimOp dflags [res] CasByteArrayOp_Int [mba, ix, old, new] = + doCasByteArray res mba ix (bWord dflags) old new -- The rest just translate straightforwardly emitPrimOp dflags [res] op [arg] @@ -1933,6 +1952,81 @@ doWriteSmallPtrArrayOp addr idx val = do emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) ------------------------------------------------------------------------------ +-- Atomic read-modify-write + +-- | Emit an atomic modification to a byte array element. The result +-- reg contains that previous value of the element. Implies a full +-- memory barrier. +doAtomicRMW :: LocalReg -- ^ Result reg + -> AtomicMachOp -- ^ Atomic op (e.g. add) + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Op argument (e.g. amount to add) + -> FCode () +doAtomicRMW res amop mba idx idx_ty n = do + dflags <- getDynFlags + let width = typeWidth idx_ty + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ res ] + (MO_AtomicRMW width amop) + [ addr, n ] + +-- | Emit an atomic read to a byte array that acts as a memory barrier. +doAtomicReadByteArray + :: LocalReg -- ^ Result reg + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> FCode () +doAtomicReadByteArray res mba idx idx_ty = do + dflags <- getDynFlags + let width = typeWidth idx_ty + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ res ] + (MO_AtomicRead width) + [ addr ] + +-- | Emit an atomic write to a byte array that acts as a memory barrier. +doAtomicWriteByteArray + :: CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Value to write + -> FCode () +doAtomicWriteByteArray mba idx idx_ty val = do + dflags <- getDynFlags + let width = typeWidth idx_ty + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ {- no results -} ] + (MO_AtomicWrite width) + [ addr, val ] + +doCasByteArray + :: LocalReg -- ^ Result reg + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Old value + -> CmmExpr -- ^ New value + -> FCode () +doCasByteArray res mba idx idx_ty old new = do + dflags <- getDynFlags + let width = (typeWidth idx_ty) + addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags) + width mba idx + emitPrimCall + [ res ] + (MO_Cmpxchg width) + [ addr, old, new ] + +------------------------------------------------------------------------------ -- Helpers for emitting function calls -- | Emit a call to @memcpy@. diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index 1aa08a1e58..7249477c9f 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -183,7 +183,7 @@ enterCostCentreFun ccs closure = ifProfiling $ do if isCurrentCCS ccs then do dflags <- getDynFlags - emitRtsCall rtsPackageId (fsLit "enterFunCCS") + emitRtsCall rtsPackageKey (fsLit "enterFunCCS") [(CmmReg (CmmGlobal BaseReg), AddrHint), (costCentreFrom dflags closure, AddrHint)] False else return () -- top-level function, nothing to do @@ -285,7 +285,7 @@ emitSetCCC cc tick push pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc = emitRtsCallWithResult result AddrHint - rtsPackageId + rtsPackageKey (fsLit "pushCostCentre") [(ccs,AddrHint), (CmmLit (mkCCostCentre cc), AddrHint)] False @@ -356,7 +356,7 @@ ldvEnter cl_ptr = do loadEra :: DynFlags -> CmmExpr loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags)) - [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) + [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageKey (fsLit "era"))) (cInt dflags)] ldvWord :: DynFlags -> CmmExpr -> CmmExpr diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index 6913c9ec15..3652a79979 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -327,7 +327,7 @@ registerTickyCtr ctr_lbl = do , mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_registeredp dflags))) (mkIntExpr dflags 1) ] - ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) + ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageKey (fsLit "ticky_entry_ctrs")) emit =<< mkCmmIfThen test (catAGraphs register_stmts) tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode () @@ -472,12 +472,12 @@ tickyAllocHeap genuine hp bytes, -- Bump the global allocation total ALLOC_HEAP_tot addToMemLbl (cLong dflags) - (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_tot")) + (mkCmmDataLabel rtsPackageKey (fsLit "ALLOC_HEAP_tot")) bytes, -- Bump the global allocation counter ALLOC_HEAP_ctr if not genuine then mkNop else addToMemLbl (cLong dflags) - (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_ctr")) + (mkCmmDataLabel rtsPackageKey (fsLit "ALLOC_HEAP_ctr")) 1 ]} @@ -541,13 +541,13 @@ ifTickyDynThunk :: FCode () -> FCode () ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code bumpTickyCounter :: FastString -> FCode () -bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsPackageId lbl) +bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsPackageKey lbl) bumpTickyCounterBy :: FastString -> Int -> FCode () -bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsPackageId lbl) +bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsPackageKey lbl) bumpTickyCounterByE :: FastString -> CmmExpr -> FCode () -bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsPackageId lbl) +bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsPackageKey lbl) bumpTickyEntryCount :: CLabel -> FCode () bumpTickyEntryCount lbl = do diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index bc1a15fe3c..985c6db900 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -175,10 +175,10 @@ tagToClosure dflags tycon tag -- ------------------------------------------------------------------------- -emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () +emitRtsCall :: PackageKey -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe -emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString +emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageKey -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode () emitRtsCallWithResult res hint pkg fun args safe = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index a5868108d9..f4607823a8 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -207,7 +207,8 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) ; binder_ty <- applySubstTy binder_ty ; checkTys binder_ty ty (mkRhsMsg binder (ptext (sLit "RHS")) ty) - -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples) + -- Check the let/app invariant + -- See Note [CoreSyn let/app invariant] in CoreSyn ; checkL (not (isUnLiftedType binder_ty) || (isNonRec rec_flag && exprOkForSpeculation rhs)) (mkRhsPrimMsg binder rhs) @@ -220,6 +221,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) -- Check that if the binder is local, it is not marked as exported ; checkL (not (isExportedId binder) || isTopLevel top_lvl_flag) (mkNonTopExportedMsg binder) + -- Check that if the binder is local, it does not have an external name ; checkL (not (isExternalName (Var.varName binder)) || isTopLevel top_lvl_flag) (mkNonTopExternalNameMsg binder) @@ -451,6 +453,8 @@ lintCoreArg fun_ty (Type arg_ty) lintCoreArg fun_ty arg = do { arg_ty <- lintCoreExpr arg + ; checkL (not (isUnLiftedType arg_ty) || exprOkForSpeculation arg) + (mkLetAppMsg arg) ; lintValApp arg fun_ty arg_ty } ----------------- @@ -1391,6 +1395,11 @@ mkRhsMsg binder what ty hsep [ptext (sLit "Binder's type:"), ppr (idType binder)], hsep [ptext (sLit "Rhs type:"), ppr ty]] +mkLetAppMsg :: CoreExpr -> MsgDoc +mkLetAppMsg e + = hang (ptext (sLit "This argument does not satisfy the let/app invariant:")) + 2 (ppr e) + mkRhsPrimMsg :: Id -> CoreExpr -> MsgDoc mkRhsPrimMsg binder _rhs = vcat [hsep [ptext (sLit "The type of this binder is primitive:"), diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index c754aae4e7..bbf104b127 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -1115,9 +1115,9 @@ data CorePrepEnv = CPE { lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id lookupMkIntegerName dflags hsc_env - = if thisPackage dflags == primPackageId + = if thisPackage dflags == primPackageKey then return $ panic "Can't use Integer in ghc-prim" - else if thisPackage dflags == integerPackageId + else if thisPackage dflags == integerPackageKey then return $ panic "Can't use Integer in integer" else liftM tyThingId $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName) diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index b36cb6d8a6..12a60daddd 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -180,25 +180,8 @@ These data types are the heart of the compiler -- /must/ be of lifted type (see "Type#type_classification" for -- the meaning of /lifted/ vs. /unlifted/). -- --- #let_app_invariant# --- The right hand side of of a non-recursive 'Let' --- _and_ the argument of an 'App', --- /may/ be of unlifted type, but only if the expression --- is ok-for-speculation. This means that the let can be floated --- around without difficulty. For example, this is OK: --- --- > y::Int# = x +# 1# --- --- But this is not, as it may affect termination if the --- expression is floated out: --- --- > y::Int# = fac 4# --- --- In this situation you should use @case@ rather than a @let@. The function --- 'CoreUtils.needsCaseBinding' can help you determine which to generate, or --- alternatively use 'MkCore.mkCoreLet' rather than this constructor directly, --- which will generate a @case@ if necessary --- +-- See Note [CoreSyn let/app invariant] +-- -- #type_let# -- We allow a /non-recursive/ let to bind a type variable, thus: -- @@ -359,9 +342,28 @@ See #letrec_invariant# Note [CoreSyn let/app invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #let_app_invariant# +The let/app invariant + the right hand side of of a non-recursive 'Let', and + the argument of an 'App', + /may/ be of unlifted type, but only if + the expression is ok-for-speculation. + +This means that the let can be floated around +without difficulty. For example, this is OK: + + y::Int# = x +# 1# + +But this is not, as it may affect termination if the +expression is floated out: + + y::Int# = fac 4# + +In this situation you should use @case@ rather than a @let@. The function +'CoreUtils.needsCaseBinding' can help you determine which to generate, or +alternatively use 'MkCore.mkCoreLet' rather than this constructor directly, +which will generate a @case@ if necessary -This is intially enforced by DsUtils.mkCoreLet and mkCoreApp +Th let/app invariant is initially enforced by DsUtils.mkCoreLet and mkCoreApp Note [CoreSyn case invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1215,8 +1217,9 @@ mkDoubleLitDouble :: Double -> Expr b mkDoubleLit d = Lit (mkMachDouble d) mkDoubleLitDouble d = Lit (mkMachDouble (toRational d)) --- | Bind all supplied binding groups over an expression in a nested let expression. Prefer to --- use 'MkCore.mkCoreLets' if possible +-- | Bind all supplied binding groups over an expression in a nested let expression. Assumes +-- that the rhs satisfies the let/app invariant. Prefer to use 'MkCore.mkCoreLets' if +-- possible, which does guarantee the invariant mkLets :: [Bind b] -> Expr b -> Expr b -- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to -- use 'MkCore.mkCoreLams' if possible diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 3bf07febf3..baf7e4fa80 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -908,13 +908,22 @@ it's applied only to dictionaries. -- Note [exprOkForSpeculation: case expressions] below -- -- Precisely, it returns @True@ iff: +-- a) The expression guarantees to terminate, +-- b) soon, +-- c) without causing a write side effect (e.g. writing a mutable variable) +-- d) without throwing a Haskell exception +-- e) without risking an unchecked runtime exception (array out of bounds, +-- divide by zero) -- --- * The expression guarantees to terminate, --- * soon, --- * without raising an exception, --- * without causing a side effect (e.g. writing a mutable variable) +-- For @exprOkForSideEffects@ the list is the same, but omitting (e). +-- +-- Note that +-- exprIsHNF implies exprOkForSpeculation +-- exprOkForSpeculation implies exprOkForSideEffects +-- +-- See Note [PrimOp can_fail and has_side_effects] in PrimOp +-- and Note [Implementation: how can_fail/has_side_effects affect transformations] -- --- Note that if @exprIsHNF e@, then @exprOkForSpecuation e@. -- As an example of the considerations in this test, consider: -- -- > let x = case y# +# 1# of { r# -> I# r# } @@ -964,7 +973,7 @@ app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool app_ok primop_ok fun args = case idDetails fun of DFunId _ new_type -> not new_type - -- DFuns terminate, unless the dict is implemented + -- DFuns terminate, unless the dict is implemented -- with a newtype in which case they may not DataConWorkId {} -> True @@ -983,14 +992,12 @@ app_ok primop_ok fun args -> True | otherwise - -> primop_ok op -- A bit conservative: we don't really need - && all (expr_ok primop_ok) args - - -- to care about lazy arguments, but this is easy + -> primop_ok op -- A bit conservative: we don't really need + && all (expr_ok primop_ok) args -- to care about lazy arguments, but this is easy _other -> isUnLiftedType (idType fun) -- c.f. the Var case of exprIsHNF || idArity fun > n_val_args -- Partial apps - || (n_val_args == 0 && + || (n_val_args == 0 && isEvaldUnfolding (idUnfolding fun)) -- Let-bound values where n_val_args = valArgCount args diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index 721dc968fc..3ba8b1d6ee 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -304,9 +304,9 @@ mkStringExprFS str mkEqBox :: Coercion -> CoreExpr mkEqBox co = ASSERT2( typeKind ty2 `eqKind` k, ppr co $$ ppr ty1 $$ ppr ty2 $$ ppr (typeKind ty1) $$ ppr (typeKind ty2) ) Var (dataConWorkId datacon) `mkTyApps` [k, ty1, ty2] `App` Coercion co - where Pair ty1 ty2 = coercionKind co + where (Pair ty1 ty2, role) = coercionKindRole co k = typeKind ty1 - datacon = case coercionRole co of + datacon = case role of Nominal -> eqBoxDataCon Representational -> coercibleDataCon Phantom -> pprPanic "mkEqBox does not support boxing phantom coercions" @@ -415,12 +415,17 @@ mkBigCoreTupTy = mkChunkified mkBoxedTupleTy %************************************************************************ \begin{code} -data FloatBind +data FloatBind = FloatLet CoreBind - | FloatCase CoreExpr Id AltCon [Var] + | FloatCase CoreExpr Id AltCon [Var] -- case e of y { C ys -> ... } -- See Note [Floating cases] in SetLevels +instance Outputable FloatBind where + ppr (FloatLet b) = ptext (sLit "LET") <+> ppr b + ppr (FloatCase e b c bs) = hang (ptext (sLit "CASE") <+> ppr e <+> ptext (sLit "of") <+> ppr b) + 2 (ppr c <+> ppr bs) + wrapFloat :: FloatBind -> CoreExpr -> CoreExpr wrapFloat (FloatLet defns) body = Let defns body wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)] diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index e646667651..fae5f36426 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -154,8 +154,8 @@ writeMixEntries dflags mod count entries filename mod_name = moduleNameString (moduleName mod) hpc_mod_dir - | modulePackageId mod == mainPackageId = hpc_dir - | otherwise = hpc_dir ++ "/" ++ packageIdString (modulePackageId mod) + | modulePackageKey mod == mainPackageKey = hpc_dir + | otherwise = hpc_dir ++ "/" ++ packageKeyString (modulePackageKey mod) tabStop = 8 -- <tab> counts as a normal char in GHC's location ranges. @@ -1233,9 +1233,9 @@ hpcInitCode this_mod (HpcInfo tickCount hashNo) module_name = hcat (map (text.charToC) $ bytesFS (moduleNameFS (Module.moduleName this_mod))) package_name = hcat (map (text.charToC) $ - bytesFS (packageIdFS (modulePackageId this_mod))) + bytesFS (packageKeyFS (modulePackageKey this_mod))) full_name_str - | modulePackageId this_mod == mainPackageId + | modulePackageKey this_mod == mainPackageKey = module_name | otherwise = package_name <> char '/' <> module_name diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 1bbcc05e40..35a2477fd5 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -466,8 +466,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd) left_con <- dsLookupDataCon leftDataConName right_con <- dsLookupDataCon rightDataConName - let mk_left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e] - mk_right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e] + let mk_left_expr ty1 ty2 e = mkCoreConApps left_con [Type ty1, Type ty2, e] + mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1, Type ty2, e] in_ty = envStackType env_ids stack_ty then_ty = envStackType then_ids stack_ty diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 9691b99975..172d19b9ac 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -35,6 +35,7 @@ import HsSyn -- lots of things import CoreSyn -- lots of things import Literal ( Literal(MachStr) ) import CoreSubst +import OccurAnal ( occurAnalyseExpr ) import MkCore import CoreUtils import CoreArity ( etaExpand ) @@ -454,7 +455,10 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) ; (bndrs, ds_lhs) <- liftM collectBinders (dsHsWrapper spec_co (Var poly_id)) ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs) - ; case decomposeRuleLhs bndrs ds_lhs of { + ; -- pprTrace "dsRule" (vcat [ ptext (sLit "Id:") <+> ppr poly_id + -- , ptext (sLit "spec_co:") <+> ppr spec_co + -- , ptext (sLit "ds_rhs:") <+> ppr ds_lhs ]) $ + case decomposeRuleLhs bndrs ds_lhs of { Left msg -> do { warnDs msg; return Nothing } ; Right (rule_bndrs, _fn, args) -> do @@ -578,7 +582,7 @@ SPEC f :: ty [n] INLINE [k] decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr]) -- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE, -- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs --- may add some extra dictionary binders (see Note [Constant rule dicts]) +-- may add some extra dictionary binders (see Note [Free dictionaries]) -- -- Returns Nothing if the LHS isn't of the expected shape -- Note [Decomposing the left-hand side of a RULE] @@ -589,7 +593,13 @@ decomposeRuleLhs orig_bndrs orig_lhs | Var fn_var <- fun , not (fn_var `elemVarSet` orig_bndr_set) - = Right (bndrs1, fn_var, args) + = -- pprTrace "decmposeRuleLhs" (vcat [ ptext (sLit "orig_bndrs:") <+> ppr orig_bndrs + -- , ptext (sLit "orig_lhs:") <+> ppr orig_lhs + -- , ptext (sLit "lhs1:") <+> ppr lhs1 + -- , ptext (sLit "bndrs1:") <+> ppr bndrs1 + -- , ptext (sLit "fn_var:") <+> ppr fn_var + -- , ptext (sLit "args:") <+> ppr args]) $ + Right (bndrs1, fn_var, args) | Case scrut bndr ty [(DEFAULT, _, body)] <- fun , isDeadBinder bndr -- Note [Matching seqId] @@ -608,7 +618,7 @@ decomposeRuleLhs orig_bndrs orig_lhs orig_bndr_set = mkVarSet orig_bndrs - -- Add extra dict binders: Note [Constant rule dicts] + -- Add extra dict binders: Note [Free dictionaries] extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d) | d <- varSetElems (lhs_fvs `delVarSetList` orig_bndrs) , isDictId d ] @@ -618,19 +628,41 @@ decomposeRuleLhs orig_bndrs orig_lhs , text "Orig lhs:" <+> ppr orig_lhs]) dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr , ptext (sLit "is not bound in RULE lhs")]) - 2 (ppr lhs2) + 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs + , text "Orig lhs:" <+> ppr orig_lhs + , text "optimised lhs:" <+> ppr lhs2 ]) pp_bndr bndr | isTyVar bndr = ptext (sLit "type variable") <+> quotes (ppr bndr) | Just pred <- evVarPred_maybe bndr = ptext (sLit "constraint") <+> quotes (ppr pred) | otherwise = ptext (sLit "variable") <+> quotes (ppr bndr) drop_dicts :: CoreExpr -> CoreExpr - drop_dicts (Let (NonRec d rhs) body) - | isDictId d - , not (exprFreeVars rhs `intersectsVarSet` orig_bndr_set) - = drop_dicts body - drop_dicts (Let bnd body) = Let bnd (drop_dicts body) - drop_dicts body = body + drop_dicts e + = wrap_lets needed bnds body + where + needed = orig_bndr_set `minusVarSet` exprFreeVars body + (bnds, body) = split_lets (occurAnalyseExpr e) + -- The occurAnalyseExpr drops dead bindings which is + -- crucial to ensure that every binding is used later; + -- which in turn makes wrap_lets work right + + split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr) + split_lets e + | Let (NonRec d r) body <- e + , isDictId d + , (bs, body') <- split_lets body + = ((d,r):bs, body') + | otherwise + = ([], e) + + wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr + wrap_lets _ [] body = body + wrap_lets needed ((d, r) : bs) body + | rhs_fvs `intersectsVarSet` needed = Let (NonRec d r) (wrap_lets needed' bs body) + | otherwise = wrap_lets needed bs body + where + rhs_fvs = exprFreeVars r + needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d \end{code} Note [Decomposing the left-hand side of a RULE] @@ -638,7 +670,7 @@ Note [Decomposing the left-hand side of a RULE] There are several things going on here. * drop_dicts: see Note [Drop dictionary bindings on rule LHS] * simpleOptExpr: see Note [Simplify rule LHS] -* extra_dict_bndrs: see Note [Free rule dicts] +* extra_dict_bndrs: see Note [Free dictionaries] Note [Drop dictionary bindings on rule LHS] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -666,9 +698,36 @@ drop_dicts drops dictionary bindings on the LHS where possible. will be simple NonRec bindings. We don't handle recursive dictionaries! + NB3: In the common case of a non-overloaded, but perhpas-polymorphic + specialisation, we don't need to bind *any* dictionaries for use + in the RHS. For example (Trac #8331) + {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-} + useAbstractMonad :: MonadAbstractIOST m => m Int + Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code + but the RHS uses no dictionaries, so we want to end up with + RULE forall s (d :: MonadBstractIOST (ReaderT s)). + useAbstractMonad (ReaderT s) d = $suseAbstractMonad s + Trac #8848 is a good example of where there are some intersting dictionary bindings to discard. +The drop_dicts algorithm is based on these observations: + + * Given (let d = rhs in e) where d is a DictId, + matching 'e' will bind e's free variables. + + * So we want to keep the binding if one of the needed variables (for + which we need a binding) is in fv(rhs) but not already in fv(e). + + * The "needed variables" are simply the orig_bndrs. Consider + f :: (Eq a, Show b) => a -> b -> String + {-# SPECIALISE f :: (Show b) => Int -> b -> String + Then orig_bndrs includes the *quantified* dictionaries of the type + namely (dsb::Show b), but not the one for Eq Int + +So we work inside out, applying the above criterion at each step. + + Note [Simplify rule LHS] ~~~~~~~~~~~~~~~~~~~~~~~~ simplOptExpr occurrence-analyses and simplifies the LHS: diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index 217a4ce7c9..a47b9ea4dd 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -238,9 +238,9 @@ boxResult result_ty _ -> [] return_result state anss - = mkConApp (tupleCon UnboxedTuple (2 + length extra_result_tys)) - (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys) - ++ (state : anss)) + = mkCoreConApps (tupleCon UnboxedTuple (2 + length extra_result_tys)) + (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys) + ++ (state : anss)) ; (ccall_res_ty, the_alt) <- mk_alt return_result res diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 4eadef69b8..2a2d733995 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -292,9 +292,9 @@ dsExpr (ExplicitTuple tup_args boxity) ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args) -- The reverse is because foldM goes left-to-right - ; return $ mkCoreLams lam_vars $ - mkConApp (tupleCon (boxityNormalTupleSort boxity) (length tup_args)) - (map (Type . exprType) args ++ args) } + ; return $ mkCoreLams lam_vars $ + mkCoreConApps (tupleCon (boxityNormalTupleSort boxity) (length tup_args)) + (map (Type . exprType) args ++ args) } dsExpr (HsSCC cc expr@(L loc _)) = do mod_name <- getModule @@ -435,7 +435,7 @@ dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do then mapM unlabelled_bottom arg_tys else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels) - return (mkApps con_expr' con_args) + return (mkCoreApps con_expr' con_args) \end{code} Record update is a little harder. Suppose we have the decl: diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 0654ebc983..c60e9146bc 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -224,9 +224,9 @@ dsFCall fn_id co fcall mDeclHeader = do dflags <- getDynFlags (fcall', cDoc) <- case fcall of - CCall (CCallSpec (StaticTarget cName mPackageId isFun) CApiConv safety) -> + CCall (CCallSpec (StaticTarget cName mPackageKey isFun) CApiConv safety) -> do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName) - let fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId True) CApiConv safety) + let fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageKey True) CApiConv safety) c = includes $$ fun_proto <+> braces (cRet <> semi) includes = vcat [ text "#include <" <> ftext h <> text ">" diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 435f5c73a2..28e6feffec 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -396,10 +396,10 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) ; repTySynInst tc eqn1 } repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ) -repTyFamEqn (L loc (TyFamInstEqn { tfie_pats = HsWB { hswb_cts = tys - , hswb_kvs = kv_names - , hswb_tvs = tv_names } - , tfie_rhs = rhs })) +repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys + , hswb_kvs = kv_names + , hswb_tvs = tv_names } + , tfe_rhs = rhs })) = do { let hs_tvs = HsQTvs { hsq_kvs = kv_names , hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk ; addTyClTyVarBinds hs_tvs $ \ _ -> @@ -1416,7 +1416,7 @@ globalVar name where mod = ASSERT( isExternalName name) nameModule name name_mod = moduleNameString (moduleName mod) - name_pkg = packageIdString (modulePackageId mod) + name_pkg = packageKeyString (modulePackageKey mod) name_occ = nameOccName name mk_varg | OccName.isDataOcc name_occ = mkNameG_dName | OccName.isVarOcc name_occ = mkNameG_vName @@ -1476,7 +1476,7 @@ rep2 n xs = do { id <- dsLookupGlobalId n dataCon' :: Name -> [CoreExpr] -> DsM (Core a) dataCon' n args = do { id <- dsLookupDataCon n - ; return $ MkC $ mkConApp id args } + ; return $ MkC $ mkCoreConApps id args } dataCon :: Name -> DsM (Core a) dataCon n = dataCon' n [] @@ -2117,7 +2117,7 @@ thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib") qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote") mkTHModule :: FastString -> Module -mkTHModule m = mkModule thPackageId (mkModuleNameFS m) +mkTHModule m = mkModule thPackageKey (mkModuleNameFS m) libFun, libTc, thFun, thTc, thCon, qqFun :: FastString -> Unique -> Name libFun = mk_known_key_name OccName.varName thLib diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 350ed22d69..71a5e10636 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -92,7 +92,7 @@ dsLit (HsInt i) = do dflags <- getDynFlags dsLit (HsRat r ty) = do num <- mkIntegerExpr (numerator (fl_value r)) denom <- mkIntegerExpr (denominator (fl_value r)) - return (mkConApp ratio_data_con [Type integer_ty, num, denom]) + return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) where (ratio_data_con, integer_ty) = case tcSplitTyConApp ty of diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index e6f86c97d9..d449adac67 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -104,6 +104,13 @@ Library Include-Dirs: . parser utils + if impl( ghc >= 7.9 ) + -- We need to set the package key to ghc (without a version number) + -- as it's magic. But we can't set it for old versions of GHC (e.g. + -- when bootstrapping) because those versions of GHC don't understand + -- that GHC is wired-in. + GHC-Options: -this-package-key ghc + if flag(stage1) Include-Dirs: stage1 else diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 4977e28769..d23d1fe5b6 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -99,8 +99,6 @@ endif @echo 'cGhcEnableTablesNextToCode = "$(GhcEnableTablesNextToCode)"' >> $@ @echo 'cLeadingUnderscore :: String' >> $@ @echo 'cLeadingUnderscore = "$(LeadingUnderscore)"' >> $@ - @echo 'cRAWCPP_FLAGS :: String' >> $@ - @echo 'cRAWCPP_FLAGS = "$(RAWCPP_FLAGS)"' >> $@ @echo 'cGHC_UNLIT_PGM :: String' >> $@ @echo 'cGHC_UNLIT_PGM = "$(utils/unlit_dist_PROG)"' >> $@ @echo 'cGHC_SPLIT_PGM :: String' >> $@ @@ -439,8 +437,14 @@ ifeq "$(compiler_stage1_VERSION_MUNGED)" "YES" compiler_stage1_MUNGED_VERSION = $(subst .$(ProjectPatchLevel),,$(ProjectVersion)) define compiler_PACKAGE_MAGIC compiler_stage1_VERSION = $(compiler_stage1_MUNGED_VERSION) +compiler_stage1_PACKAGE_KEY = $(subst .$(ProjectPatchLevel),,$(compiler_stage1_PACKAGE_KEY)) endef +# NB: the PACKAGE_KEY munging has no effect for new-style package keys +# (which indeed, have nothing version like in them, but are important for +# old-style package keys which do.) The subst operation is idempotent, so +# as long as we do it at least once we should be good. + # Don't register the non-munged package compiler_stage1_REGISTER_PACKAGE = NO @@ -667,9 +671,9 @@ compiler_stage2_CONFIGURE_OPTS += --disable-library-for-ghci compiler_stage3_CONFIGURE_OPTS += --disable-library-for-ghci # after build-package, because that sets compiler_stage1_HC_OPTS: -compiler_stage1_HC_OPTS += $(GhcStage1HcOpts) -compiler_stage2_HC_OPTS += $(GhcStage2HcOpts) -compiler_stage3_HC_OPTS += $(GhcStage3HcOpts) +compiler_stage1_HC_OPTS += $(GhcHcOpts) $(GhcStage1HcOpts) +compiler_stage2_HC_OPTS += $(GhcHcOpts) $(GhcStage2HcOpts) +compiler_stage3_HC_OPTS += $(GhcHcOpts) $(GhcStage3HcOpts) ifneq "$(BINDIST)" "YES" diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index d4a58044f5..645a0d8118 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -6,13 +6,6 @@ ByteCodeGen: Generate bytecode from Core \begin{code} {-# LANGUAGE CPP, MagicHash #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where #include "HsVersions.h" @@ -278,7 +271,7 @@ collect :: AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet) collect (_, e) = go [] e where go xs e | Just e' <- bcView e = go xs e' - go xs (AnnLam x (_,e)) + go xs (AnnLam x (_,e)) | UbxTupleRep _ <- repType (idType x) = unboxedTupleException | otherwise @@ -820,8 +813,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple MASSERT(isAlgCase) rhs_code <- schemeE (d_alts + size) s p' rhs return (my_discr alt, unitOL (UNPACK (trunc16 size)) `appOL` rhs_code) - where - real_bndrs = filterOut isTyVar bndrs + where + real_bndrs = filterOut isTyVar bndrs my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-} my_discr (DataAlt dc, _, _) @@ -1253,8 +1246,8 @@ pushAtom d p e | Just e' <- bcView e = pushAtom d p e' -pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things, - = return (nilOL, 0) -- treated just like a variable V +pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things, + = return (nilOL, 0) -- treated just like a variable V pushAtom d p (AnnVar v) | UnaryRep rep_ty <- repType (idType v) @@ -1564,12 +1557,12 @@ isVAtom :: AnnExpr' Var ann -> Bool isVAtom e | Just e' <- bcView e = isVAtom e' isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v) isVAtom (AnnCoercion {}) = True -isVAtom _ = False +isVAtom _ = False atomPrimRep :: AnnExpr' Id ann -> PrimRep atomPrimRep e | Just e' <- bcView e = atomPrimRep e' -atomPrimRep (AnnVar v) = bcIdPrimRep v -atomPrimRep (AnnLit l) = typePrimRep (literalType l) +atomPrimRep (AnnVar v) = bcIdPrimRep v +atomPrimRep (AnnLit l) = typePrimRep (literalType l) atomPrimRep (AnnCoercion {}) = VoidRep atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other))) diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs index 548c29f514..5535d58453 100644 --- a/compiler/ghci/ByteCodeInstr.lhs +++ b/compiler/ghci/ByteCodeInstr.lhs @@ -5,23 +5,15 @@ ByteCodeInstrs: Bytecode instruction definitions \begin{code} {-# LANGUAGE CPP, MagicHash #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - {-# OPTIONS_GHC -funbox-strict-fields #-} - -module ByteCodeInstr ( - BCInstr(..), ProtoBCO(..), bciStackUse, BreakInfo (..) +module ByteCodeInstr ( + BCInstr(..), ProtoBCO(..), bciStackUse, BreakInfo (..) ) where #include "HsVersions.h" #include "../includes/MachDeps.h" -import ByteCodeItbls ( ItblPtr ) +import ByteCodeItbls ( ItblPtr ) import StgCmmLayout ( ArgRep(..) ) import PprCore @@ -44,17 +36,17 @@ import Data.Word -- ---------------------------------------------------------------------------- -- Bytecode instructions -data ProtoBCO a - = ProtoBCO { - protoBCOName :: a, -- name, in some sense - protoBCOInstrs :: [BCInstr], -- instrs - -- arity and GC info - protoBCOBitmap :: [StgWord], - protoBCOBitmapSize :: Word16, - protoBCOArity :: Int, - -- what the BCO came from - protoBCOExpr :: Either [AnnAlt Id VarSet] (AnnExpr Id VarSet), - -- malloc'd pointers +data ProtoBCO a + = ProtoBCO { + protoBCOName :: a, -- name, in some sense + protoBCOInstrs :: [BCInstr], -- instrs + -- arity and GC info + protoBCOBitmap :: [StgWord], + protoBCOBitmapSize :: Word16, + protoBCOArity :: Int, + -- what the BCO came from + protoBCOExpr :: Either [AnnAlt Id VarSet] (AnnExpr Id VarSet), + -- malloc'd pointers protoBCOPtrs :: [Either ItblPtr (Ptr ())] } @@ -80,14 +72,14 @@ data BCInstr -- Pushing literals | PUSH_UBX (Either Literal (Ptr ())) Word16 - -- push this int/float/double/addr, on the stack. Word16 - -- is # of words to copy from literal pool. Eitherness reflects - -- the difficulty of dealing with MachAddr here, mostly due to - -- the excessive (and unnecessary) restrictions imposed by the - -- designers of the new Foreign library. In particular it is - -- quite impossible to convert an Addr to any other integral - -- type, and it appears impossible to get hold of the bits of - -- an addr, even though we need to assemble BCOs. + -- push this int/float/double/addr, on the stack. Word16 + -- is # of words to copy from literal pool. Eitherness reflects + -- the difficulty of dealing with MachAddr here, mostly due to + -- the excessive (and unnecessary) restrictions imposed by the + -- designers of the new Foreign library. In particular it is + -- quite impossible to convert an Addr to any other integral + -- type, and it appears impossible to get hold of the bits of + -- an addr, even though we need to assemble BCOs. -- various kinds of application | PUSH_APPLY_N @@ -112,8 +104,8 @@ data BCInstr | MKPAP !Word16{-ptr to PAP is this far down stack-} !Word16{-number of words-} | UNPACK !Word16 -- unpack N words from t.o.s Constr | PACK DataCon !Word16 - -- after assembly, the DataCon is an index into the - -- itbl array + -- after assembly, the DataCon is an index into the + -- itbl array -- For doing case trees | LABEL LocalLabel | TESTLT_I Int LocalLabel @@ -147,13 +139,13 @@ data BCInstr -- To Infinity And Beyond | ENTER - | RETURN -- return a lifted value + | RETURN -- return a lifted value | RETURN_UBX ArgRep -- return an unlifted value, here's its rep - -- Breakpoints + -- Breakpoints | BRK_FUN (MutableByteArray# RealWorld) Word16 BreakInfo -data BreakInfo +data BreakInfo = BreakInfo { breakInfo_module :: Module , breakInfo_number :: {-# UNPACK #-} !Int @@ -173,8 +165,8 @@ instance Outputable BreakInfo where instance Outputable a => Outputable (ProtoBCO a) where ppr (ProtoBCO name instrs bitmap bsize arity origin malloced) - = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity - <+> text (show malloced) <> colon) + = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity + <+> text (show malloced) <> colon) $$ nest 3 (case origin of Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';')) (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}' @@ -212,8 +204,8 @@ instance Outputable BCInstr where ppr (PUSH_L offset) = text "PUSH_L " <+> ppr offset ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> ppr o1 <+> ppr o2 ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3 - ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm - ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers." + ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm + ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers." <> ppr op ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco) ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco) @@ -221,23 +213,23 @@ instance Outputable BCInstr where ppr (PUSH_UBX (Left lit) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit ppr (PUSH_UBX (Right aa) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> text (show aa) - ppr PUSH_APPLY_N = text "PUSH_APPLY_N" - ppr PUSH_APPLY_V = text "PUSH_APPLY_V" - ppr PUSH_APPLY_F = text "PUSH_APPLY_F" - ppr PUSH_APPLY_D = text "PUSH_APPLY_D" - ppr PUSH_APPLY_L = text "PUSH_APPLY_L" - ppr PUSH_APPLY_P = text "PUSH_APPLY_P" - ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP" - ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP" - ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP" - ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP" - ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP" + ppr PUSH_APPLY_N = text "PUSH_APPLY_N" + ppr PUSH_APPLY_V = text "PUSH_APPLY_V" + ppr PUSH_APPLY_F = text "PUSH_APPLY_F" + ppr PUSH_APPLY_D = text "PUSH_APPLY_D" + ppr PUSH_APPLY_L = text "PUSH_APPLY_L" + ppr PUSH_APPLY_P = text "PUSH_APPLY_P" + ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP" + ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP" + ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP" + ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP" + ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP" ppr (SLIDE n d) = text "SLIDE " <+> ppr n <+> ppr d ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> ppr sz ppr (ALLOC_AP_NOUPD sz) = text "ALLOC_AP_NOUPD " <+> ppr sz ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> ppr arity <+> ppr sz - ppr (MKAP offset sz) = text "MKAP " <+> ppr sz <+> text "words," + ppr (MKAP offset sz) = text "MKAP " <+> ppr sz <+> text "words," <+> ppr offset <+> text "stkoff" ppr (MKPAP offset sz) = text "MKPAP " <+> ppr sz <+> text "words," <+> ppr offset <+> text "stkoff" @@ -256,8 +248,8 @@ instance Outputable BCInstr where ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab ppr CASEFAIL = text "CASEFAIL" ppr (JMP lab) = text "JMP" <+> ppr lab - ppr (CCALL off marshall_addr int) = text "CCALL " <+> ppr off - <+> text "marshall code at" + ppr (CCALL off marshall_addr int) = text "CCALL " <+> ppr off + <+> text "marshall code at" <+> text (show marshall_addr) <+> (if int == 1 then text "(interruptible)" @@ -265,7 +257,7 @@ instance Outputable BCInstr where ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff <+> text "by" <+> ppr n ppr ENTER = text "ENTER" - ppr RETURN = text "RETURN" + ppr RETURN = text "RETURN" ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk ppr (BRK_FUN _breakArray index info) = text "BRK_FUN" <+> text "<array>" <+> ppr index <+> ppr info @@ -284,54 +276,54 @@ protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco)) bciStackUse :: BCInstr -> Word bciStackUse STKCHECK{} = 0 -bciStackUse PUSH_L{} = 1 -bciStackUse PUSH_LL{} = 2 +bciStackUse PUSH_L{} = 1 +bciStackUse PUSH_LL{} = 2 bciStackUse PUSH_LLL{} = 3 -bciStackUse PUSH_G{} = 1 +bciStackUse PUSH_G{} = 1 bciStackUse PUSH_PRIMOP{} = 1 -bciStackUse PUSH_BCO{} = 1 +bciStackUse PUSH_BCO{} = 1 bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco bciStackUse (PUSH_UBX _ nw) = fromIntegral nw -bciStackUse PUSH_APPLY_N{} = 1 -bciStackUse PUSH_APPLY_V{} = 1 -bciStackUse PUSH_APPLY_F{} = 1 -bciStackUse PUSH_APPLY_D{} = 1 -bciStackUse PUSH_APPLY_L{} = 1 -bciStackUse PUSH_APPLY_P{} = 1 -bciStackUse PUSH_APPLY_PP{} = 1 -bciStackUse PUSH_APPLY_PPP{} = 1 -bciStackUse PUSH_APPLY_PPPP{} = 1 -bciStackUse PUSH_APPLY_PPPPP{} = 1 -bciStackUse PUSH_APPLY_PPPPPP{} = 1 +bciStackUse PUSH_APPLY_N{} = 1 +bciStackUse PUSH_APPLY_V{} = 1 +bciStackUse PUSH_APPLY_F{} = 1 +bciStackUse PUSH_APPLY_D{} = 1 +bciStackUse PUSH_APPLY_L{} = 1 +bciStackUse PUSH_APPLY_P{} = 1 +bciStackUse PUSH_APPLY_PP{} = 1 +bciStackUse PUSH_APPLY_PPP{} = 1 +bciStackUse PUSH_APPLY_PPPP{} = 1 +bciStackUse PUSH_APPLY_PPPPP{} = 1 +bciStackUse PUSH_APPLY_PPPPPP{} = 1 bciStackUse ALLOC_AP{} = 1 bciStackUse ALLOC_AP_NOUPD{} = 1 bciStackUse ALLOC_PAP{} = 1 bciStackUse (UNPACK sz) = fromIntegral sz -bciStackUse LABEL{} = 0 -bciStackUse TESTLT_I{} = 0 -bciStackUse TESTEQ_I{} = 0 -bciStackUse TESTLT_W{} = 0 -bciStackUse TESTEQ_W{} = 0 -bciStackUse TESTLT_F{} = 0 -bciStackUse TESTEQ_F{} = 0 -bciStackUse TESTLT_D{} = 0 -bciStackUse TESTEQ_D{} = 0 -bciStackUse TESTLT_P{} = 0 -bciStackUse TESTEQ_P{} = 0 -bciStackUse CASEFAIL{} = 0 -bciStackUse JMP{} = 0 -bciStackUse ENTER{} = 0 -bciStackUse RETURN{} = 0 -bciStackUse RETURN_UBX{} = 1 -bciStackUse CCALL{} = 0 -bciStackUse SWIZZLE{} = 0 -bciStackUse BRK_FUN{} = 0 +bciStackUse LABEL{} = 0 +bciStackUse TESTLT_I{} = 0 +bciStackUse TESTEQ_I{} = 0 +bciStackUse TESTLT_W{} = 0 +bciStackUse TESTEQ_W{} = 0 +bciStackUse TESTLT_F{} = 0 +bciStackUse TESTEQ_F{} = 0 +bciStackUse TESTLT_D{} = 0 +bciStackUse TESTEQ_D{} = 0 +bciStackUse TESTLT_P{} = 0 +bciStackUse TESTEQ_P{} = 0 +bciStackUse CASEFAIL{} = 0 +bciStackUse JMP{} = 0 +bciStackUse ENTER{} = 0 +bciStackUse RETURN{} = 0 +bciStackUse RETURN_UBX{} = 1 +bciStackUse CCALL{} = 0 +bciStackUse SWIZZLE{} = 0 +bciStackUse BRK_FUN{} = 0 -- These insns actually reduce stack use, but we need the high-tide level, -- so can't use this info. Not that it matters much. -bciStackUse SLIDE{} = 0 -bciStackUse MKAP{} = 0 -bciStackUse MKPAP{} = 0 -bciStackUse PACK{} = 1 -- worst case is PACK 0 words +bciStackUse SLIDE{} = 0 +bciStackUse MKAP{} = 0 +bciStackUse MKPAP{} = 0 +bciStackUse PACK{} = 1 -- worst case is PACK 0 words \end{code} diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index d508a1c5aa..cbedb717fe 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -260,13 +260,13 @@ linkFail who what -- HACKS!!! ToDo: cleaner nameToCLabel :: Name -> String{-suffix-} -> String nameToCLabel n suffix - = if pkgid /= mainPackageId + = if pkgid /= mainPackageKey then package_part ++ '_': qual_name else qual_name where - pkgid = modulePackageId mod + pkgid = modulePackageKey mod mod = ASSERT( isExternalName n ) nameModule n - package_part = zString (zEncodeFS (packageIdFS (modulePackageId mod))) + package_part = zString (zEncodeFS (packageKeyFS (modulePackageKey mod))) module_part = zString (zEncodeFS (moduleNameFS (moduleName mod))) occ_part = zString (zEncodeFS (occNameFS (nameOccName n))) qual_name = module_part ++ '_':occ_part ++ '_':suffix diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs index 67767e41b9..9ccb113314 100644 --- a/compiler/ghci/DebuggerUtils.hs +++ b/compiler/ghci/DebuggerUtils.hs @@ -46,7 +46,7 @@ dataConInfoPtrToName x = do modFS = mkFastStringByteList mod occFS = mkFastStringByteList occ occName = mkOccNameFS OccName.dataName occFS - modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS) + modName = mkModule (fsToPackageKey pkgFS) (mkModuleNameFS modFS) return (Left $ showSDoc dflags $ ppr modName <> dot <> ppr occName) `recoverM` (Right `fmap` lookupOrig modName occName) diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 162c349a8d..40b83bbbae 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -59,7 +59,6 @@ import Control.Monad import Data.IORef import Data.List -import qualified Data.Map as Map import Control.Concurrent.MVar import System.FilePath @@ -70,7 +69,7 @@ import System.Directory hiding (findFile) import System.Directory #endif -import Distribution.Package hiding (depends, PackageId) +import Distribution.Package hiding (depends, mkPackageKey, PackageKey) import Exception \end{code} @@ -124,12 +123,8 @@ data PersistentLinkerState -- The currently-loaded packages; always object code -- Held, as usual, in dependency order; though I am not sure if -- that is really important - pkgs_loaded :: ![PackageId], - - -- we need to remember the name of the last temporary DLL/.so - -- so we can link it - last_temp_so :: !(Maybe FilePath) - } + pkgs_loaded :: ![PackageKey] + } emptyPLS :: DynFlags -> PersistentLinkerState emptyPLS _ = PersistentLinkerState { @@ -137,18 +132,17 @@ emptyPLS _ = PersistentLinkerState { itbl_env = emptyNameEnv, pkgs_loaded = init_pkgs, bcos_loaded = [], - objs_loaded = [], - last_temp_so = Nothing } + objs_loaded = [] } -- Packages that don't need loading, because the compiler -- shares them with the interpreted program. -- -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details. - where init_pkgs = [rtsPackageId] + where init_pkgs = [rtsPackageKey] -extendLoadedPkgs :: [PackageId] -> IO () +extendLoadedPkgs :: [PackageKey] -> IO () extendLoadedPkgs pkgs = modifyPLS_ $ \s -> return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } @@ -320,14 +314,14 @@ reallyInitDynLinker dflags = ; if null cmdline_lib_specs then return pls else do - { pls1 <- foldM (preloadLib dflags lib_paths framework_paths) pls cmdline_lib_specs + { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs ; maybePutStr dflags "final link ... " ; ok <- resolveObjs ; if succeeded ok then maybePutStrLn dflags "done" else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed") - ; return pls1 + ; return pls }} @@ -366,21 +360,19 @@ classifyLdInput dflags f return Nothing where platform = targetPlatform dflags -preloadLib :: DynFlags -> [String] -> [String] -> PersistentLinkerState -> LibrarySpec -> IO (PersistentLinkerState) -preloadLib dflags lib_paths framework_paths pls lib_spec +preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO () +preloadLib dflags lib_paths framework_paths lib_spec = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ") case lib_spec of Object static_ish - -> do (b, pls1) <- preload_static lib_paths static_ish + -> do b <- preload_static lib_paths static_ish maybePutStrLn dflags (if b then "done" else "not found") - return pls1 Archive static_ish -> do b <- preload_static_archive lib_paths static_ish maybePutStrLn dflags (if b then "done" else "not found") - return pls DLL dll_unadorned -> do maybe_errstr <- loadDLL (mkSOName platform dll_unadorned) @@ -396,14 +388,12 @@ preloadLib dflags lib_paths framework_paths pls lib_spec case err2 of Nothing -> maybePutStrLn dflags "done" Just _ -> preloadFailed mm lib_paths lib_spec - return pls DLLPath dll_path -> do maybe_errstr <- loadDLL dll_path case maybe_errstr of Nothing -> maybePutStrLn dflags "done" Just mm -> preloadFailed mm lib_paths lib_spec - return pls Framework framework -> if platformUsesFrameworks (targetPlatform dflags) @@ -411,7 +401,6 @@ preloadLib dflags lib_paths framework_paths pls lib_spec case maybe_errstr of Nothing -> maybePutStrLn dflags "done" Just mm -> preloadFailed mm framework_paths lib_spec - return pls else panic "preloadLib Framework" where @@ -431,13 +420,11 @@ preloadLib dflags lib_paths framework_paths pls lib_spec -- Not interested in the paths in the static case. preload_static _paths name = do b <- doesFileExist name - if not b then return (False, pls) - else if dynamicGhc - then do pls1 <- dynLoadObjs dflags pls [name] - return (True, pls1) - else do loadObj name - return (True, pls) - + if not b then return False + else do if dynamicGhc + then dynLoadObjs dflags [name] + else loadObj name + return True preload_static_archive _paths name = do b <- doesFileExist name if not b then return False @@ -539,7 +526,7 @@ getLinkDeps :: HscEnv -> HomePackageTable -> Maybe FilePath -- replace object suffices? -> SrcSpan -- for error messages -> [Module] -- If you need these - -> IO ([Linkable], [PackageId]) -- ... then link these first + -> IO ([Linkable], [PackageKey]) -- ... then link these first -- Fails with an IO exception if it can't find enough files getLinkDeps hsc_env hpt pls replace_osuf span mods @@ -577,8 +564,8 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods -- tree recursively. See bug #936, testcase ghci/prog007. follow_deps :: [Module] -- modules to follow -> UniqSet ModuleName -- accum. module dependencies - -> UniqSet PackageId -- accum. package dependencies - -> IO ([ModuleName], [PackageId]) -- result + -> UniqSet PackageKey -- accum. package dependencies + -> IO ([ModuleName], [PackageKey]) -- result follow_deps [] acc_mods acc_pkgs = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs) follow_deps (mod:mods) acc_mods acc_pkgs @@ -592,7 +579,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods when (mi_boot iface) $ link_boot_mod_error mod let - pkg = modulePackageId mod + pkg = modulePackageKey mod deps = mi_deps iface pkg_deps = dep_pkgs deps @@ -804,8 +791,8 @@ dynLinkObjs dflags pls objs = do wanted_objs = map nameOfObject unlinkeds if dynamicGhc - then do pls2 <- dynLoadObjs dflags pls1 wanted_objs - return (pls2, Succeeded) + then do dynLoadObjs dflags wanted_objs + return (pls1, Succeeded) else do mapM_ loadObj wanted_objs -- Link them all together @@ -819,11 +806,9 @@ dynLinkObjs dflags pls objs = do pls2 <- unload_wkr dflags [] pls1 return (pls2, Failed) - -dynLoadObjs :: DynFlags -> PersistentLinkerState -> [FilePath] - -> IO PersistentLinkerState -dynLoadObjs _ pls [] = return pls -dynLoadObjs dflags pls objs = do +dynLoadObjs :: DynFlags -> [FilePath] -> IO () +dynLoadObjs _ [] = return () +dynLoadObjs dflags objs = do let platform = targetPlatform dflags soFile <- newTempName dflags (soExt platform) let -- When running TH for a non-dynamic way, we still need to make @@ -831,22 +816,10 @@ dynLoadObjs dflags pls objs = do -- Opt_Static off dflags1 = gopt_unset dflags Opt_Static dflags2 = dflags1 { - -- We don't want the original ldInputs in - -- (they're already linked in), but we do want - -- to link against the previous dynLoadObjs - -- library if there was one, so that the linker - -- can resolve dependencies when it loads this - -- library. - ldInputs = - case last_temp_so pls of - Nothing -> [] - Just so -> - let (lp, l) = splitFileName so in - [ Option ("-L" ++ lp) - , Option ("-Wl,-rpath") - , Option ("-Wl," ++ lp) - , Option ("-l:" ++ l) - ], + -- We don't want to link the ldInputs in; we'll + -- be calling dynLoadObjs with any objects that + -- need to be linked. + ldInputs = [], -- Even if we're e.g. profiling, we still want -- the vanilla dynamic libraries, so we set the -- ways / build tag to be just WayDyn. @@ -858,7 +831,7 @@ dynLoadObjs dflags pls objs = do consIORef (filesToNotIntermediateClean dflags) soFile m <- loadDLL soFile case m of - Nothing -> return pls { last_temp_so = Just soFile } + Nothing -> return () Just err -> panic ("Loading temp shared object failed: " ++ err) rmDupLinkables :: [Linkable] -- Already loaded @@ -1071,7 +1044,7 @@ showLS (Framework nm) = "(framework) " ++ nm -- automatically, and it doesn't matter what order you specify the input -- packages. -- -linkPackages :: DynFlags -> [PackageId] -> IO () +linkPackages :: DynFlags -> [PackageKey] -> IO () -- NOTE: in fact, since each module tracks all the packages it depends on, -- we don't really need to use the package-config dependencies. -- @@ -1087,16 +1060,13 @@ linkPackages dflags new_pkgs = do modifyPLS_ $ \pls -> do linkPackages' dflags new_pkgs pls -linkPackages' :: DynFlags -> [PackageId] -> PersistentLinkerState +linkPackages' :: DynFlags -> [PackageKey] -> PersistentLinkerState -> IO PersistentLinkerState linkPackages' dflags new_pks pls = do pkgs' <- link (pkgs_loaded pls) new_pks return $! pls { pkgs_loaded = pkgs' } where - pkg_map = pkgIdMap (pkgState dflags) - ipid_map = installedPackageIdMap (pkgState dflags) - - link :: [PackageId] -> [PackageId] -> IO [PackageId] + link :: [PackageKey] -> [PackageKey] -> IO [PackageKey] link pkgs new_pkgs = foldM link_one pkgs new_pkgs @@ -1104,17 +1074,16 @@ linkPackages' dflags new_pks pls = do | new_pkg `elem` pkgs -- Already linked = return pkgs - | Just pkg_cfg <- lookupPackage pkg_map new_pkg + | Just pkg_cfg <- lookupPackage dflags new_pkg = do { -- Link dependents first - pkgs' <- link pkgs [ Maybes.expectJust "link_one" $ - Map.lookup ipid ipid_map + pkgs' <- link pkgs [ resolveInstalledPackageId dflags ipid | ipid <- depends pkg_cfg ] -- Now link the package itself ; linkPackage dflags pkg_cfg ; return (new_pkg : pkgs') } | otherwise - = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ packageIdString new_pkg)) + = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ packageKeyString new_pkg)) linkPackage :: DynFlags -> PackageConfig -> IO () @@ -1235,7 +1204,9 @@ locateLib dflags is_hs dirs lib mk_hs_dyn_lib_path dir = dir </> mkHsSOName platform hs_dyn_lib_name so_name = mkSOName platform lib - mk_dyn_lib_path dir = dir </> so_name + mk_dyn_lib_path dir = case (arch, os) of + (ArchX86_64, OSSolaris2) -> dir </> ("64/" ++ so_name) + _ -> dir </> so_name findObject = liftM (fmap Object) $ findFile mk_obj_path dirs findDynObject = liftM (fmap Object) $ findFile mk_dyn_obj_path dirs @@ -1252,6 +1223,8 @@ locateLib dflags is_hs dirs lib Nothing -> g platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) searchForLibUsingGcc dflags so dirs = do diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index a2f9af92f1..dde813d31d 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -7,14 +7,6 @@ -- Pepe Iborra (supported by Google SoC) 2006 -- ----------------------------------------------------------------------------- - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module RtClosureInspect( cvObtainTerm, -- :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term cvReconstructType, @@ -85,9 +77,9 @@ import System.IO.Unsafe data Term = Term { ty :: RttiType , dc :: Either String DataCon -- Carries a text representation if the datacon is - -- not exported by the .hi file, which is the case + -- not exported by the .hi file, which is the case -- for private constructors in -O0 compiled libraries - , val :: HValue + , val :: HValue , subTerms :: [Term] } | Prim { ty :: RttiType @@ -142,20 +134,20 @@ instance Outputable (Term) where ------------------------------------------------------------------------- -- Runtime Closure Datatype and functions for retrieving closure related stuff ------------------------------------------------------------------------- -data ClosureType = Constr - | Fun - | Thunk Int +data ClosureType = Constr + | Fun + | Thunk Int | ThunkSelector - | Blackhole - | AP - | PAP - | Indirection Int + | Blackhole + | AP + | PAP + | Indirection Int | MutVar Int | MVar Int | Other Int deriving (Show, Eq) -data Closure = Closure { tipe :: ClosureType +data Closure = Closure { tipe :: ClosureType , infoPtr :: Ptr () , infoTable :: StgInfoTable , ptrs :: Array Int HValue @@ -163,7 +155,7 @@ data Closure = Closure { tipe :: ClosureType } instance Outputable ClosureType where - ppr = text . show + ppr = text . show #include "../includes/rts/storage/ClosureTypes.h" @@ -175,7 +167,7 @@ pAP_CODE = PAP getClosureData :: DynFlags -> a -> IO Closure getClosureData dflags a = - case unpackClosure# a of + case unpackClosure# a of (# iptr, ptrs, nptrs #) -> do let iptr' | ghciTablesNextToCode = @@ -194,11 +186,11 @@ getClosureData dflags a = nptrs_data = [W# (indexWordArray# nptrs i) | I# i <- [0.. fromIntegral (BCI.nptrs itbl)-1] ] ASSERT(elems >= 0) return () - ptrsList `seq` + ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data) readCType :: Integral a => a -> ClosureType -readCType i +readCType i | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr | i >= FUN && i <= FUN_STATIC = Fun | i >= THUNK && i < THUNK_SELECTOR = Thunk i' @@ -212,7 +204,7 @@ readCType i | i == MVAR_CLEAN || i == MVAR_DIRTY = MVar i' | otherwise = Other i' where i' = fromIntegral i - + isConstr, isIndirection, isThunk :: ClosureType -> Bool isConstr Constr = True isConstr _ = False @@ -240,7 +232,7 @@ unsafeDeepSeq :: a -> b -> b unsafeDeepSeq = unsafeDeepSeq1 2 where unsafeDeepSeq1 0 a b = seq a $! b unsafeDeepSeq1 i a b -- 1st case avoids infinite loops for non reducible thunks - | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b + | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b -- | unsafePerformIO (isFullyEvaluated a) = b | otherwise = case unsafePerformIO (getClosureData a) of closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure) @@ -315,7 +307,7 @@ mapTermTypeM f = foldTermM TermFoldM { termTyVars :: Term -> TyVarSet termTyVars = foldTerm TermFold { - fTerm = \ty _ _ tt -> + fTerm = \ty _ _ tt -> tyVarsOfType ty `plusVarEnv` concatVarEnv tt, fSuspension = \_ ty _ _ -> tyVarsOfType ty, fPrim = \ _ _ -> emptyVarEnv, @@ -347,21 +339,21 @@ ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do tt_docs <- mapM (y app_prec) tt return $ cparen (not (null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs) - -ppr_termM y p Term{dc=Right dc, subTerms=tt} + +ppr_termM y p Term{dc=Right dc, subTerms=tt} {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity - = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2) - <+> hsep (map (ppr_term1 True) tt) + = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2) + <+> hsep (map (ppr_term1 True) tt) -} -- TODO Printing infix constructors properly | null sub_terms_to_show = return (ppr dc) - | otherwise + | otherwise = do { tt_docs <- mapM (y app_prec) sub_terms_to_show ; return $ cparen (p >= app_prec) $ sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] } where - sub_terms_to_show -- Don't show the dictionary arguments to - -- constructors unless -dppr-debug is on + sub_terms_to_show -- Don't show the dictionary arguments to + -- constructors unless -dppr-debug is on | opt_PprStyle_Debug = tt | otherwise = dropList (dataConTheta dc) tt @@ -378,9 +370,9 @@ ppr_termM _ _ t = ppr_termM1 t ppr_termM1 :: Monad m => Term -> m SDoc -ppr_termM1 Prim{value=words, ty=ty} = +ppr_termM1 Prim{value=words, ty=ty} = return $ repPrim (tyConAppTyCon ty) words -ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = +ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = return (char '_' <+> ifPprDebug (text "::" <> ppr ty)) ppr_termM1 Suspension{ty=ty, bound_to=Just n} -- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>") @@ -392,7 +384,7 @@ ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap" pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t} | Just (tc,_) <- tcSplitTyConApp_maybe ty , ASSERT(isNewTyCon tc) True - , Just new_dc <- tyConSingleDataCon_maybe tc = do + , Just new_dc <- tyConSingleDataCon_maybe tc = do real_term <- y max_prec t return $ cparen (p >= app_prec) (ppr new_dc <+> real_term) pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap" @@ -401,11 +393,11 @@ pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap" -- Custom Term Pretty Printers ------------------------------------------------------- --- We can want to customize the representation of a --- term depending on its type. +-- We can want to customize the representation of a +-- term depending on its type. -- However, note that custom printers have to work with -- type representations, instead of directly with types. --- We cannot use type classes here, unless we employ some +-- We cannot use type classes here, unless we employ some -- typerep trickery (e.g. Weirich's RepLib tricks), -- which I didn't. Therefore, this code replicates a lot -- of what type classes provide for free. @@ -413,7 +405,7 @@ pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap" type CustomTermPrinter m = TermPrinterM m -> [Precedence -> Term -> (m (Maybe SDoc))] --- | Takes a list of custom printers with a explicit recursion knot and a term, +-- | Takes a list of custom printers with a explicit recursion knot and a term, -- and returns the output of the first successful printer, or the default printer cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc cPprTerm printers_ = go 0 where @@ -430,7 +422,7 @@ cPprTerm printers_ = go 0 where -- Default set of custom printers. Note that the recursion knot is explicit cPprTermBase :: forall m. Monad m => CustomTermPrinter m cPprTermBase y = - [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma) + [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma) . mapM (y (-1)) . subTerms) , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2) @@ -441,7 +433,7 @@ cPprTermBase y = , ifTerm (isTyCon doubleTyCon . ty) ppr_double , ifTerm (isIntegerTy . ty) ppr_integer ] - where + where ifTerm :: (Term -> Bool) -> (Precedence -> Term -> m SDoc) -> Precedence -> Term -> m (Maybe SDoc) @@ -449,11 +441,11 @@ cPprTermBase y = | pred t = Just `liftM` f prec t ifTerm _ _ _ _ = return Nothing - isTupleTy ty = fromMaybe False $ do - (tc,_) <- tcSplitTyConApp_maybe ty + isTupleTy ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty return (isBoxedTupleTyCon tc) - isTyCon a_tc ty = fromMaybe False $ do + isTyCon a_tc ty = fromMaybe False $ do (tc,_) <- tcSplitTyConApp_maybe ty return (a_tc == tc) @@ -461,7 +453,7 @@ cPprTermBase y = (tc,_) <- tcSplitTyConApp_maybe ty return (tyConName tc == integerTyConName) - ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer + ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer :: Precedence -> Term -> m SDoc ppr_int _ v = return (Ppr.int (unsafeCoerce# (val v))) ppr_char _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'') @@ -474,16 +466,16 @@ cPprTermBase y = ppr_list p (Term{subTerms=[h,t]}) = do let elems = h : getListTerms t isConsLast = not(termType(last elems) `eqType` termType h) - is_string = all (isCharTy . ty) elems + is_string = all (isCharTy . ty) elems print_elems <- mapM (y cons_prec) elems if is_string then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems)))) else if isConsLast - then return $ cparen (p >= cons_prec) - $ pprDeeperList fsep + then return $ cparen (p >= cons_prec) + $ pprDeeperList fsep $ punctuate (space<>colon) print_elems - else return $ brackets + else return $ brackets $ pprDeeperList fcat $ punctuate comma print_elems @@ -524,9 +516,9 @@ repPrim t = rep where | t == mVarPrimTyCon = text "<mVar>" | t == tVarPrimTyCon = text "<tVar>" | otherwise = char '<' <> ppr t <> char '>' - where build ww = unsafePerformIO $ withArray ww (peek . castPtr) --- This ^^^ relies on the representation of Haskell heap values being --- the same as in a C array. + where build ww = unsafePerformIO $ withArray ww (peek . castPtr) +-- This ^^^ relies on the representation of Haskell heap values being +-- the same as in a C array. ----------------------------------- -- Type Reconstruction @@ -537,14 +529,14 @@ The algorithm walks the heap generating a set of equations, which are solved with syntactic unification. A type reconstruction equation looks like: - <datacon reptype> = <actual heap contents> + <datacon reptype> = <actual heap contents> The full equation set is generated by traversing all the subterms, starting from a given term. The only difficult part is that newtypes are only found in the lhs of equations. -Right hand sides are missing them. We can either (a) drop them from the lhs, or -(b) reconstruct them in the rhs when possible. +Right hand sides are missing them. We can either (a) drop them from the lhs, or +(b) reconstruct them in the rhs when possible. The function congruenceNewtypes takes a shot at (b) -} @@ -574,7 +566,7 @@ runTR hsc_env thing = do runTR_maybe :: HscEnv -> TR a -> IO (Maybe a) runTR_maybe hsc_env thing_inside - = do { (_errs, res) <- initTc hsc_env HsSrcFile False + = do { (_errs, res) <- initTc hsc_env HsSrcFile False (icInteractiveModule (hsc_IC hsc_env)) thing_inside ; return res } @@ -583,17 +575,17 @@ traceTR :: SDoc -> TR () traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti --- Semantically different to recoverM in TcRnMonad +-- Semantically different to recoverM in TcRnMonad -- recoverM retains the errors in the first action, -- whereas recoverTc here does not recoverTR :: TR a -> TR a -> TR a -recoverTR recover thing = do +recoverTR recover thing = do (_,mb_res) <- tryTcErrs thing - case mb_res of + case mb_res of Nothing -> recover Just res -> return res -trIO :: IO a -> TR a +trIO :: IO a -> TR a trIO = liftTcM . liftIO liftTcM :: TcM a -> TR a @@ -608,17 +600,17 @@ instTyVars :: [TyVar] -> TR ([TcTyVar], [TcType], TvSubst) instTyVars = liftTcM . tcInstTyVars type RttiInstantiation = [(TcTyVar, TyVar)] - -- Associates the typechecker-world meta type variables - -- (which are mutable and may be refined), to their + -- Associates the typechecker-world meta type variables + -- (which are mutable and may be refined), to their -- debugger-world RuntimeUnk counterparts. -- If the TcTyVar has not been refined by the runtime type -- elaboration, then we want to turn it back into the -- original RuntimeUnk --- | Returns the instantiated type scheme ty', and the +-- | Returns the instantiated type scheme ty', and the -- mapping from new (instantiated) -to- old (skolem) type variables instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation) -instScheme (tvs, ty) +instScheme (tvs, ty) = liftTcM $ do { (tvs', _, subst) <- tcInstTyVars tvs ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs] ; return (substTy subst ty, rtti_inst) } @@ -698,7 +690,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do text "Term obtained: " <> ppr term $$ text "Type obtained: " <> ppr (termType term)) return term - where + where dflags = hsc_dflags hsc_env go :: Int -> Type -> Type -> HValue -> TcM Term @@ -715,7 +707,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do clos <- trIO $ getClosureData dflags a return (Suspension (tipe clos) my_ty a Nothing) go max_depth my_ty old_ty a = do - let monomorphic = not(isTyVarTy my_ty) + let monomorphic = not(isTyVarTy my_ty) -- This ^^^ is a convention. The ancestor tests for -- monomorphism and passes a type instead of a tv clos <- trIO $ getClosureData dflags a @@ -735,14 +727,14 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do MutVar _ | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty -> do -- Deal with the MutVar# primitive - -- It does not have a constructor at all, + -- It does not have a constructor at all, -- so we simulate the following one -- MutVar# :: contents_ty -> MutVar# s contents_ty traceTR (text "Following a MutVar") contents_tv <- newVar liftedTypeKind contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w ASSERT(isUnliftedTypeKind $ typeKind my_ty) return () - (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy + (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy contents_ty (mkTyConApp tycon [world,contents_ty]) addConstraint (mkFunTy contents_tv my_ty) mutvar_ty x <- go (pred max_depth) contents_tv contents_ty contents @@ -762,12 +754,12 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do -- In such case, we return a best approximation: -- ignore the unpointed args, and recover the pointeds -- This preserves laziness, and should be safe. - traceTR (text "Not constructor" <+> ppr dcname) + traceTR (text "Not constructor" <+> ppr dcname) let dflags = hsc_dflags hsc_env tag = showPpr dflags dcname - vars <- replicateM (length$ elems$ ptrs clos) + vars <- replicateM (length$ elems$ ptrs clos) (newVar liftedTypeKind) - subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i + subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i | (i, tv) <- zip [0..] vars] return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms) Just dc -> do @@ -875,7 +867,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <> int max_depth <> text " steps") search stop expand l d = - case viewl l of + case viewl l of EmptyL -> return () x :< xx -> unlessM stop $ do new <- expand x @@ -921,7 +913,7 @@ findPtrTys i ty | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty , isUnboxedTupleTyCon tc = findPtrTyss i elem_tys - + | otherwise = case repType ty of UnaryRep rep_ty | typePrimRep rep_ty == PtrRep -> return (i + 1, [(i, ty)]) @@ -954,7 +946,7 @@ getDataConArgTys :: DataCon -> Type -> TR [Type] -- I believe that con_app_ty should not have any enclosing foralls getDataConArgTys dc con_app_ty = do { let UnaryRep rep_con_app_ty = repType con_app_ty - ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty + ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty))) ; (_, _, subst) <- instTyVars (univ_tvs ++ ex_tvs) ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc)) @@ -975,7 +967,7 @@ Consider a GADT (cf Trac #7386) ... In getDataConArgTys -* con_app_ty is the known type (from outside) of the constructor application, +* con_app_ty is the known type (from outside) of the constructor application, say D [Int] Int * The data constructor MkT has a (representation) dataConTyCon = DList, @@ -984,7 +976,7 @@ In getDataConArgTys MkT :: a -> DList a (Maybe a) ... -So the dataConTyCon of the data constructor, DList, differs from +So the dataConTyCon of the data constructor, DList, differs from the "outside" type, D. So we can't straightforwardly decompose the "outside" type, and we end up in the "_" branch of the case. @@ -1126,9 +1118,9 @@ check2 (_, rtti_ty) (_, old_ty) -- Dealing with newtypes -------------------------- {- - congruenceNewtypes does a parallel fold over two Type values, - compensating for missing newtypes on both sides. - This is necessary because newtypes are not present + congruenceNewtypes does a parallel fold over two Type values, + compensating for missing newtypes on both sides. + This is necessary because newtypes are not present in runtime, but sometimes there is evidence available. Evidence can come from DataCon signatures or from compile-time type inference. @@ -1174,8 +1166,8 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') return (mkFunTy r1' r2') -- TyconApp Inductive case; this is the interesting bit. | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs - , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs - , tycon_l /= tycon_r + , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs + , tycon_l /= tycon_r = upgrade tycon_l r | otherwise = return r @@ -1185,7 +1177,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') | not (isNewTyCon new_tycon) = do traceTR (text "(Upgrade) Not matching newtype evidence: " <> ppr new_tycon <> text " for " <> ppr ty) - return ty + return ty | otherwise = do traceTR (text "(Upgrade) upgraded " <> ppr ty <> text " in presence of newtype evidence " <> ppr new_tycon) @@ -1193,7 +1185,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') let ty' = mkTyConApp new_tycon vars UnaryRep rep_ty = repType ty' _ <- liftTcM (unifyType ty rep_ty) - -- assumes that reptype doesn't ^^^^ touch tyconApp args + -- assumes that reptype doesn't ^^^^ touch tyconApp args return ty' @@ -1205,7 +1197,7 @@ zonkTerm = foldTermM (TermFoldM return (Suspension ct ty v b) , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' -> return$ NewtypeWrap ty' dc t - , fRefWrapM = \ty t -> return RefWrap `ap` + , fRefWrapM = \ty t -> return RefWrap `ap` zonkRttiType ty `ap` return t , fPrimM = (return.) . Prim }) @@ -1214,13 +1206,13 @@ zonkRttiType :: TcType -> TcM Type -- by skolems, safely out of Meta-tyvar-land zonkRttiType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_meta) where - zonk_unbound_meta tv + zonk_unbound_meta tv = ASSERT( isTcTyVar tv ) do { tv' <- skolemiseUnboundMetaTyVar tv RuntimeUnk - -- This is where RuntimeUnks are born: - -- otherwise-unconstrained unification variables are - -- turned into RuntimeUnks as they leave the - -- typechecker's monad + -- This is where RuntimeUnks are born: + -- otherwise-unconstrained unification variables are + -- turned into RuntimeUnks as they leave the + -- typechecker's monad ; return (mkTyVarTy tv') } -------------------------------------------------------------------------------- diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 6862901437..d722a402e0 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -201,13 +201,20 @@ cvtDec (ClassD ctxt cl tvs fds decs) ; unless (null adts') (failWith $ (ptext (sLit "Default data instance declarations are not allowed:")) $$ (Outputable.ppr adts')) + ; at_defs <- mapM cvt_at_def ats' ; returnL $ TyClD $ ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds' - , tcdATs = fams', tcdATDefs = ats', tcdDocs = [] + , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = [] , tcdFVs = placeHolderNames } -- no docs in TH ^^ } + where + cvt_at_def :: LTyFamInstDecl RdrName -> CvtM (LTyFamDefltEqn RdrName) + -- Very similar to what happens in RdrHsSyn.mkClassDecl + cvt_at_def decl = case RdrHsSyn.mkATDefault decl of + Right def -> return def + Left (_, msg) -> failWith msg cvtDec (InstanceD ctxt ty decs) = do { let doc = ptext (sLit "an instance declaration") @@ -216,7 +223,7 @@ cvtDec (InstanceD ctxt ty decs) ; ctxt' <- cvtContext ctxt ; L loc ty' <- cvtType ty ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty' - ; returnL $ InstD (ClsInstD (ClsInstDecl inst_ty' binds' sigs' ats' adts')) } + ; returnL $ InstD (ClsInstD (ClsInstDecl inst_ty' binds' sigs' ats' adts' Nothing)) } cvtDec (ForeignD ford) = do { ford' <- cvtForD ford @@ -280,9 +287,9 @@ cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName) cvtTySynEqn tc (TySynEqn lhs rhs) = do { lhs' <- mapM cvtType lhs ; rhs' <- cvtType rhs - ; returnL $ TyFamInstEqn { tfie_tycon = tc - , tfie_pats = mkHsWithBndrs lhs' - , tfie_rhs = rhs' } } + ; returnL $ TyFamEqn { tfe_tycon = tc + , tfe_pats = mkHsWithBndrs lhs' + , tfe_rhs = rhs' } } ---------------- cvt_ci_decs :: MsgDoc -> [TH.Dec] @@ -1143,8 +1150,8 @@ mk_ghc_ns TH.VarName = OccName.varName mk_mod :: TH.ModName -> ModuleName mk_mod mod = mkModuleName (TH.modString mod) -mk_pkg :: TH.PkgName -> PackageId -mk_pkg pkg = stringToPackageId (TH.pkgString pkg) +mk_pkg :: TH.PkgName -> PackageKey +mk_pkg pkg = stringToPackageKey (TH.pkgString pkg) mk_uniq :: Int# -> Unique mk_uniq u = mkUniqueGrimily (I# u) diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 2261a89741..04a72225f1 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -166,13 +166,7 @@ data HsBindLR idL idR abs_binds :: LHsBinds idL -- ^ Typechecked user bindings } - | PatSynBind { - patsyn_id :: Located idL, -- ^ Name of the pattern synonym - bind_fvs :: NameSet, -- ^ See Note [Bind free vars] - patsyn_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names - patsyn_def :: LPat idR, -- ^ Right-hand side - patsyn_dir :: HsPatSynDir idR -- ^ Directionality - } + | PatSynBind (PatSynBind idL idR) deriving (Data, Typeable) -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] @@ -195,6 +189,14 @@ data ABExport id , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas } deriving (Data, Typeable) +data PatSynBind idL idR + = PSB { psb_id :: Located idL, -- ^ Name of the pattern synonym + psb_fvs :: NameSet, -- ^ See Note [Bind free vars] + psb_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names + psb_def :: LPat idR, -- ^ Right-hand side + psb_dir :: HsPatSynDir idR -- ^ Directionality + } deriving (Data, Typeable) + -- | Used for the NameSet in FunBind and PatBind prior to the renamer placeHolderNames :: NameSet placeHolderNames = panic "placeHolderNames" @@ -437,20 +439,7 @@ ppr_monobind (FunBind { fun_id = fun, fun_infix = inf, $$ ifPprDebug (pprBndr LetBind (unLoc fun)) $$ pprFunBind (unLoc fun) inf matches $$ ifPprDebug (ppr wrap) -ppr_monobind (PatSynBind{ patsyn_id = L _ psyn, patsyn_args = details, - patsyn_def = pat, patsyn_dir = dir }) - = ppr_lhs <+> ppr_rhs - where - ppr_lhs = ptext (sLit "pattern") <+> ppr_details details - ppr_simple syntax = syntax <+> ppr pat - - ppr_details (InfixPatSyn v1 v2) = hsep [ppr v1, pprInfixOcc psyn, ppr v2] - ppr_details (PrefixPatSyn vs) = hsep (pprPrefixOcc psyn : map ppr vs) - - ppr_rhs = case dir of - Unidirectional -> ppr_simple (ptext (sLit "<-")) - ImplicitBidirectional -> ppr_simple equals - +ppr_monobind (PatSynBind psb) = ppr psb ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars , abs_exports = exports, abs_binds = val_binds , abs_ev_binds = ev_binds }) @@ -467,6 +456,23 @@ instance (OutputableBndr id) => Outputable (ABExport id) where = vcat [ ppr gbl <+> ptext (sLit "<=") <+> ppr lcl , nest 2 (pprTcSpecPrags prags) , nest 2 (ppr wrap)] + +instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL idR) where + ppr (PSB{ psb_id = L _ psyn, psb_args = details, psb_def = pat, psb_dir = dir }) + = ppr_lhs <+> ppr_rhs + where + ppr_lhs = ptext (sLit "pattern") <+> ppr_details + ppr_simple syntax = syntax <+> ppr pat + + (is_infix, ppr_details) = case details of + InfixPatSyn v1 v2 -> (True, hsep [ppr v1, pprInfixOcc psyn, ppr v2]) + PrefixPatSyn vs -> (False, hsep (pprPrefixOcc psyn : map ppr vs)) + + ppr_rhs = case dir of + Unidirectional -> ppr_simple (ptext (sLit "<-")) + ImplicitBidirectional -> ppr_simple equals + ExplicitBidirectional mg -> ppr_simple (ptext (sLit "<-")) <+> ptext (sLit "where") $$ + (nest 2 $ pprFunBind psyn is_infix mg) \end{code} @@ -785,10 +791,9 @@ instance Traversable HsPatSynDetails where traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args -data HsPatSynDirLR idL idR +data HsPatSynDir id = Unidirectional | ImplicitBidirectional + | ExplicitBidirectional (MatchGroup id (LHsExpr id)) deriving (Data, Typeable) - -type HsPatSynDir id = HsPatSynDirLR id id \end{code} diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index c4174db776..313dccccd5 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -29,7 +29,7 @@ module HsDecls ( InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..), TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts, DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, - TyFamInstEqn(..), LTyFamInstEqn, + TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn, LClsInstDecl, ClsInstDecl(..), -- ** Standalone deriving declarations @@ -472,7 +472,7 @@ data TyClDecl name tcdSigs :: [LSig name], -- ^ Methods' signatures tcdMeths :: LHsBinds name, -- ^ Default methods tcdATs :: [LFamilyDecl name], -- ^ Associated types; ie - tcdATDefs :: [LTyFamInstDecl name], -- ^ Associated type defaults + tcdATDefs :: [LTyFamDefltEqn name], -- ^ Associated type defaults tcdDocs :: [LDocDecl], -- ^ Haddock docs tcdFVs :: NameSet } @@ -573,7 +573,7 @@ tyFamInstDeclName = unLoc . tyFamInstDeclLName tyFamInstDeclLName :: OutputableBndr name => TyFamInstDecl name -> Located name tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = - (L _ (TyFamInstEqn { tfie_tycon = ln })) }) + (L _ (TyFamEqn { tfe_tycon = ln })) }) = ln tyClDeclLName :: TyClDecl name -> Located name @@ -632,7 +632,7 @@ instance OutputableBndr name | otherwise -- Laid out = vcat [ top_matter <+> ptext (sLit "where") , nest 2 $ pprDeclList (map ppr ats ++ - map ppr at_defs ++ + map ppr_fam_deflt_eqn at_defs ++ pprLHsBindsForUser methods sigs) ] where top_matter = ptext (sLit "class") @@ -657,7 +657,7 @@ instance (OutputableBndr name) => Outputable (FamilyDecl name) where ClosedTypeFamily eqns -> ( ptext (sLit "where") , if null eqns then ptext (sLit "..") - else vcat $ map ppr eqns ) + else vcat $ map ppr_fam_inst_eqn eqns ) _ -> (empty, empty) pprFlavour :: FamilyInfo name -> SDoc @@ -678,7 +678,7 @@ pp_vanilla_decl_head thing tyvars context pp_fam_inst_lhs :: OutputableBndr name => Located name - -> HsWithBndrs [LHsType name] + -> HsTyPats name -> HsContext name -> SDoc pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patterns @@ -686,12 +686,13 @@ pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patt , hsep (map (pprParendHsType.unLoc) typats)] pprTyClDeclFlavour :: TyClDecl a -> SDoc -pprTyClDeclFlavour (ClassDecl {}) = ptext (sLit "class") -pprTyClDeclFlavour (FamDecl {}) = ptext (sLit "family") -pprTyClDeclFlavour (SynDecl {}) = ptext (sLit "type") -pprTyClDeclFlavour (DataDecl { tcdDataDefn = (HsDataDefn { dd_ND = nd }) }) - = ppr nd +pprTyClDeclFlavour (ClassDecl {}) = ptext (sLit "class") +pprTyClDeclFlavour (SynDecl {}) = ptext (sLit "type") pprTyClDeclFlavour (ForeignType {}) = ptext (sLit "foreign type") +pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) + = pprFlavour info +pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) + = ppr nd \end{code} %************************************************************************ @@ -893,25 +894,49 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT { %* * %************************************************************************ +Note [Type family instance declarations in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The data type TyFamEqn represents one equation of a type family instance. +It is parameterised over its tfe_pats field: + + * An ordinary type family instance declaration looks like this in source Haskell + type instance T [a] Int = a -> a + (or something similar for a closed family) + It is represented by a TyFamInstEqn, with *type* in the tfe_pats field. + + * On the other hand, the *default instance* of an associated type looksl like + this in source Haskell + class C a where + type T a b + type T a b = a -> b -- The default instance + It is represented by a TyFamDefltEqn, with *type variables8 in the tfe_pats field. + \begin{code} ----------------- Type synonym family instances ------------- +type LTyFamInstEqn name = Located (TyFamInstEqn name) +type LTyFamDefltEqn name = Located (TyFamDefltEqn name) -type LTyFamInstEqn name = Located (TyFamInstEqn name) - --- | One equation in a type family instance declaration -data TyFamInstEqn name - = TyFamInstEqn - { tfie_tycon :: Located name - , tfie_pats :: HsWithBndrs [LHsType name] +type HsTyPats name = HsWithBndrs [LHsType name] -- ^ Type patterns (with kind and type bndrs) -- See Note [Family instance declaration binders] - , tfie_rhs :: LHsType name } + +type TyFamInstEqn name = TyFamEqn name (HsTyPats name) +type TyFamDefltEqn name = TyFamEqn name (LHsTyVarBndrs name) + -- See Note [Type family instance declarations in HsSyn] + +-- | One equation in a type family instance declaration +-- See Note [Type family instance declarations in HsSyn] +data TyFamEqn name pats + = TyFamEqn + { tfe_tycon :: Located name + , tfe_pats :: pats + , tfe_rhs :: LHsType name } deriving( Typeable, Data ) type LTyFamInstDecl name = Located (TyFamInstDecl name) -data TyFamInstDecl name +data TyFamInstDecl name = TyFamInstDecl - { tfid_eqn :: LTyFamInstEqn name + { tfid_eqn :: LTyFamInstEqn name , tfid_fvs :: NameSet } deriving( Typeable, Data ) @@ -921,11 +946,9 @@ type LDataFamInstDecl name = Located (DataFamInstDecl name) data DataFamInstDecl name = DataFamInstDecl { dfid_tycon :: Located name - , dfid_pats :: HsWithBndrs [LHsType name] -- lhs - -- ^ Type patterns (with kind and type bndrs) - -- See Note [Family instance declaration binders] - , dfid_defn :: HsDataDefn name -- rhs - , dfid_fvs :: NameSet } -- free vars for dependency analysis + , dfid_pats :: HsTyPats name -- LHS + , dfid_defn :: HsDataDefn name -- RHS + , dfid_fvs :: NameSet } -- Rree vars for dependency analysis deriving( Typeable, Data ) @@ -937,10 +960,11 @@ data ClsInstDecl name { cid_poly_ty :: LHsType name -- Context => Class Instance-type -- Using a polytype means that the renamer conveniently -- figures out the quantified type variables for us. - , cid_binds :: LHsBinds name - , cid_sigs :: [LSig name] -- User-supplied pragmatic info - , cid_tyfam_insts :: [LTyFamInstDecl name] -- type family instances - , cid_datafam_insts :: [LDataFamInstDecl name] -- data family instances + , cid_binds :: LHsBinds name -- Class methods + , cid_sigs :: [LSig name] -- User-supplied pragmatic info + , cid_tyfam_insts :: [LTyFamInstDecl name] -- Type family instances + , cid_datafam_insts :: [LDataFamInstDecl name] -- Data family instances + , cid_overlap_mode :: Maybe OverlapMode } deriving (Data, Typeable) @@ -983,17 +1007,23 @@ instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where pprTyFamInstDecl :: OutputableBndr name => TopLevelFlag -> TyFamInstDecl name -> SDoc pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) - = ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> (ppr eqn) + = ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn ppr_instance_keyword :: TopLevelFlag -> SDoc ppr_instance_keyword TopLevel = ptext (sLit "instance") ppr_instance_keyword NotTopLevel = empty -instance (OutputableBndr name) => Outputable (TyFamInstEqn name) where - ppr (TyFamInstEqn { tfie_tycon = tycon - , tfie_pats = pats - , tfie_rhs = rhs }) - = (pp_fam_inst_lhs tycon pats []) <+> equals <+> (ppr rhs) +ppr_fam_inst_eqn :: OutputableBndr name => LTyFamInstEqn name -> SDoc +ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon + , tfe_pats = pats + , tfe_rhs = rhs })) + = pp_fam_inst_lhs tycon pats [] <+> equals <+> ppr rhs + +ppr_fam_deflt_eqn :: OutputableBndr name => LTyFamDefltEqn name -> SDoc +ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon + , tfe_pats = tvs + , tfe_rhs = rhs })) + = pp_vanilla_decl_head tycon tvs [] <+> equals <+> ppr rhs instance (OutputableBndr name) => Outputable (DataFamInstDecl name) where ppr = pprDataFamInstDecl TopLevel @@ -1013,6 +1043,7 @@ pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) instance (OutputableBndr name) => Outputable (ClsInstDecl name) where ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_overlap_mode = mbOverlap , cid_datafam_insts = adts }) | null sigs, null ats, null adts, isEmptyBag binds -- No "where" part = top_matter @@ -1024,7 +1055,21 @@ instance (OutputableBndr name) => Outputable (ClsInstDecl name) where map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++ pprLHsBindsForUser binds sigs ] where - top_matter = ptext (sLit "instance") <+> ppr inst_ty + top_matter = ptext (sLit "instance") <+> ppOverlapPragma mbOverlap + <+> ppr inst_ty + +ppOverlapPragma :: Maybe OverlapMode -> SDoc +ppOverlapPragma mb = + case mb of + Nothing -> empty + Just NoOverlap -> ptext (sLit "{-# NO_OVERLAP #-}") + Just Overlappable -> ptext (sLit "{-# OVERLAPPABLE #-}") + Just Overlapping -> ptext (sLit "{-# OVERLAPPING #-}") + Just Overlaps -> ptext (sLit "{-# OVERLAPS #-}") + Just Incoherent -> ptext (sLit "{-# INCOHERENT #-}") + + + instance (OutputableBndr name) => Outputable (InstDecl name) where ppr (ClsInstD { cid_inst = decl }) = ppr decl @@ -1052,12 +1097,14 @@ instDeclDataFamInsts inst_decls \begin{code} type LDerivDecl name = Located (DerivDecl name) -data DerivDecl name = DerivDecl { deriv_type :: LHsType name } +data DerivDecl name = DerivDecl { deriv_type :: LHsType name + , deriv_overlap_mode :: Maybe OverlapMode + } deriving (Data, Typeable) instance (OutputableBndr name) => Outputable (DerivDecl name) where - ppr (DerivDecl ty) - = hsep [ptext (sLit "deriving instance"), ppr ty] + ppr (DerivDecl ty o) + = hsep [ptext (sLit "deriving instance"), ppOverlapPragma o, ppr ty] \end{code} %************************************************************************ diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index aa7923f444..69b6df64ec 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -79,8 +79,6 @@ noSyntaxExpr = HsLit (HsString (fsLit "noSyntaxExpr")) type CmdSyntaxTable id = [(Name, SyntaxExpr id)] -- See Note [CmdSyntaxTable] -noSyntaxTable :: CmdSyntaxTable id -noSyntaxTable = [] \end{code} Note [CmdSyntaxtable] @@ -88,7 +86,7 @@ Note [CmdSyntaxtable] Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps track of the methods needed for a Cmd. -* Before the renamer, this list is 'noSyntaxTable' +* Before the renamer, this list is an empty list * After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ For example, for the 'arr' method diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index ae7866cf03..5d4d22fae2 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -1,10 +1,12 @@ +> {-# LANGUAGE ScopedTypeVariables #-} + % % (c) The University of Glasgow, 1992-2006 % Here we collect a variety of helper functions that construct or analyse HsSyn. All these functions deal with generic HsSyn; functions -which deal with the intantiated versions are located elsewhere: +which deal with the instantiated versions are located elsewhere: Parameterised by Module ---------------- ------------- @@ -100,7 +102,10 @@ import FastString import Util import Bag import Outputable + import Data.Either +import Data.Function +import Data.List \end{code} @@ -500,11 +505,13 @@ mkVarBind var rhs = L (getLoc rhs) $ VarBind { var_id = var, var_rhs = rhs, var_inline = False } mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName -mkPatSynBind name details lpat dir = PatSynBind{ patsyn_id = name - , patsyn_args = details - , patsyn_def = lpat - , patsyn_dir = dir - , bind_fvs = placeHolderNames } +mkPatSynBind name details lpat dir = PatSynBind psb + where + psb = PSB{ psb_id = name + , psb_args = details + , psb_def = lpat + , psb_dir = dir + , psb_fvs = placeHolderNames } ------------ mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] @@ -572,7 +579,7 @@ collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc -- I don't think we want the binders from the nested binds -- The only time we collect binders from a typechecked -- binding (hence see AbsBinds) is in zonking in TcHsSyn -collect_bind (PatSynBind { patsyn_id = L _ ps }) acc = ps : acc +collect_bind (PatSynBind (PSB { psb_id = L _ ps })) acc = ps : acc collectHsBindsBinders :: LHsBindsLR idL idR -> [idL] collectHsBindsBinders binds = collect_binds binds [] @@ -743,24 +750,26 @@ hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons -- See Note [Binders in family instances] ------------------- -hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name] +hsConDeclsBinders :: forall name. (Eq name) => [LConDecl name] -> [Located name] -- See hsLTyClDeclBinders for what this does -- The function is boringly complicated because of the records -- And since we only have equality, we have to be a little careful -hsConDeclsBinders cons - = snd (foldl do_one ([], []) cons) - where - do_one (flds_seen, acc) (L loc (ConDecl { con_name = L _ name - , con_details = RecCon flds })) - = (map unLoc new_flds ++ flds_seen, L loc name : new_flds ++ acc) - where +hsConDeclsBinders cons = go id cons + where go :: ([Located name] -> [Located name]) -> [LConDecl name] -> [Located name] + go _ [] = [] + go remSeen (r:rs) = -- don't re-mangle the location of field names, because we don't -- have a record of the full location of the field declaration anyway - new_flds = filterOut (\f -> unLoc f `elem` flds_seen) - (map cd_fld_name flds) + case r of + -- remove only the first occurrence of any seen field in order to + -- avoid circumventing detection of duplicate fields (#9156) + L loc (ConDecl { con_name = L _ name , con_details = RecCon flds }) -> + (L loc name) : r' ++ go remSeen' rs + where r' = remSeen (map cd_fld_name flds) + remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc) v | v <- r'] + L loc (ConDecl { con_name = L _ name }) -> + (L loc name) : go remSeen rs - do_one (flds_seen, acc) (L loc (ConDecl { con_name = L _ name })) - = (flds_seen, L loc name : acc) \end{code} Note [Binders in family instances] diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 9dd95fc0f2..4ec9ec7cbb 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -260,7 +260,7 @@ getSymbolTable bh ncu = do mapAccumR (fromOnDiskName arr) namecache od_names in (namecache', arr) -type OnDiskName = (PackageId, ModuleName, OccName) +type OnDiskName = (PackageKey, ModuleName, OccName) fromOnDiskName :: Array Int Name -> NameCache -> OnDiskName -> (NameCache, Name) fromOnDiskName _ nc (pid, mod_name, occ) = @@ -277,7 +277,7 @@ fromOnDiskName _ nc (pid, mod_name, occ) = serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () serialiseName bh name _ = do let mod = ASSERT2( isExternalName name, ppr name ) nameModule name - put_ bh (modulePackageId mod, moduleName mod, nameOccName name) + put_ bh (modulePackageKey mod, moduleName mod, nameOccName name) -- Note [Symbol table representation of names] diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index f2d6f7e39a..46091adf80 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -330,7 +330,7 @@ We cannot represent this by a newtype, even though it's not existential, because there are two value fields (the equality predicate and op. See Trac #2238 -Moreover, +Moreover, class (a ~ F b) => C a b where {} Here we can't use a newtype either, even though there is only one field, because equality predicates are unboxed, and classes diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 7b202acf7d..935b8eda93 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -168,9 +168,10 @@ data IfaceClassOp = IfaceClassOp IfaceTopBndr DefMethSpec IfaceType -- Just False => ordinary polymorphic default method -- Just True => generic default method -data IfaceAT = IfaceAT - IfaceDecl -- The associated type declaration - [IfaceAxBranch] -- Default associated type instances, if any +data IfaceAT = IfaceAT -- See Class.ClassATItem + IfaceDecl -- The associated type declaration + (Maybe IfaceType) -- Default associated type instance, if any + -- This is just like CoAxBranch data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] @@ -839,12 +840,12 @@ instance Outputable IfaceAT where ppr = pprIfaceAT showAll pprIfaceAT :: ShowSub -> IfaceAT -> SDoc -pprIfaceAT ss (IfaceAT d defs) +pprIfaceAT ss (IfaceAT d mb_def) = vcat [ pprIfaceDecl ss d - , ppUnless (null defs) $ nest 2 $ - ptext (sLit "Defaults:") <+> vcat (map (pprAxBranch pp_tc) defs) ] - where - pp_tc = ppr (ifName d) + , case mb_def of + Nothing -> empty + Just rhs -> nest 2 $ + ptext (sLit "Default:") <+> ppr rhs ] instance Outputable IfaceTyConParent where ppr p = pprIfaceTyConParent p @@ -1174,9 +1175,11 @@ freeNamesIfContext :: IfaceContext -> NameSet freeNamesIfContext = fnList freeNamesIfType freeNamesIfAT :: IfaceAT -> NameSet -freeNamesIfAT (IfaceAT decl defs) +freeNamesIfAT (IfaceAT decl mb_def) = freeNamesIfDecl decl &&& - fnList freeNamesIfAxBranch defs + case mb_def of + Nothing -> emptyNameSet + Just rhs -> freeNamesIfType rhs freeNamesIfClsSig :: IfaceClassOp -> NameSet freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 03ce53fff8..2be6e9d4d8 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -353,13 +353,13 @@ wantHiBootFile dflags eps mod from -- The boot-ness of the requested interface, -- based on the dependencies in directly-imported modules where - this_package = thisPackage dflags == modulePackageId mod + this_package = thisPackage dflags == modulePackageKey mod badSourceImport :: Module -> SDoc badSourceImport mod = hang (ptext (sLit "You cannot {-# SOURCE #-} import a module from another package")) 2 (ptext (sLit "but") <+> quotes (ppr mod) <+> ptext (sLit "is from package") - <+> quotes (ppr (modulePackageId mod))) + <+> quotes (ppr (modulePackageKey mod))) \end{code} Note [Care with plugin imports] @@ -573,7 +573,7 @@ findAndReadIface doc_str mod hi_boot_file (ml_hi_file loc) -- See Note [Home module load error] - if thisPackage dflags == modulePackageId mod && + if thisPackage dflags == modulePackageKey mod && not (isOneShot (ghcMode dflags)) then return (Failed (homeModError mod loc)) else do r <- read_file file_path @@ -876,7 +876,9 @@ badIfaceFile file err hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc hiModuleNameMismatchWarn requested_mod read_mod = - withPprStyle defaultUserStyle $ + -- ToDo: This will fail to have enough qualification when the package IDs + -- are the same + withPprStyle (mkUserStyle alwaysQualify AllTheWay) $ -- we want the Modules below to be qualified with package names, -- so reset the PrintUnqualified setting. hsep [ ptext (sLit "Something is amiss; requested module ") diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index b4d36aed91..1aba9eee44 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -218,12 +218,12 @@ mkDependencies -- on M.hi-boot, and hence that we should do the hi-boot consistency -- check.) - pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports) + pkgs | th_used = insertList thPackageKey (imp_dep_pkgs imports) | otherwise = imp_dep_pkgs imports -- Set the packages required to be Safe according to Safe Haskell. -- See Note [RnNames . Tracking Trust Transitively] - sorted_pkgs = sortBy stablePackageIdCmp pkgs + sorted_pkgs = sortBy stablePackageKeyCmp pkgs trust_pkgs = imp_trust_pkgs imports dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs @@ -559,7 +559,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- dependency tree. We only care about orphan modules in the current -- package, because changes to orphans outside this package will be -- tracked by the usage on the ABI hash of package modules that we import. - let orph_mods = filter ((== this_pkg) . modulePackageId) + let orph_mods = filter ((== this_pkg) . modulePackageKey) $ dep_orphs sorted_deps dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods @@ -661,7 +661,7 @@ getOrphanHashes hsc_env mods = do sortDependencies :: Dependencies -> Dependencies sortDependencies d = Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d), - dep_pkgs = sortBy (stablePackageIdCmp `on` fst) (dep_pkgs d), + dep_pkgs = sortBy (stablePackageKeyCmp `on` fst) (dep_pkgs d), dep_orphs = sortBy stableModuleCmp (dep_orphs d), dep_finsts = sortBy stableModuleCmp (dep_finsts d) } \end{code} @@ -989,7 +989,7 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names -- things in *this* module = Nothing - | modulePackageId mod /= this_pkg + | modulePackageKey mod /= this_pkg = Just UsagePackageModule{ usg_mod = mod, usg_mod_hash = mod_hash, usg_safe = imp_safe } @@ -1318,7 +1318,7 @@ checkDependencies hsc_env summary iface return (RecompBecause reason) else return UpToDate - where pkg = modulePackageId mod + where pkg = modulePackageKey mod _otherwise -> return (RecompBecause reason) needInterface :: Module -> (ModIface -> IfG RecompileRequired) @@ -1347,7 +1347,7 @@ needInterface mod continue -- | Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out -- whether M needs to be recompiled. -checkModUsage :: PackageId -> Usage -> IfG RecompileRequired +checkModUsage :: PackageKey -> Usage -> IfG RecompileRequired checkModUsage _this_pkg UsagePackageModule{ usg_mod = mod, usg_mod_hash = old_mod_hash } @@ -1476,7 +1476,7 @@ checkList (check:checks) = do recompile <- check \begin{code} tyThingToIfaceDecl :: TyThing -> IfaceDecl tyThingToIfaceDecl (AnId id) = idToIfaceDecl id -tyThingToIfaceDecl (ATyCon tycon) = tyConToIfaceDecl emptyTidyEnv tycon +tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon) tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax tyThingToIfaceDecl (AConLike cl) = case cl of RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only @@ -1568,48 +1568,52 @@ coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs -- See Note [CoAxBranch type variables] in CoAxiom ----------------- -tyConToIfaceDecl :: TidyEnv -> TyCon -> IfaceDecl +tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl) -- We *do* tidy TyCons, because they are not (and cannot -- conveniently be) built in tidy form +-- The returned TidyEnv is the one after tidying the tyConTyVars tyConToIfaceDecl env tycon | Just clas <- tyConClass_maybe tycon = classToIfaceDecl env clas | Just syn_rhs <- synTyConRhs_maybe tycon - = IfaceSyn { ifName = getOccName tycon, - ifTyVars = if_tc_tyvars, - ifRoles = tyConRoles tycon, - ifSynRhs = to_ifsyn_rhs syn_rhs, - ifSynKind = tidyToIfaceType tc_env1 (synTyConResKind tycon) } + = ( tc_env1 + , IfaceSyn { ifName = getOccName tycon, + ifTyVars = if_tc_tyvars, + ifRoles = tyConRoles tycon, + ifSynRhs = to_ifsyn_rhs syn_rhs, + ifSynKind = tidyToIfaceType tc_env1 (synTyConResKind tycon) }) | isAlgTyCon tycon - = IfaceData { ifName = getOccName tycon, - ifCType = tyConCType tycon, - ifTyVars = if_tc_tyvars, - ifRoles = tyConRoles tycon, - ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon), - ifCons = ifaceConDecls (algTyConRhs tycon), - ifRec = boolToRecFlag (isRecursiveTyCon tycon), - ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifPromotable = isJust (promotableTyCon_maybe tycon), - ifParent = parent } + = ( tc_env1 + , IfaceData { ifName = getOccName tycon, + ifCType = tyConCType tycon, + ifTyVars = if_tc_tyvars, + ifRoles = tyConRoles tycon, + ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon), + ifCons = ifaceConDecls (algTyConRhs tycon), + ifRec = boolToRecFlag (isRecursiveTyCon tycon), + ifGadtSyntax = isGadtSyntaxTyCon tycon, + ifPromotable = isJust (promotableTyCon_maybe tycon), + ifParent = parent }) | isForeignTyCon tycon - = IfaceForeign { ifName = getOccName tycon, - ifExtName = tyConExtName tycon } + = (env, IfaceForeign { ifName = getOccName tycon, + ifExtName = tyConExtName tycon }) - | otherwise + | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon -- For pretty printing purposes only. - = IfaceData { ifName = getOccName tycon, - ifCType = Nothing, - ifTyVars = funAndPrimTyVars, - ifRoles = tyConRoles tycon, - ifCtxt = [], - ifCons = IfDataTyCon [], - ifRec = boolToRecFlag False, - ifGadtSyntax = False, - ifPromotable = False, - ifParent = IfNoParent } + = ( env + , IfaceData { ifName = getOccName tycon, + ifCType = Nothing, + ifTyVars = funAndPrimTyVars, + ifRoles = tyConRoles tycon, + ifCtxt = [], + ifCons = IfDataTyCon [], + ifRec = boolToRecFlag False, + ifGadtSyntax = False, + ifPromotable = False, + ifParent = IfNoParent }) where (tc_env1, tc_tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon) if_tc_tyvars = toIfaceTvBndrs tc_tyvars @@ -1680,17 +1684,18 @@ toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env c toIfaceBang _ HsStrict = IfStrict toIfaceBang _ (HsUserBang {}) = panic "toIfaceBang" -classToIfaceDecl :: TidyEnv -> Class -> IfaceDecl +classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl) classToIfaceDecl env clas - = IfaceClass { ifCtxt = tidyToIfaceContext env1 sc_theta, - ifName = getOccName (classTyCon clas), - ifTyVars = toIfaceTvBndrs clas_tyvars', - ifRoles = tyConRoles (classTyCon clas), - ifFDs = map toIfaceFD clas_fds, - ifATs = map toIfaceAT clas_ats, - ifSigs = map toIfaceClassOp op_stuff, - ifMinDef = fmap getFS (classMinimalDef clas), - ifRec = boolToRecFlag (isRecursiveTyCon tycon) } + = ( env1 + , IfaceClass { ifCtxt = tidyToIfaceContext env1 sc_theta, + ifName = getOccName (classTyCon clas), + ifTyVars = toIfaceTvBndrs clas_tyvars', + ifRoles = tyConRoles (classTyCon clas), + ifFDs = map toIfaceFD clas_fds, + ifATs = map toIfaceAT clas_ats, + ifSigs = map toIfaceClassOp op_stuff, + ifMinDef = fmap getFS (classMinimalDef clas), + ifRec = boolToRecFlag (isRecursiveTyCon tycon) }) where (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff) = classExtraBigSig clas @@ -1699,8 +1704,10 @@ classToIfaceDecl env clas (env1, clas_tyvars') = tidyTyVarBndrs env clas_tyvars toIfaceAT :: ClassATItem -> IfaceAT - toIfaceAT (tc, defs) - = IfaceAT (tyConToIfaceDecl env1 tc) (map (coAxBranchToIfaceBranch' tc) defs) + toIfaceAT (ATI tc def) + = IfaceAT if_decl (fmap (tidyToIfaceType env2) def) + where + (env2, if_decl) = tyConToIfaceDecl env1 tc toIfaceClassOp (sel_id, def_meth) = ASSERT(sel_tyvars == clas_tyvars) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 867674b3e6..68f9e8fd65 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -344,26 +344,34 @@ tcHiBootIface hsc_src mod else do -- OK, so we're in one-shot mode. - -- In that case, we're read all the direct imports by now, - -- so eps_is_boot will record if any of our imports mention us by - -- way of hi-boot file - { eps <- getEps - ; case lookupUFM (eps_is_boot eps) (moduleName mod) of { - Nothing -> return emptyModDetails ; -- The typical case + -- Re #9245, we always check if there is an hi-boot interface + -- to check consistency against, rather than just when we notice + -- that an hi-boot is necessary due to a circular import. + { read_result <- findAndReadIface + need mod + True -- Hi-boot file - Just (_, False) -> failWithTc moduleLoop ; + ; case read_result of { + Succeeded (iface, _path) -> typecheckIface iface ; + Failed err -> + + -- There was no hi-boot file. But if there is circularity in + -- the module graph, there really should have been one. + -- Since we've read all the direct imports by now, + -- eps_is_boot will record if any of our imports mention the + -- current module, which either means a module loop (not + -- a SOURCE import) or that our hi-boot file has mysteriously + -- disappeared. + do { eps <- getEps + ; case lookupUFM (eps_is_boot eps) (moduleName mod) of + Nothing -> return emptyModDetails -- The typical case + + Just (_, False) -> failWithTc moduleLoop -- Someone below us imported us! -- This is a loop with no hi-boot in the way - Just (_mod, True) -> -- There's a hi-boot interface below us - - do { read_result <- findAndReadIface - need mod - True -- Hi-boot file - - ; case read_result of - Failed err -> failWithTc (elaborate err) - Succeeded (iface, _path) -> typecheckIface iface + Just (_mod, True) -> failWithTc (elaborate err) + -- The hi-boot file has mysteriously disappeared. }}}} where need = ptext (sLit "Need the hi-boot interface for") <+> ppr mod @@ -536,13 +544,18 @@ tc_iface_decl _parent ignore_prags -- it mentions unless it's necessary to do so ; return (op_name, dm, op_ty) } - tc_at cls (IfaceAT tc_decl defs_decls) + tc_at cls (IfaceAT tc_decl if_def) = do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl - defs <- forkM (mk_at_doc tc) (tc_ax_branches defs_decls) + mb_def <- case if_def of + Nothing -> return Nothing + Just def -> forkM (mk_at_doc tc) $ + extendIfaceTyVarEnv (tyConTyVars tc) $ + do { tc_def <- tcIfaceType def + ; return (Just tc_def) } -- Must be done lazily in case the RHS of the defaults mention -- the type constructor being defined here -- e.g. type AT a; type AT b = AT [b] Trac #8002 - return (tc, defs) + return (ATI tc mb_def) mk_sc_doc pred = ptext (sLit "Superclass") <+> ppr pred mk_at_doc tc = ptext (sLit "Associated type") <+> ppr tc diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs index f92bd89c5c..24d0856ea3 100644 --- a/compiler/llvmGen/Llvm/AbsSyn.hs +++ b/compiler/llvmGen/Llvm/AbsSyn.hs @@ -65,6 +65,8 @@ data LlvmFunction = LlvmFunction { type LlvmFunctions = [LlvmFunction] +type SingleThreaded = Bool + -- | LLVM ordering types for synchronization purposes. (Introduced in LLVM -- 3.0). Please see the LLVM documentation for a better description. data LlvmSyncOrdering @@ -224,6 +226,11 @@ data LlvmExpression | Load LlvmVar {- | + Atomic load of the value at location ptr + -} + | ALoad LlvmSyncOrdering SingleThreaded LlvmVar + + {- | Navigate in an structure, selecting elements * inbound: Is the pointer inbounds? (computed pointer doesn't overflow) * ptr: Location of the structure diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index 025078226d..73077257f8 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -239,6 +239,7 @@ ppLlvmExpression expr Insert vec elt idx -> ppInsert vec elt idx GetElemPtr inb ptr indexes -> ppGetElementPtr inb ptr indexes Load ptr -> ppLoad ptr + ALoad ord st ptr -> ppALoad ord st ptr Malloc tp amount -> ppMalloc tp amount Phi tp precessors -> ppPhi tp precessors Asm asm c ty v se sk -> ppAsm asm c ty v se sk @@ -327,13 +328,18 @@ ppSyncOrdering SyncSeqCst = text "seq_cst" -- of specifying alignment. ppLoad :: LlvmVar -> SDoc -ppLoad var - | isVecPtrVar var = text "load" <+> ppr var <> - comma <+> text "align 1" - | otherwise = text "load" <+> ppr var +ppLoad var = text "load" <+> ppr var <> align where - isVecPtrVar :: LlvmVar -> Bool - isVecPtrVar = isVector . pLower . getVarType + align | isVector . pLower . getVarType $ var = text ", align 1" + | otherwise = empty + +ppALoad :: LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc +ppALoad ord st var = sdocWithDynFlags $ \dflags -> + let alignment = (llvmWidthInBits dflags $ getVarType var) `quot` 8 + align = text ", align" <+> ppr alignment + sThreaded | st = text " singlethread" + | otherwise = empty + in text "load atomic" <+> ppr var <> sThreaded <+> ppSyncOrdering ord <> align ppStore :: LlvmVar -> LlvmVar -> SDoc ppStore val dst diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 686b352c2a..50cd824b24 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -406,7 +406,7 @@ strDisplayName_llvm lbl = do dflags <- getDynFlags let sdoc = pprCLabel platform lbl depth = Outp.PartWay 1 - style = Outp.mkUserStyle (\ _ _ -> Outp.NameNotInScope2, Outp.alwaysQualifyModules) depth + style = Outp.mkUserStyle Outp.reallyAlwaysQualify depth str = Outp.renderWithStyle dflags sdoc style return (fsLit (dropInfoSuffix str)) diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 517553516b..4a56600937 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -15,6 +15,7 @@ import BlockId import CodeGen.Platform ( activeStgRegs, callerSaves ) import CLabel import Cmm +import CPrim import PprCmm import CmmUtils import Hoopl @@ -32,6 +33,7 @@ import Unique import Data.List ( nub ) import Data.Maybe ( catMaybes ) +type Atomic = Bool type LlvmStatements = OrdList LlvmStatement -- ----------------------------------------------------------------------------- @@ -228,6 +230,17 @@ genCall t@(PrimTarget (MO_PopCnt w)) dsts args = genCall t@(PrimTarget (MO_BSwap w)) dsts args = genCallSimpleCast w t dsts args +genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = do + dstV <- getCmmReg (CmmLocal dst) + (v1, stmts, top) <- genLoad True addr (localRegType dst) + let stmt1 = Store v1 dstV + return (stmts `snocOL` stmt1, top) + +-- TODO: implement these properly rather than calling to RTS functions. +-- genCall t@(PrimTarget (MO_AtomicWrite width)) [] [addr, val] = undefined +-- genCall t@(PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = undefined +-- genCall t@(PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] = undefined + -- Handle memcpy function specifically since llvm's intrinsic version takes -- some extra parameters. genCall t@(PrimTarget op) [] args' @@ -548,7 +561,6 @@ cmmPrimOpFunctions mop = do (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch" - MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported MO_U_QuotRem2 {} -> unsupported @@ -558,6 +570,12 @@ cmmPrimOpFunctions mop = do MO_Touch -> unsupported MO_UF_Conv _ -> unsupported + MO_AtomicRead _ -> unsupported + + MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop + MO_Cmpxchg w -> fsLit $ cmpxchgLabel w + MO_AtomicWrite w -> fsLit $ atomicWriteLabel w + -- | Tail function calls genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData @@ -849,7 +867,7 @@ exprToVarOpt opt e = case e of -> genLit opt lit CmmLoad e' ty - -> genLoad e' ty + -> genLoad False e' ty -- Cmmreg in expression is the value, so must load. If you want actual -- reg pointer, call getCmmReg directly. @@ -1268,41 +1286,41 @@ genMachOp_slow _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!" -- | Handle CmmLoad expression. -genLoad :: CmmExpr -> CmmType -> LlvmM ExprData +genLoad :: Atomic -> CmmExpr -> CmmType -> LlvmM ExprData -- First we try to detect a few common cases and produce better code for -- these then the default case. We are mostly trying to detect Cmm code -- like I32[Sp + n] and use 'getelementptr' operations instead of the -- generic case that uses casts and pointer arithmetic -genLoad e@(CmmReg (CmmGlobal r)) ty - = genLoad_fast e r 0 ty +genLoad atomic e@(CmmReg (CmmGlobal r)) ty + = genLoad_fast atomic e r 0 ty -genLoad e@(CmmRegOff (CmmGlobal r) n) ty - = genLoad_fast e r n ty +genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty + = genLoad_fast atomic e r n ty -genLoad e@(CmmMachOp (MO_Add _) [ +genLoad atomic e@(CmmMachOp (MO_Add _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) ty - = genLoad_fast e r (fromInteger n) ty + = genLoad_fast atomic e r (fromInteger n) ty -genLoad e@(CmmMachOp (MO_Sub _) [ +genLoad atomic e@(CmmMachOp (MO_Sub _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) ty - = genLoad_fast e r (negate $ fromInteger n) ty + = genLoad_fast atomic e r (negate $ fromInteger n) ty -- generic case -genLoad e ty +genLoad atomic e ty = do other <- getTBAAMeta otherN - genLoad_slow e ty other + genLoad_slow atomic e ty other -- | Handle CmmLoad expression. -- This is a special case for loading from a global register pointer -- offset such as I32[Sp+8]. -genLoad_fast :: CmmExpr -> GlobalReg -> Int -> CmmType - -> LlvmM ExprData -genLoad_fast e r n ty = do +genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType + -> LlvmM ExprData +genLoad_fast atomic e r n ty = do dflags <- getDynFlags (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) meta <- getTBAARegMeta r @@ -1315,7 +1333,7 @@ genLoad_fast e r n ty = do case grt == ty' of -- were fine True -> do - (var, s3) <- doExpr ty' (MExpr meta $ Load ptr) + (var, s3) <- doExpr ty' (MExpr meta $ loadInstr ptr) return (var, s1 `snocOL` s2 `snocOL` s3, []) @@ -1323,32 +1341,34 @@ genLoad_fast e r n ty = do False -> do let pty = pLift ty' (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty - (var, s4) <- doExpr ty' (MExpr meta $ Load ptr') + (var, s4) <- doExpr ty' (MExpr meta $ loadInstr ptr') return (var, s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, []) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway. - False -> genLoad_slow e ty meta - + False -> genLoad_slow atomic e ty meta + where + loadInstr ptr | atomic = ALoad SyncSeqCst False ptr + | otherwise = Load ptr -- | Handle Cmm load expression. -- Generic case. Uses casts and pointer arithmetic if needed. -genLoad_slow :: CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData -genLoad_slow e ty meta = do +genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData +genLoad_slow atomic e ty meta = do (iptr, stmts, tops) <- exprToVar e dflags <- getDynFlags case getVarType iptr of LMPointer _ -> do (dvar, load) <- doExpr (cmmToLlvmType ty) - (MExpr meta $ Load iptr) + (MExpr meta $ loadInstr iptr) return (dvar, stmts `snocOL` load, tops) i@(LMInt _) | i == llvmWord dflags -> do let pty = LMPointer $ cmmToLlvmType ty (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty (dvar, load) <- doExpr (cmmToLlvmType ty) - (MExpr meta $ Load ptr) + (MExpr meta $ loadInstr ptr) return (dvar, stmts `snocOL` cast `snocOL` load, tops) other -> do dflags <- getDynFlags @@ -1357,6 +1377,9 @@ genLoad_slow e ty meta = do "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ ", Var: " ++ showSDoc dflags (ppr iptr))) + where + loadInstr ptr | atomic = ALoad SyncSeqCst False ptr + | otherwise = Load ptr -- | Handle CmmReg expression. This will return a pointer to the stack diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index c0a609ba2e..7a554f4d20 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -50,7 +50,7 @@ codeOutput :: DynFlags -> FilePath -> ModLocation -> ForeignStubs - -> [PackageId] + -> [PackageKey] -> Stream IO RawCmmGroup () -- Compiled C-- -> IO (FilePath, (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})) @@ -100,7 +100,7 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action outputC :: DynFlags -> FilePath -> Stream IO RawCmmGroup () - -> [PackageId] + -> [PackageKey] -> IO () outputC dflags filenm cmm_stream packages @@ -115,7 +115,7 @@ outputC dflags filenm cmm_stream packages -- * -#include options from the cmdline and OPTIONS pragmas -- * the _stub.h file, if there is one. -- - let rts = getPackageDetails (pkgState dflags) rtsPackageId + let rts = getPackageDetails dflags rtsPackageKey let cc_injects = unlines (map mk_include (includes rts)) mk_include h_file = @@ -210,7 +210,7 @@ outputForeignStubs dflags mod location stubs -- we need the #includes from the rts package for the stub files let rts_includes = - let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in + let rts_pkg = getPackageDetails dflags rtsPackageKey in concatMap mk_include (includes rts_pkg) mk_include i = "#include \"" ++ i ++ "\"\n" diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 11427e27cf..f7b5eb8782 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -390,7 +390,7 @@ link' dflags batch_attempt_linking hpt return Succeeded -linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [PackageId] -> IO Bool +linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [PackageKey] -> IO Bool linkingNeeded dflags staticLink linkables pkg_deps = do -- if the modification time on the executable is later than the -- modification times on all of the objects and libraries, then omit @@ -411,9 +411,8 @@ linkingNeeded dflags staticLink linkables pkg_deps = do -- next, check libraries. XXX this only checks Haskell libraries, -- not extra_libraries or -l things from the command line. - let pkg_map = pkgIdMap (pkgState dflags) - pkg_hslibs = [ (libraryDirs c, lib) - | Just c <- map (lookupPackage pkg_map) pkg_deps, + let pkg_hslibs = [ (libraryDirs c, lib) + | Just c <- map (lookupPackage dflags) pkg_deps, lib <- packageHsLibs dflags c ] pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs @@ -427,7 +426,7 @@ linkingNeeded dflags staticLink linkables pkg_deps = do -- Returns 'False' if it was, and we can avoid linking, because the -- previous binary was linked with "the same options". -checkLinkInfo :: DynFlags -> [PackageId] -> FilePath -> IO Bool +checkLinkInfo :: DynFlags -> [PackageKey] -> FilePath -> IO Bool checkLinkInfo dflags pkg_deps exe_file | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) -- ToDo: Windows and OS X do not use the ELF binary format, so @@ -1113,7 +1112,7 @@ runPhase (RealPhase cc_phase) input_fn dflags -- way we do the import depends on whether we're currently compiling -- the base package or not. ++ (if platformOS platform == OSMinGW32 && - thisPackage dflags == basePackageId + thisPackage dflags == basePackageKey then [ "-DCOMPILING_BASE_PACKAGE" ] else []) @@ -1559,7 +1558,7 @@ mkExtraObj dflags extn xs = do cFile <- newTempName dflags extn oFile <- newTempName dflags "o" writeFile cFile xs - let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId + let rtsDetails = getPackageDetails dflags rtsPackageKey SysTools.runCc dflags ([Option "-c", FileOption "" cFile, @@ -1608,7 +1607,7 @@ mkExtraObjToLinkIntoBinary dflags = do -- this was included as inline assembly in the main.c file but this -- is pretty fragile. gas gets upset trying to calculate relative offsets -- that span the .note section (notably .text) when debug info is present -mkNoteObjsToLinkIntoBinary :: DynFlags -> [PackageId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary :: DynFlags -> [PackageKey] -> IO [FilePath] mkNoteObjsToLinkIntoBinary dflags dep_packages = do link_info <- getLinkInfo dflags dep_packages @@ -1649,7 +1648,7 @@ mkNoteObjsToLinkIntoBinary dflags dep_packages = do -- link. We save this information in the binary, and the next time we -- link, if nothing else has changed, we use the link info stored in -- the existing binary to decide whether to re-link or not. -getLinkInfo :: DynFlags -> [PackageId] -> IO String +getLinkInfo :: DynFlags -> [PackageKey] -> IO String getLinkInfo dflags dep_packages = do package_link_opts <- getPackageLinkOpts dflags dep_packages pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags) @@ -1727,13 +1726,13 @@ mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $ ----------------------------------------------------------------------------- -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file -getHCFilePackages :: FilePath -> IO [PackageId] +getHCFilePackages :: FilePath -> IO [PackageKey] getHCFilePackages filename = Exception.bracket (openFile filename ReadMode) hClose $ \h -> do l <- hGetLine h case l of '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> - return (map stringToPackageId (words rest)) + return (map stringToPackageKey (words rest)) _other -> return [] @@ -1750,10 +1749,10 @@ getHCFilePackages filename = -- read any interface files), so the user must explicitly specify all -- the packages. -linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO () +linkBinary :: DynFlags -> [FilePath] -> [PackageKey] -> IO () linkBinary = linkBinary' False -linkBinary' :: Bool -> DynFlags -> [FilePath] -> [PackageId] -> IO () +linkBinary' :: Bool -> DynFlags -> [FilePath] -> [PackageKey] -> IO () linkBinary' staticLink dflags o_files dep_packages = do let platform = targetPlatform dflags mySettings = settings dflags @@ -2027,7 +2026,7 @@ maybeCreateManifest dflags exe_filename | otherwise = return [] -linkDynLibCheck :: DynFlags -> [String] -> [PackageId] -> IO () +linkDynLibCheck :: DynFlags -> [String] -> [PackageKey] -> IO () linkDynLibCheck dflags o_files dep_packages = do when (haveRtsOptsFlags dflags) $ do @@ -2037,7 +2036,7 @@ linkDynLibCheck dflags o_files dep_packages linkDynLib dflags o_files dep_packages -linkStaticLibCheck :: DynFlags -> [String] -> [PackageId] -> IO () +linkStaticLibCheck :: DynFlags -> [String] -> [PackageKey] -> IO () linkStaticLibCheck dflags o_files dep_packages = do when (platformOS (targetPlatform dflags) `notElem` [OSiOS, OSDarwin]) $ @@ -2166,7 +2165,9 @@ joinObjectFiles dflags o_files output_fn = do if ldIsGnuLd then do script <- newTempName dflags "ldscript" - writeFile script $ "INPUT(" ++ unwords o_files ++ ")" + cwd <- getCurrentDirectory + let o_files_abs = map (cwd </>) o_files + writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")" ld_r [SysTools.FileOption "" script] ccInfo else if sLdSupportsFilelist mySettings then do diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 122eafff19..74bd1397b8 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -43,7 +43,7 @@ module DynFlags ( targetRetainsAllBindings, GhcMode(..), isOneShot, GhcLink(..), isNoLink, - PackageFlag(..), + PackageFlag(..), PackageArg(..), ModRenaming, PkgConfRef(..), Option(..), showOpt, DynLibLoader(..), @@ -61,7 +61,7 @@ module DynFlags ( safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn, packageTrustOn, safeDirectImpsReq, safeImplicitImpsReq, - unsafeFlags, + unsafeFlags, unsafeFlagsForInfer, -- ** System tool settings and locations Settings(..), @@ -90,7 +90,7 @@ module DynFlags ( getVerbFlags, updOptLevel, setTmpDir, - setPackageName, + setPackageKey, -- ** Parsing DynFlags parseDynamicFlagsCmdLine, @@ -190,6 +190,8 @@ import Data.Word import System.FilePath import System.IO import System.IO.Error +import Text.ParserCombinators.ReadP hiding (char) +import Text.ParserCombinators.ReadP as R import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet @@ -269,6 +271,7 @@ data DumpFlag | Opt_D_dump_hi | Opt_D_dump_hi_diffs | Opt_D_dump_mod_cycles + | Opt_D_dump_mod_map | Opt_D_dump_view_pattern_commoning | Opt_D_verbose_core2core @@ -480,7 +483,6 @@ data SafeHaskellMode | Sf_Unsafe | Sf_Trustworthy | Sf_Safe - | Sf_SafeInferred deriving (Eq) instance Show SafeHaskellMode where @@ -488,7 +490,6 @@ instance Show SafeHaskellMode where show Sf_Unsafe = "Unsafe" show Sf_Trustworthy = "Trustworthy" show Sf_Safe = "Safe" - show Sf_SafeInferred = "Safe-Inferred" instance Outputable SafeHaskellMode where ppr = text . show @@ -630,7 +631,7 @@ data DynFlags = DynFlags { ctxtStkDepth :: Int, -- ^ Typechecker context stack depth tyFunStkDepth :: Int, -- ^ Typechecker type function stack depth - thisPackage :: PackageId, -- ^ name of package currently being compiled + thisPackage :: PackageKey, -- ^ name of package currently being compiled -- ways ways :: [Way], -- ^ Way flags from the command line @@ -737,11 +738,14 @@ data DynFlags = DynFlags { language :: Maybe Language, -- | Safe Haskell mode safeHaskell :: SafeHaskellMode, + safeInfer :: Bool, + safeInferred :: Bool, -- We store the location of where some extension and flags were turned on so -- we can produce accurate error messages when Safe Haskell fails due to -- them. thOnLoc :: SrcSpan, newDerivOnLoc :: SrcSpan, + overlapInstLoc :: SrcSpan, pkgTrustOnLoc :: SrcSpan, warnSafeOnLoc :: SrcSpan, warnUnsafeOnLoc :: SrcSpan, @@ -1019,9 +1023,15 @@ isNoLink :: GhcLink -> Bool isNoLink NoLink = True isNoLink _ = False +data PackageArg = PackageArg String + | PackageIdArg String + | PackageKeyArg String + deriving (Eq, Show) + +type ModRenaming = Maybe [(String, String)] + data PackageFlag - = ExposePackage String - | ExposePackageId String + = ExposePackage PackageArg ModRenaming | HidePackage String | IgnorePackage String | TrustPackage String @@ -1215,7 +1225,6 @@ wayOptl platform WayThreaded = -- the problems are our fault or theirs, but it seems that using the -- alternative 1:1 threading library libthr works around it: OSFreeBSD -> ["-lthr"] - OSSolaris2 -> ["-lrt"] OSOpenBSD -> ["-pthread"] OSNetBSD -> ["-pthread"] _ -> [] @@ -1352,7 +1361,7 @@ defaultDynFlags mySettings = ctxtStkDepth = mAX_CONTEXT_REDUCTION_DEPTH, tyFunStkDepth = mAX_TYPE_FUNCTION_REDUCTION_DEPTH, - thisPackage = mainPackageId, + thisPackage = mainPackageKey, objectDir = Nothing, dylibInstallName = Nothing, @@ -1417,9 +1426,12 @@ defaultDynFlags mySettings = warningFlags = IntSet.fromList (map fromEnum standardWarnings), ghciScripts = [], language = Nothing, - safeHaskell = Sf_SafeInferred, + safeHaskell = Sf_None, + safeInfer = True, + safeInferred = True, thOnLoc = noSrcSpan, newDerivOnLoc = noSrcSpan, + overlapInstLoc = noSrcSpan, pkgTrustOnLoc = noSrcSpan, warnSafeOnLoc = noSrcSpan, warnUnsafeOnLoc = noSrcSpan, @@ -1626,6 +1638,7 @@ dopt f dflags = (fromEnum f `IntSet.member` dumpFlags dflags) enableIfVerbose Opt_D_dump_ticked = False enableIfVerbose Opt_D_dump_view_pattern_commoning = False enableIfVerbose Opt_D_dump_mod_cycles = False + enableIfVerbose Opt_D_dump_mod_map = False enableIfVerbose _ = True -- | Set a 'DumpFlag' @@ -1702,7 +1715,7 @@ packageTrustOn = gopt Opt_PackageTrust -- | Is Safe Haskell on in some way (including inference mode) safeHaskellOn :: DynFlags -> Bool -safeHaskellOn dflags = safeHaskell dflags /= Sf_None +safeHaskellOn dflags = safeHaskell dflags /= Sf_None || safeInferOn dflags -- | Is the Safe Haskell safe language in use safeLanguageOn :: DynFlags -> Bool @@ -1710,7 +1723,7 @@ safeLanguageOn dflags = safeHaskell dflags == Sf_Safe -- | Is the Safe Haskell safe inference mode active safeInferOn :: DynFlags -> Bool -safeInferOn dflags = safeHaskell dflags == Sf_SafeInferred +safeInferOn = safeInfer -- | Test if Safe Imports are on in some form safeImportsOn :: DynFlags -> Bool @@ -1724,7 +1737,11 @@ setSafeHaskell s = updM f where f dfs = do let sf = safeHaskell dfs safeM <- combineSafeFlags sf s - return $ dfs { safeHaskell = safeM } + return $ case (s == Sf_Safe || s == Sf_Unsafe) of + True -> dfs { safeHaskell = safeM, safeInfer = False } + -- leave safe inferrence on in Trustworthy mode so we can warn + -- if it could have been inferred safe. + False -> dfs { safeHaskell = safeM } -- | Are all direct imports required to be safe for this Safe Haskell mode? -- Direct imports are when the code explicitly imports a module @@ -1741,9 +1758,7 @@ safeImplicitImpsReq d = safeLanguageOn d -- want to export this functionality from the module but do want to export the -- type constructors. combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode -combineSafeFlags a b | a == Sf_SafeInferred = return b - | b == Sf_SafeInferred = return a - | a == Sf_None = return b +combineSafeFlags a b | a == Sf_None = return b | b == Sf_None = return a | a == b = return a | otherwise = addErr errm >> return (panic errm) @@ -1755,13 +1770,19 @@ combineSafeFlags a b | a == Sf_SafeInferred = return b -- * function to get srcspan that enabled the flag -- * function to test if the flag is on -- * function to turn the flag off -unsafeFlags :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] +unsafeFlags, unsafeFlagsForInfer + :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] unsafeFlags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc, xopt Opt_GeneralizedNewtypeDeriving, flip xopt_unset Opt_GeneralizedNewtypeDeriving), ("-XTemplateHaskell", thOnLoc, xopt Opt_TemplateHaskell, flip xopt_unset Opt_TemplateHaskell)] +unsafeFlagsForInfer = unsafeFlags ++ + -- TODO: Can we do better than this for inference? + [("-XOverlappingInstances", overlapInstLoc, + xopt Opt_OverlappingInstances, + flip xopt_unset Opt_OverlappingInstances)] -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from @@ -2043,43 +2064,41 @@ updateWays dflags -- The bool is to indicate if we are parsing command line flags (false means -- file pragma). This allows us to generate better warnings. safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String]) -safeFlagCheck _ dflags | not (safeLanguageOn dflags || safeInferOn dflags) - = (dflags, []) - --- safe or safe-infer ON -safeFlagCheck cmdl dflags = - case safeLanguageOn dflags of - True -> (dflags', warns) +safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns) + where + -- Handle illegal flags under safe language. + (dflagsUnset, warns) = foldl check_method (dflags, []) unsafeFlags - -- throw error if -fpackage-trust by itself with no safe haskell flag - False | not cmdl && packageTrustOn dflags - -> (gopt_unset dflags' Opt_PackageTrust, - [L (pkgTrustOnLoc dflags') $ - "-fpackage-trust ignored;" ++ - " must be specified with a Safe Haskell flag"] - ) + check_method (df, warns) (str,loc,test,fix) + | test df = (fix df, warns ++ safeFailure (loc df) str) + | otherwise = (df, warns) - False | null warns && safeInfOk - -> (dflags', []) + safeFailure loc str + = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " + ++ str] - | otherwise - -> (dflags' { safeHaskell = Sf_None }, []) - -- Have we inferred Unsafe? - -- See Note [HscMain . Safe Haskell Inference] - where - -- TODO: Can we do better than this for inference? - safeInfOk = not $ xopt Opt_OverlappingInstances dflags +safeFlagCheck cmdl dflags = + case (safeInferOn dflags) of + True | safeFlags -> (dflags', warn) + True -> (dflags' { safeInferred = False }, warn) + False -> (dflags', warn) - (dflags', warns) = foldl check_method (dflags, []) unsafeFlags + where + -- dynflags and warn for when -fpackage-trust by itself with no safe + -- haskell flag + (dflags', warn) + | safeHaskell dflags == Sf_None && not cmdl && packageTrustOn dflags + = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg) + | otherwise = (dflags, []) - check_method (df, warns) (str,loc,test,fix) - | test df = (apFix fix df, warns ++ safeFailure (loc dflags) str) - | otherwise = (df, warns) + pkgWarnMsg = [L (pkgTrustOnLoc dflags') $ + "-fpackage-trust ignored;" ++ + " must be specified with a Safe Haskell flag"] - apFix f = if safeInferOn dflags then id else f + safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer + -- Have we inferred Unsafe? + -- See Note [HscMain . Safe Haskell Inference] - safeFailure loc str - = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " ++ str] {- ********************************************************************** %* * @@ -2364,6 +2383,7 @@ dynamic_flags = [ , Flag "ddump-hpc" (setDumpFlag Opt_D_dump_ticked) -- back compat , Flag "ddump-ticked" (setDumpFlag Opt_D_dump_ticked) , Flag "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles) + , Flag "ddump-mod-map" (setDumpFlag Opt_D_dump_mod_map) , Flag "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning) , Flag "ddump-to-file" (NoArg (setGeneralFlag Opt_DumpToFile)) , Flag "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs) @@ -2478,7 +2498,7 @@ dynamic_flags = [ ------ Safe Haskell flags ------------------------------------------- , Flag "fpackage-trust" (NoArg setPackageTrust) - , Flag "fno-safe-infer" (NoArg (setSafeHaskell Sf_None)) + , Flag "fno-safe-infer" (noArg (\d -> d { safeInfer = False } )) , Flag "fPIC" (NoArg (setGeneralFlag Opt_PIC)) , Flag "fno-PIC" (NoArg (unSetGeneralFlag Opt_PIC)) ] @@ -2517,9 +2537,13 @@ package_flags = [ removeUserPkgConf deprecate "Use -no-user-package-db instead") - , Flag "package-name" (hasArg setPackageName) + , Flag "package-name" (HasArg $ \name -> do + upd (setPackageKey name) + deprecate "Use -this-package-key instead") + , Flag "this-package-key" (hasArg setPackageKey) , Flag "package-id" (HasArg exposePackageId) , Flag "package" (HasArg exposePackage) + , Flag "package-key" (HasArg exposePackageKey) , Flag "hide-package" (HasArg hidePackage) , Flag "hide-all-packages" (NoArg (setGeneralFlag Opt_HideAllPackages)) , Flag "ignore-package" (HasArg ignorePackage) @@ -2872,7 +2896,9 @@ xFlags = [ deprecatedForExtension "MultiParamTypeClasses" ), ( "FunctionalDependencies", Opt_FunctionalDependencies, nop ), ( "GeneralizedNewtypeDeriving", Opt_GeneralizedNewtypeDeriving, setGenDeriving ), - ( "OverlappingInstances", Opt_OverlappingInstances, nop ), + ( "OverlappingInstances", Opt_OverlappingInstances, + \ turn_on -> when turn_on + $ deprecate "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS" ), ( "UndecidableInstances", Opt_UndecidableInstances, nop ), ( "IncoherentInstances", Opt_IncoherentInstances, nop ), ( "PackageImports", Opt_PackageImports, nop ), @@ -3327,11 +3353,39 @@ removeGlobalPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotGlobal . extra clearPkgConf :: DynP () clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] } -exposePackage, exposePackageId, hidePackage, ignorePackage, +parsePackageFlag :: (String -> PackageArg) -- type of argument + -> String -- string to parse + -> PackageFlag +parsePackageFlag constr str = case filter ((=="").snd) (readP_to_S parse str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str) + where parse = do + pkg <- munch1 (\c -> isAlphaNum c || c `elem` ":-_.") + (do _ <- tok $ R.char '(' + rns <- tok $ sepBy parseItem (tok $ R.char ',') + _ <- tok $ R.char ')' + return (ExposePackage (constr pkg) (Just rns)) + +++ + return (ExposePackage (constr pkg) Nothing)) + parseMod = munch1 (\c -> isAlphaNum c || c `elem` ".") + parseItem = do + orig <- tok $ parseMod + (do _ <- tok $ string "as" + new <- tok $ parseMod + return (orig, new) + +++ + return (orig, orig)) + tok m = skipSpaces >> m + +exposePackage, exposePackageId, exposePackageKey, hidePackage, ignorePackage, trustPackage, distrustPackage :: String -> DynP () exposePackage p = upd (exposePackage' p) exposePackageId p = - upd (\s -> s{ packageFlags = ExposePackageId p : packageFlags s }) + upd (\s -> s{ packageFlags = + parsePackageFlag PackageIdArg p : packageFlags s }) +exposePackageKey p = + upd (\s -> s{ packageFlags = + parsePackageFlag PackageKeyArg p : packageFlags s }) hidePackage p = upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) ignorePackage p = @@ -3343,10 +3397,11 @@ distrustPackage p = exposePackage p >> exposePackage' :: String -> DynFlags -> DynFlags exposePackage' p dflags - = dflags { packageFlags = ExposePackage p : packageFlags dflags } + = dflags { packageFlags = + parsePackageFlag PackageArg p : packageFlags dflags } -setPackageName :: String -> DynFlags -> DynFlags -setPackageName p s = s{ thisPackage = stringToPackageId p } +setPackageKey :: String -> DynFlags -> DynFlags +setPackageKey p s = s{ thisPackage = stringToPackageKey p } -- If we're linking a binary, then only targets that produce object -- code are allowed (requests for other target types are ignored). @@ -3398,10 +3453,10 @@ setMainIs arg | not (null main_fn) && isLower (head main_fn) -- The arg looked like "Foo.Bar.baz" = upd $ \d -> d{ mainFunIs = Just main_fn, - mainModIs = mkModule mainPackageId (mkModuleName main_mod) } + mainModIs = mkModule mainPackageKey (mkModuleName main_mod) } | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" - = upd $ \d -> d{ mainModIs = mkModule mainPackageId (mkModuleName arg) } + = upd $ \d -> d{ mainModIs = mkModule mainPackageKey (mkModuleName arg) } | otherwise -- The arg looked like "baz" = upd $ \d -> d{ mainFunIs = Just arg } @@ -3588,6 +3643,8 @@ compilerInfo dflags ("RTS ways", cGhcRTSWays), ("Support dynamic-too", if isWindows then "NO" else "YES"), ("Support parallel --make", "YES"), + ("Support reexported-modules", "YES"), + ("Uses package keys", "YES"), ("Dynamic by default", if dYNAMIC_BY_DEFAULT dflags then "YES" else "NO"), ("GHC Dynamic", if dynamicGhc diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 02f731d3c2..c43064e7f1 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -7,15 +7,18 @@ {-# LANGUAGE CPP #-} module ErrUtils ( + MsgDoc, + Validity(..), andValid, allValid, isValid, getInvalids, + ErrMsg, WarnMsg, Severity(..), Messages, ErrorMessages, WarningMessages, errMsgSpan, errMsgContext, errMsgShortDoc, errMsgExtraInfo, - MsgDoc, mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc, + mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc, pprLocErrMsg, makeIntoWarning, - + errorsFound, emptyMessages, isEmptyMessages, mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg, - printBagOfErrors, + printBagOfErrors, warnIsErrorMsg, mkLongWarnMsg, ghcExit, @@ -46,7 +49,7 @@ import DynFlags import System.Directory import System.Exit ( ExitCode(..), exitWith ) -import System.FilePath +import System.FilePath ( takeDirectory, (</>) ) import Data.List import qualified Data.Set as Set import Data.IORef @@ -56,6 +59,29 @@ import Control.Monad import Control.Monad.IO.Class import System.IO +------------------------- +type MsgDoc = SDoc + +------------------------- +data Validity + = IsValid -- Everything is fine + | NotValid MsgDoc -- A problem, and some indication of why + +isValid :: Validity -> Bool +isValid IsValid = True +isValid (NotValid {}) = False + +andValid :: Validity -> Validity -> Validity +andValid IsValid v = v +andValid v _ = v + +allValid :: [Validity] -> Validity -- If they aren't all valid, return the first +allValid [] = IsValid +allValid (v : vs) = v `andValid` allValid vs + +getInvalids :: [Validity] -> [MsgDoc] +getInvalids vs = [d | NotValid d <- vs] + -- ----------------------------------------------------------------------------- -- Basic error messages: just render a message with a source location. @@ -74,7 +100,6 @@ data ErrMsg = ErrMsg { -- The SrcSpan is used for sorting errors into line-number order type WarnMsg = ErrMsg -type MsgDoc = SDoc data Severity = SevOutput diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index cbfd4e4f1c..f9c7e2eee0 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -43,13 +43,12 @@ import Maybes ( expectJust ) import Exception ( evaluate ) import Distribution.Text -import Distribution.Package hiding (PackageId) import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef ) import System.Directory import System.FilePath import Control.Monad -import Data.List ( partition ) import Data.Time +import Data.List ( foldl' ) type FileExt = String -- Filename extension @@ -80,12 +79,12 @@ flushFinderCaches hsc_env = do fc_ref = hsc_FC hsc_env mlc_ref = hsc_MLC hsc_env -flushModLocationCache :: PackageId -> IORef ModLocationCache -> IO () +flushModLocationCache :: PackageKey -> IORef ModLocationCache -> IO () flushModLocationCache this_pkg ref = do atomicModifyIORef ref $ \fm -> (filterModuleEnv is_ext fm, ()) _ <- evaluate =<< readIORef ref return () - where is_ext mod _ | modulePackageId mod /= this_pkg = True + where is_ext mod _ | modulePackageKey mod /= this_pkg = True | otherwise = False addToFinderCache :: IORef FinderCache -> ModuleName -> FindResult -> IO () @@ -148,7 +147,7 @@ findImportedModule hsc_env mod_name mb_pkg = findExactModule :: HscEnv -> Module -> IO FindResult findExactModule hsc_env mod = let dflags = hsc_dflags hsc_env - in if modulePackageId mod == thisPackage dflags + in if modulePackageKey mod == thisPackage dflags then findHomeModule hsc_env (moduleName mod) else findPackageModule hsc_env mod @@ -190,41 +189,21 @@ homeSearchCache hsc_env mod_name do_this = do findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult findExposedPackageModule hsc_env mod_name mb_pkg - -- not found in any package: - = case lookupModuleWithSuggestions (hsc_dflags hsc_env) mod_name of - Left suggest -> return (NotFound { fr_paths = [], fr_pkg = Nothing - , fr_pkgs_hidden = [] - , fr_mods_hidden = [] - , fr_suggestions = suggest }) - Right found - | null found_exposed -- Found, but with no exposed copies - -> return (NotFound { fr_paths = [], fr_pkg = Nothing - , fr_pkgs_hidden = pkg_hiddens - , fr_mods_hidden = mod_hiddens - , fr_suggestions = [] }) - - | [(pkg_conf,_)] <- found_exposed -- Found uniquely - -> let pkgid = packageConfigId pkg_conf in - findPackageModule_ hsc_env (mkModule pkgid mod_name) pkg_conf - - | otherwise -- Found in more than one place - -> return (FoundMultiple (map (packageConfigId.fst) found_exposed)) - where - for_this_pkg = case mb_pkg of - Nothing -> found - Just p -> filter ((`matches` p) . fst) found - found_exposed = filter is_exposed for_this_pkg - is_exposed (pkg_conf,exposed_mod) = exposed pkg_conf && exposed_mod - - mod_hiddens = [ packageConfigId pkg_conf - | (pkg_conf,False) <- found ] - - pkg_hiddens = [ packageConfigId pkg_conf - | (pkg_conf,_) <- found, not (exposed pkg_conf) ] - - pkg_conf `matches` pkg - = case packageName pkg_conf of - PackageName n -> pkg == mkFastString n + = case lookupModuleWithSuggestions (hsc_dflags hsc_env) mod_name mb_pkg of + LookupFound m pkg_conf -> + findPackageModule_ hsc_env m pkg_conf + LookupMultiple rs -> + return (FoundMultiple rs) + LookupHidden pkg_hiddens mod_hiddens -> + return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = map (modulePackageKey.fst) pkg_hiddens + , fr_mods_hidden = map (modulePackageKey.fst) mod_hiddens + , fr_suggestions = [] }) + LookupNotFound suggest -> + return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_suggestions = suggest }) modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult modLocationCache hsc_env mod do_this = do @@ -295,15 +274,22 @@ findPackageModule :: HscEnv -> Module -> IO FindResult findPackageModule hsc_env mod = do let dflags = hsc_dflags hsc_env - pkg_id = modulePackageId mod - pkg_map = pkgIdMap (pkgState dflags) + pkg_id = modulePackageKey mod -- - case lookupPackage pkg_map pkg_id of + case lookupPackage dflags pkg_id of Nothing -> return (NoPackage pkg_id) Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf +-- | Look up the interface file associated with module @mod@. This function +-- requires a few invariants to be upheld: (1) the 'Module' in question must +-- be the module identifier of the *original* implementation of a module, +-- not a reexport (this invariant is upheld by @Packages.lhs@) and (2) +-- the 'PackageConfig' must be consistent with the package key in the 'Module'. +-- The redundancy is to avoid an extra lookup in the package state +-- for the appropriate config. findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindResult findPackageModule_ hsc_env mod pkg_conf = + ASSERT( modulePackageKey mod == packageConfigId pkg_conf ) modLocationCache hsc_env mod $ -- special case for GHC.Prim; we won't find it in the filesystem. @@ -373,7 +359,7 @@ searchPathExts paths mod exts ] search [] = return (NotFound { fr_paths = map fst to_search - , fr_pkg = Just (modulePackageId mod) + , fr_pkg = Just (modulePackageKey mod) , fr_mods_hidden = [], fr_pkgs_hidden = [] , fr_suggestions = [] }) @@ -548,18 +534,38 @@ cannotFindInterface = cantFindErr (sLit "Failed to load interface for") cantFindErr :: LitString -> LitString -> DynFlags -> ModuleName -> FindResult -> SDoc -cantFindErr _ multiple_found _ mod_name (FoundMultiple pkgs) +cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) + | Just pkgs <- unambiguousPackages = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( sep [ptext (sLit "it was found in multiple packages:"), - hsep (map (text.packageIdString) pkgs)] + hsep (map ppr pkgs) ] ) + | otherwise + = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( + vcat (map pprMod mods) + ) + where + unambiguousPackages = foldl' unambiguousPackage (Just []) mods + unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) + = Just (modulePackageKey m : xs) + unambiguousPackage _ _ = Nothing + + pprMod (m, o) = ptext (sLit "it is bound as") <+> ppr m <+> + ptext (sLit "by") <+> pprOrigin m o + pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" + pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( + if e == Just True + then [ptext (sLit "package") <+> ppr (modulePackageKey m)] + else [] ++ + map ((ptext (sLit "a reexport in package") <+>) + .ppr.packageConfigId) res ++ + if f then [ptext (sLit "a package flag")] else [] + ) + cantFindErr cannot_find _ dflags mod_name find_result = ptext cannot_find <+> quotes (ppr mod_name) $$ more_info where - pkg_map :: PackageConfigMap - pkg_map = pkgIdMap (pkgState dflags) - more_info = case find_result of NoPackage pkg @@ -615,7 +621,7 @@ cantFindErr cannot_find _ dflags mod_name find_result <> dot $$ cabal_pkg_hidden_hint pkg cabal_pkg_hidden_hint pkg | gopt Opt_BuildingCabalPackage dflags - = case simpleParse (packageIdString pkg) of + = case simpleParse (packageKeyString pkg) of Just pid -> ptext (sLit "Perhaps you need to add") <+> quotes (text (display (pkgName pid))) <+> @@ -626,22 +632,40 @@ cantFindErr cannot_find _ dflags mod_name find_result mod_hidden pkg = ptext (sLit "it is a hidden module in the package") <+> quotes (ppr pkg) - pp_suggestions :: [Module] -> SDoc + pp_suggestions :: [ModuleSuggestion] -> SDoc pp_suggestions sugs | null sugs = empty | otherwise = hang (ptext (sLit "Perhaps you meant")) - 2 (vcat [ vcat (map pp_exp exposed_sugs) - , vcat (map pp_hid hidden_sugs) ]) - where - (exposed_sugs, hidden_sugs) = partition from_exposed_pkg sugs - - from_exposed_pkg m = case lookupPackage pkg_map (modulePackageId m) of - Just pkg_config -> exposed pkg_config - Nothing -> WARN( True, ppr m ) -- Should not happen - False - - pp_exp mod = ppr (moduleName mod) - <+> parens (ptext (sLit "from") <+> ppr (modulePackageId mod)) - pp_hid mod = ppr (moduleName mod) - <+> parens (ptext (sLit "needs flag -package") <+> ppr (modulePackageId mod)) + 2 (vcat (map pp_sugg sugs)) + + -- NB: Prefer the *original* location, and then reexports, and then + -- package flags when making suggestions. ToDo: if the original package + -- also has a reexport, prefer that one + pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o + where provenance ModHidden = empty + provenance (ModOrigin{ fromOrigPackage = e, + fromExposedReexport = res, + fromPackageFlag = f }) + | Just True <- e + = parens (ptext (sLit "from") <+> ppr (modulePackageKey mod)) + | f && moduleName mod == m + = parens (ptext (sLit "from") <+> ppr (modulePackageKey mod)) + | (pkg:_) <- res + = parens (ptext (sLit "from") <+> ppr (packageConfigId pkg) + <> comma <+> ptext (sLit "reexporting") <+> ppr mod) + | f + = parens (ptext (sLit "defined via package flags to be") + <+> ppr mod) + | otherwise = empty + pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o + where provenance ModHidden = empty + provenance (ModOrigin{ fromOrigPackage = e, + fromHiddenReexport = rhs }) + | Just False <- e + = parens (ptext (sLit "needs flag -package-key") + <+> ppr (modulePackageKey mod)) + | (pkg:_) <- rhs + = parens (ptext (sLit "needs flag -package-key") + <+> ppr (packageConfigId pkg)) + | otherwise = empty \end{code} diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 13d4f87009..9ab52ebf1d 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -81,7 +81,7 @@ module GHC ( SafeHaskellMode(..), -- * Querying the environment - packageDbModules, + -- packageDbModules, -- * Printing PrintUnqualified, alwaysQualify, @@ -133,10 +133,10 @@ module GHC ( -- * Abstract syntax elements -- ** Packages - PackageId, + PackageKey, -- ** Modules - Module, mkModule, pprModule, moduleName, modulePackageId, + Module, mkModule, pprModule, moduleName, modulePackageKey, ModuleName, mkModuleName, moduleNameString, -- ** Names @@ -534,7 +534,7 @@ checkBrokenTablesNextToCode' dflags -- flags. If you are not doing linking or doing static linking, you -- can ignore the list of packages returned. -- -setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageId] +setSessionDynFlags :: GhcMonad m => DynFlags -> m [PackageKey] setSessionDynFlags dflags = do (dflags', preload) <- liftIO $ initPackages dflags modifySession $ \h -> h{ hsc_dflags = dflags' @@ -543,7 +543,7 @@ setSessionDynFlags dflags = do return preload -- | Sets the program 'DynFlags'. -setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageId] +setProgramDynFlags :: GhcMonad m => DynFlags -> m [PackageKey] setProgramDynFlags dflags = do (dflags', preload) <- liftIO $ initPackages dflags modifySession $ \h -> h{ hsc_dflags = dflags' } @@ -1167,9 +1167,10 @@ getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env) -- ----------------------------------------------------------------------------- +{- ToDo: Move the primary logic here to compiler/main/Packages.lhs -- | Return all /external/ modules available in the package database. -- Modules from the current session (i.e., from the 'HomePackageTable') are --- not included. +-- not included. This includes module names which are reexported by packages. packageDbModules :: GhcMonad m => Bool -- ^ Only consider exposed packages. -> m [Module] @@ -1177,10 +1178,13 @@ packageDbModules only_exposed = do dflags <- getSessionDynFlags let pkgs = eltsUFM (pkgIdMap (pkgState dflags)) return $ - [ mkModule pid modname | p <- pkgs - , not only_exposed || exposed p - , let pid = packageConfigId p - , modname <- exposedModules p ] + [ mkModule pid modname + | p <- pkgs + , not only_exposed || exposed p + , let pid = packageConfigId p + , modname <- exposedModules p + ++ map exportName (reexportedModules p) ] + -} -- ----------------------------------------------------------------------------- -- Misc exported utils @@ -1301,7 +1305,7 @@ showRichTokenStream ts = go startLoc ts "" -- ----------------------------------------------------------------------------- -- Interactive evaluation --- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the +-- | Takes a 'ModuleName' and possibly a 'PackageKey', and consults the -- filesystem and package database to find the corresponding 'Module', -- using the algorithm that is used for an @import@ declaration. findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module @@ -1311,7 +1315,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do this_pkg = thisPackage dflags -- case maybe_pkg of - Just pkg | fsToPackageId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do + Just pkg | fsToPackageKey pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg case res of Found _ m -> return m @@ -1323,7 +1327,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do Nothing -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg case res of - Found loc m | modulePackageId m /= this_pkg -> return m + Found loc m | modulePackageKey m /= this_pkg -> return m | otherwise -> modNotLoadedError dflags m loc err -> throwOneError $ noModError dflags noSrcSpan mod_name err @@ -1368,7 +1372,7 @@ isModuleTrusted m = withSession $ \hsc_env -> liftIO $ hscCheckSafe hsc_env m noSrcSpan -- | Return if a module is trusted and the pkgs it depends on to be trusted. -moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [PackageId]) +moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [PackageKey]) moduleTrustReqs m = withSession $ \hsc_env -> liftIO $ hscGetSafe hsc_env m noSrcSpan diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 694778115d..0c63203d4c 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -63,6 +63,7 @@ import qualified Data.Set as Set import qualified FiniteMap as Map ( insertListWith ) import Control.Concurrent ( forkIOWithUnmask, killThread ) +import qualified GHC.Conc as CC import Control.Concurrent.MVar import Control.Concurrent.QSem import Control.Exception @@ -80,6 +81,11 @@ import System.IO.Error ( isDoesNotExistError ) import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities ) +label_self :: String -> IO () +label_self thread_name = do + self_tid <- CC.myThreadId + CC.labelThread self_tid thread_name + -- ----------------------------------------------------------------------------- -- Loading the program @@ -744,10 +750,18 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do | ((ms,mvar,_),idx) <- comp_graph_w_idx ] + liftIO $ label_self "main --make thread" -- For each module in the module graph, spawn a worker thread that will -- compile this module. let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) -> forkIOWithUnmask $ \unmask -> do + liftIO $ label_self $ unwords + [ "worker --make thread" + , "for module" + , show (moduleNameString (ms_mod_name mod)) + , "number" + , show mod_idx + ] -- Replace the default log_action with one that writes each -- message to the module's log_queue. The main thread will -- deal with synchronously printing these messages. @@ -1786,7 +1800,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) just_found location mod | otherwise -> -- Drop external-pkg - ASSERT(modulePackageId mod /= thisPackage dflags) + ASSERT(modulePackageKey mod /= thisPackage dflags) return Nothing err -> return $ Just $ Left $ noModError dflags loc wanted_mod err diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index aef6007fb7..15d67fc882 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -407,19 +407,20 @@ tcRnModule' hsc_env sum save_rn_syntax mod = do tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_res) dflags <- getDynFlags + let allSafeOK = safeInferred dflags && tcSafeOK - -- end of the Safe Haskell line, how to respond to user? - if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK) - -- if safe haskell off or safe infer failed, wipe trust - then wipeTrust tcg_res emptyBag + -- end of the safe haskell line, how to respond to user? + if not (safeHaskellOn dflags) || (safeInferOn dflags && not allSafeOK) + -- if safe Haskell off or safe infer failed, mark unsafe + then markUnsafe tcg_res emptyBag - -- module safe, throw warning if needed + -- module (could be) safe, throw warning if needed else do tcg_res' <- hscCheckSafeImports tcg_res safe <- liftIO $ readIORef (tcg_safeInfer tcg_res') when (safe && wopt Opt_WarnSafe dflags) - (logWarnings $ unitBag $ - mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ errSafe tcg_res') + (logWarnings $ unitBag $ mkPlainWarnMsg dflags + (warnSafeOnLoc dflags) $ errSafe tcg_res') return tcg_res' where pprMod t = ppr $ moduleName $ tcg_mod t @@ -773,16 +774,15 @@ hscCheckSafeImports tcg_env = do tcg_env' <- checkSafeImports dflags tcg_env case safeLanguageOn dflags of True -> do - -- we nuke user written RULES in -XSafe + -- XSafe: we nuke user written RULES logWarnings $ warns dflags (tcg_rules tcg_env') return tcg_env' { tcg_rules = [] } False - -- user defined RULES, so not safe or already unsafe - | safeInferOn dflags && not (null $ tcg_rules tcg_env') || - safeHaskell dflags == Sf_None - -> wipeTrust tcg_env' $ warns dflags (tcg_rules tcg_env') + -- SafeInferred: user defined RULES, so not safe + | safeInferOn dflags && not (null $ tcg_rules tcg_env') + -> markUnsafe tcg_env' $ warns dflags (tcg_rules tcg_env') - -- trustworthy OR safe inferred with no RULES + -- Trustworthy OR SafeInferred: with no RULES | otherwise -> return tcg_env' @@ -828,7 +828,7 @@ checkSafeImports dflags tcg_env True -> -- did we fail safe inference or fail -XSafe? case safeInferOn dflags of - True -> wipeTrust tcg_env errs + True -> markUnsafe tcg_env errs False -> liftIO . throwIO . mkSrcErr $ errs -- All good matey! @@ -842,14 +842,16 @@ checkSafeImports dflags tcg_env imp_info = tcg_imports tcg_env -- ImportAvails imports = imp_mods imp_info -- ImportedMods imports' = moduleEnvToList imports -- (Module, [ImportedModsVal]) - pkg_reqs = imp_trust_pkgs imp_info -- [PackageId] + pkg_reqs = imp_trust_pkgs imp_info -- [PackageKey] condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) condense (_, []) = panic "HscMain.condense: Pattern match failure!" condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs -- we turn all imports into safe ones when -- inference mode is on. - let s' = if safeInferOn dflags then True else s + let s' = if safeInferOn dflags && + safeHaskell dflags == Sf_None + then True else s return (m, l, s') -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) @@ -879,7 +881,7 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do return $ isEmptyBag errs -- | Return if a module is trusted and the pkgs it depends on to be trusted. -hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [PackageId]) +hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [PackageKey]) hscGetSafe hsc_env m l = runHsc hsc_env $ do dflags <- getDynFlags (self, pkgs) <- hscCheckSafe' dflags m l @@ -893,15 +895,15 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do -- Return (regardless of trusted or not) if the trust type requires the modules -- own package be trusted and a list of other packages required to be trusted -- (these later ones haven't been checked) but the own package trust has been. -hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId, [PackageId]) +hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageKey, [PackageKey]) hscCheckSafe' dflags m l = do (tw, pkgs) <- isModSafe m l case tw of False -> return (Nothing, pkgs) True | isHomePkg m -> return (Nothing, pkgs) - | otherwise -> return (Just $ modulePackageId m, pkgs) + | otherwise -> return (Just $ modulePackageKey m, pkgs) where - isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageId]) + isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageKey]) isModSafe m l = do iface <- lookup' m case iface of @@ -915,7 +917,7 @@ hscCheckSafe' dflags m l = do let trust = getSafeMode $ mi_trust iface' trust_own_pkg = mi_trust_pkg iface' -- check module is trusted - safeM = trust `elem` [Sf_SafeInferred, Sf_Safe, Sf_Trustworthy] + safeM = trust `elem` [Sf_Safe, Sf_Trustworthy] -- check package is trusted safeP = packageTrusted trust trust_own_pkg m -- pkg trust reqs @@ -930,13 +932,13 @@ hscCheckSafe' dflags m l = do return (trust == Sf_Trustworthy, pkgRs) where - pkgTrustErr = unitBag $ mkPlainErrMsg dflags l $ + pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" - , text "The package (" <> ppr (modulePackageId m) + , text "The package (" <> ppr (modulePackageKey m) <> text ") the module resides in isn't trusted." ] - modTrustErr = unitBag $ mkPlainErrMsg dflags l $ + modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The module itself isn't safe." ] @@ -951,11 +953,9 @@ hscCheckSafe' dflags m l = do packageTrusted _ _ _ | not (packageTrustOn dflags) = True packageTrusted Sf_Safe False _ = True - packageTrusted Sf_SafeInferred False _ = True packageTrusted _ _ m | isHomePkg m = True - | otherwise = trusted $ getPackageDetails (pkgState dflags) - (modulePackageId m) + | otherwise = trusted $ getPackageDetails dflags (modulePackageKey m) lookup' :: Module -> Hsc (Maybe ModIface) lookup' m = do @@ -979,11 +979,11 @@ hscCheckSafe' dflags m l = do isHomePkg :: Module -> Bool isHomePkg m - | thisPackage dflags == modulePackageId m = True + | thisPackage dflags == modulePackageKey m = True | otherwise = False -- | Check the list of packages are trusted. -checkPkgTrust :: DynFlags -> [PackageId] -> Hsc () +checkPkgTrust :: DynFlags -> [PackageKey] -> Hsc () checkPkgTrust dflags pkgs = case errors of [] -> return () @@ -991,19 +991,20 @@ checkPkgTrust dflags pkgs = where errors = catMaybes $ map go pkgs go pkg - | trusted $ getPackageDetails (pkgState dflags) pkg + | trusted $ getPackageDetails dflags pkg = Nothing | otherwise - = Just $ mkPlainErrMsg dflags noSrcSpan + = Just $ mkErrMsg dflags noSrcSpan (pkgQual dflags) $ text "The package (" <> ppr pkg <> text ") is required" <> text " to be trusted but it isn't!" --- | Set module to unsafe and wipe trust information. +-- | Set module to unsafe and (potentially) wipe trust information. -- -- Make sure to call this method to set a module to inferred unsafe, --- it should be a central and single failure method. -wipeTrust :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv -wipeTrust tcg_env whyUnsafe = do +-- it should be a central and single failure method. We only wipe the trust +-- information when we aren't in a specific Safe Haskell mode. +markUnsafe :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv +markUnsafe tcg_env whyUnsafe = do dflags <- getDynFlags when (wopt Opt_WarnUnsafe dflags) @@ -1011,7 +1012,12 @@ wipeTrust tcg_env whyUnsafe = do mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) liftIO $ writeIORef (tcg_safeInfer tcg_env) False - return $ tcg_env { tcg_imports = wiped_trust } + -- NOTE: Only wipe trust when not in an explicity safe haskell mode. Other + -- times inference may be on but we are in Trustworthy mode -- so we want + -- to record safe-inference failed but not wipe the trust dependencies. + case safeHaskell dflags == Sf_None of + True -> return $ tcg_env { tcg_imports = wiped_trust } + False -> return tcg_env where wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] } @@ -1021,7 +1027,7 @@ wipeTrust tcg_env whyUnsafe = do , nest 4 $ (vcat $ badFlags df) $+$ (vcat $ pprErrMsgBagWithLoc whyUnsafe) ] - badFlags df = concat $ map (badFlag df) unsafeFlags + badFlags df = concat $ map (badFlag df) unsafeFlagsForInfer badFlag df (str,loc,on,_) | on df = [mkLocMessage SevOutput (loc df) $ text str <+> text "is not allowed in Safe Haskell"] @@ -1368,7 +1374,7 @@ hscStmtWithLocation hsc_env0 stmt source linenumber = handleWarnings -- Then code-gen, and link it - -- It's important NOT to have package 'interactive' as thisPackageId + -- It's important NOT to have package 'interactive' as thisPackageKey -- for linking, else we try to link 'main' and can't find it. -- Whereas the linker already knows to ignore 'interactive' let src_span = srcLocSpan interactiveSrcLoc diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 9738f590b6..123b0777fc 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -54,6 +54,7 @@ module HscTypes ( setInteractivePrintName, icInteractiveModule, InteractiveImport(..), setInteractivePackage, mkPrintUnqualified, pprModulePrefix, + mkQualPackage, mkQualModule, pkgQual, -- * Interfaces ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache, @@ -443,7 +444,7 @@ instance Outputable TargetId where -- | Helps us find information about modules in the home package type HomePackageTable = ModuleNameEnv HomeModInfo -- Domain = modules in the home package that have been fully compiled - -- "home" package name cached here for convenience + -- "home" package key cached here for convenience -- | Helps us find information about modules in the imported packages type PackageIfaceTable = ModuleEnv ModIface @@ -634,26 +635,26 @@ type FinderCache = ModuleNameEnv FindResult data FindResult = Found ModLocation Module -- ^ The module was found - | NoPackage PackageId + | NoPackage PackageKey -- ^ The requested package was not found - | FoundMultiple [PackageId] + | FoundMultiple [(Module, ModuleOrigin)] -- ^ _Error_: both in multiple packages -- | Not found | NotFound { fr_paths :: [FilePath] -- Places where I looked - , fr_pkg :: Maybe PackageId -- Just p => module is in this package's + , fr_pkg :: Maybe PackageKey -- Just p => module is in this package's -- manifest, but couldn't find -- the .hi file - , fr_mods_hidden :: [PackageId] -- Module is in these packages, + , fr_mods_hidden :: [PackageKey] -- Module is in these packages, -- but the *module* is hidden - , fr_pkgs_hidden :: [PackageId] -- Module is in these packages, + , fr_pkgs_hidden :: [PackageKey] -- Module is in these packages, -- but the *package* is hidden - , fr_suggestions :: [Module] -- Possible mis-spelled modules + , fr_suggestions :: [ModuleSuggestion] -- Possible mis-spelled modules } -- | Cache that remembers where we found a particular module. Contains both @@ -995,8 +996,8 @@ data ModGuts mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment -- These fields all describe the things **declared in this module** - mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module - -- ToDo: I'm unconvinced this is actually used anywhere + mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module. + -- Used for creating interface files. mg_tcs :: ![TyCon], -- ^ TyCons declared in this module -- (includes TyCons for classes) mg_insts :: ![ClsInst], -- ^ Class instances declared in this module @@ -1067,7 +1068,7 @@ data CgGuts -- as part of the code-gen of tycons cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs - cg_dep_pkgs :: ![PackageId], -- ^ Dependent packages, used to + cg_dep_pkgs :: ![PackageKey], -- ^ Dependent packages, used to -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information cg_modBreaks :: !ModBreaks -- ^ Module breakpoints @@ -1100,13 +1101,13 @@ appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) Note [The interactive package] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Type and class declarations at the command prompt are treated as if -they were defined in modules +Type, class, and value declarations at the command prompt are treated +as if they were defined in modules interactive:Ghci1 interactive:Ghci2 ...etc... with each bunch of declarations using a new module, all sharing a -common package 'interactive' (see Module.interactivePackageId, and +common package 'interactive' (see Module.interactivePackageKey, and PrelNames.mkInteractiveModule). This scheme deals well with shadowing. For example: @@ -1138,7 +1139,7 @@ The details are a bit tricky though: extend the HPT. * The 'thisPackage' field of DynFlags is *not* set to 'interactive'. - It stays as 'main' (or whatever -package-name says), and is the + It stays as 'main' (or whatever -this-package-key says), and is the package to which :load'ed modules are added to. * So how do we arrange that declarations at the command prompt get @@ -1148,14 +1149,15 @@ The details are a bit tricky though: turn get the module from it 'icInteractiveModule' field of the interactive context. - The 'thisPackage' field stays as 'main' (or whatever -package-name says. + The 'thisPackage' field stays as 'main' (or whatever -this-package-key says. * The main trickiness is that the type environment (tcg_type_env and - fixity envt (tcg_fix_env) now contains entities from all the - GhciN modules together, rather than just a single module as is usually - the case. So you can't use "nameIsLocalOrFrom" to decide whether - to look in the TcGblEnv vs the HPT/PTE. This is a change, but not - a problem provided you know. + fixity envt (tcg_fix_env), and instances (tcg_insts, tcg_fam_insts) + now contains entities from all the interactive-package modules + (Ghci1, Ghci2, ...) together, rather than just a single module as + is usually the case. So you can't use "nameIsLocalOrFrom" to + decide whether to look in the TcGblEnv vs the HPT/PTE. This is a + change, but not a problem provided you know. Note [Interactively-bound Ids in GHCi] @@ -1341,7 +1343,7 @@ extendInteractiveContext ictxt new_tythings setInteractivePackage :: HscEnv -> HscEnv -- Set the 'thisPackage' DynFlag to 'interactive' setInteractivePackage hsc_env - = hsc_env { hsc_dflags = (hsc_dflags hsc_env) { thisPackage = interactivePackageId } } + = hsc_env { hsc_dflags = (hsc_dflags hsc_env) { thisPackage = interactivePackageKey } } setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext setInteractivePrintName ic n = ic{ic_int_print = n} @@ -1408,11 +1410,28 @@ exposed (say P2), so we use M.T for that, and P1:M.T for the other one. This is handled by the qual_mod component of PrintUnqualified, inside the (ppr mod) of case (3), in Name.pprModulePrefix +Note [Printing package keys] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the old days, original names were tied to PackageIds, which directly +corresponded to the entities that users wrote in Cabal files, and were perfectly +suitable for printing when we need to disambiguate packages. However, with +PackageKey, the situation is different. First, the key is not a human readable +at all, so we need to consult the package database to find the appropriate +PackageId to display. Second, there may be multiple copies of a library visible +with the same PackageId, in which case we need to disambiguate. For now, +we just emit the actual package key (which the user can go look up); however, +another scheme is to (recursively) say which dependencies are different. + +NB: When we extend package keys to also have holes, we will have to disambiguate +those as well. + \begin{code} -- | Creates some functions that work out the best ways to format --- names for the user according to a set of heuristics +-- names for the user according to a set of heuristics. mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified -mkPrintUnqualified dflags env = (qual_name, qual_mod) +mkPrintUnqualified dflags env = QueryQualify qual_name + (mkQualModule dflags) + (mkQualPackage dflags) where qual_name mod occ | [gre] <- unqual_gres @@ -1445,18 +1464,48 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod) -- "import M" would resolve unambiguously to P:M. (if P is the -- current package we can just assume it is unqualified). - qual_mod mod - | modulePackageId mod == thisPackage dflags = False +-- | Creates a function for formatting modules based on two heuristics: +-- (1) if the module is the current module, don't qualify, and (2) if there +-- is only one exposed package which exports this module, don't qualify. +mkQualModule :: DynFlags -> QueryQualifyModule +mkQualModule dflags mod + | modulePackageKey mod == thisPackage dflags = False - | [pkgconfig] <- [pkg | (pkg,exposed_module) <- lookup, - exposed pkg && exposed_module], - packageConfigId pkgconfig == modulePackageId mod + | [(_, pkgconfig)] <- lookup, + packageConfigId pkgconfig == modulePackageKey mod -- this says: we are given a module P:M, is there just one exposed package -- that exposes a module M, and is it package P? = False | otherwise = True where lookup = lookupModuleInAllPackages dflags (moduleName mod) + +-- | Creates a function for formatting packages based on two heuristics: +-- (1) don't qualify if the package in question is "main", and (2) only qualify +-- with a package key if the package ID would be ambiguous. +mkQualPackage :: DynFlags -> QueryQualifyPackage +mkQualPackage dflags pkg_key + | pkg_key == mainPackageKey + -- Skip the lookup if it's main, since it won't be in the package + -- database! + = False + | searchPackageId dflags pkgid `lengthIs` 1 + -- this says: we are given a package pkg-0.1@MMM, are there only one + -- exposed packages whose package ID is pkg-0.1? + = False + | otherwise + = True + where pkg = fromMaybe (pprPanic "qual_pkg" (ftext (packageKeyFS pkg_key))) + (lookupPackage dflags pkg_key) + pkgid = sourcePackageId pkg + +-- | A function which only qualifies package names if necessary; but +-- qualifies all other identifiers. +pkgQual :: DynFlags -> PrintUnqualified +pkgQual dflags = alwaysQualify { + queryQualifyPackage = mkQualPackage dflags + } + \end{code} @@ -1904,7 +1953,7 @@ data Dependencies -- I.e. modules that this one imports, or that are in the -- dep_mods of those directly-imported modules - , dep_pkgs :: [(PackageId, Bool)] + , dep_pkgs :: [(PackageKey, Bool)] -- ^ All packages transitively below this module -- I.e. packages to which this module's direct imports belong, -- or that are in the dep_pkgs of those modules @@ -2493,14 +2542,15 @@ trustInfoToNum it Sf_Unsafe -> 1 Sf_Trustworthy -> 2 Sf_Safe -> 3 - Sf_SafeInferred -> 4 numToTrustInfo :: Word8 -> IfaceTrustInfo numToTrustInfo 0 = setSafeMode Sf_None numToTrustInfo 1 = setSafeMode Sf_Unsafe numToTrustInfo 2 = setSafeMode Sf_Trustworthy numToTrustInfo 3 = setSafeMode Sf_Safe -numToTrustInfo 4 = setSafeMode Sf_SafeInferred +numToTrustInfo 4 = setSafeMode Sf_Safe -- retained for backwards compat, used + -- to be Sf_SafeInfered but we no longer + -- differentiate. numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" instance Outputable IfaceTrustInfo where @@ -2508,7 +2558,6 @@ instance Outputable IfaceTrustInfo where ppr (TrustInfo Sf_Unsafe) = ptext $ sLit "unsafe" ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy" ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe" - ppr (TrustInfo Sf_SafeInferred) = ptext $ sLit "safe-inferred" instance Binary IfaceTrustInfo where put_ bh iftrust = putByte bh $ trustInfoToNum iftrust diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index cfcc076235..d60cf56eba 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -879,7 +879,7 @@ getContext = withSession $ \HscEnv{ hsc_IC=ic } -> -- its full top-level scope available. moduleIsInterpreted :: GhcMonad m => Module -> m Bool moduleIsInterpreted modl = withSession $ \h -> - if modulePackageId modl /= thisPackage (hsc_dflags h) + if modulePackageKey modl /= thisPackage (hsc_dflags h) then return False else case lookupUFM (hsc_HPT h) (moduleName modl) of Just details -> return (isJust (mi_globals (hm_iface details))) diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs index 514a2e004f..864980be9d 100644 --- a/compiler/main/PackageConfig.hs +++ b/compiler/main/PackageConfig.hs @@ -9,8 +9,8 @@ module PackageConfig ( -- $package_naming - -- * PackageId - mkPackageId, packageConfigId, + -- * PackageKey + mkPackageKey, packageConfigId, -- * The PackageConfig type: information about a package PackageConfig, @@ -26,7 +26,8 @@ module PackageConfig ( import Distribution.InstalledPackageInfo import Distribution.ModuleName -import Distribution.Package hiding (PackageId) +import Distribution.Package hiding (PackageKey, mkPackageKey) +import qualified Distribution.Package as Cabal import Distribution.Text import Distribution.Version @@ -43,31 +44,33 @@ defaultPackageConfig :: PackageConfig defaultPackageConfig = emptyInstalledPackageInfo -- ----------------------------------------------------------------------------- --- PackageId (package names with versions) +-- PackageKey (package names, versions and dep hash) -- $package_naming -- #package_naming# --- Mostly the compiler deals in terms of 'PackageId's, which have the --- form @<pkg>-<version>@. You're expected to pass in the version for --- the @-package-name@ flag. However, for wired-in packages like @base@ --- & @rts@, we don't necessarily know what the version is, so these are --- handled specially; see #wired_in_packages#. +-- Mostly the compiler deals in terms of 'PackageKey's, which are md5 hashes +-- of a package ID, keys of its dependencies, and Cabal flags. You're expected +-- to pass in the package key in the @-this-package-key@ flag. However, for +-- wired-in packages like @base@ & @rts@, we don't necessarily know what the +-- version is, so these are handled specially; see #wired_in_packages#. --- | Turn a Cabal 'PackageIdentifier' into a GHC 'PackageId' -mkPackageId :: PackageIdentifier -> PackageId -mkPackageId = stringToPackageId . display +-- | Turn a Cabal 'PackageIdentifier' into a GHC 'PackageKey' +mkPackageKey :: Cabal.PackageKey -> PackageKey +mkPackageKey = stringToPackageKey . display --- | Get the GHC 'PackageId' right out of a Cabalish 'PackageConfig' -packageConfigId :: PackageConfig -> PackageId -packageConfigId = mkPackageId . sourcePackageId +-- | Get the GHC 'PackageKey' right out of a Cabalish 'PackageConfig' +packageConfigId :: PackageConfig -> PackageKey +packageConfigId = mkPackageKey . packageKey -- | Turn a 'PackageConfig', which contains GHC 'Module.ModuleName's into a Cabal specific -- 'InstalledPackageInfo' which contains Cabal 'Distribution.ModuleName.ModuleName's packageConfigToInstalledPackageInfo :: PackageConfig -> InstalledPackageInfo packageConfigToInstalledPackageInfo (pkgconf@(InstalledPackageInfo { exposedModules = e, + reexportedModules = r, hiddenModules = h })) = pkgconf{ exposedModules = map convert e, + reexportedModules = map (fmap convert) r, hiddenModules = map convert h } where convert :: Module.ModuleName -> Distribution.ModuleName.ModuleName convert = (expectJust "packageConfigToInstalledPackageInfo") . simpleParse . moduleNameString @@ -77,7 +80,9 @@ packageConfigToInstalledPackageInfo installedPackageInfoToPackageConfig :: InstalledPackageInfo_ String -> PackageConfig installedPackageInfoToPackageConfig (pkgconf@(InstalledPackageInfo { exposedModules = e, + reexportedModules = r, hiddenModules = h })) = pkgconf{ exposedModules = map mkModuleName e, + reexportedModules = map (fmap mkModuleName) r, hiddenModules = map mkModuleName h } diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index bb2e048cc3..78c8059046 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -2,21 +2,29 @@ % (c) The University of Glasgow, 2006 % \begin{code} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} -- | Package manipulation module Packages ( module PackageConfig, - -- * The PackageConfigMap - PackageConfigMap, emptyPackageConfigMap, lookupPackage, - extendPackageConfigMap, dumpPackages, simpleDumpPackages, - -- * Reading the package config, and processing cmdline args - PackageState(..), + PackageState(preloadPackages), initPackages, + + -- * Querying the package config + lookupPackage, + resolveInstalledPackageId, + searchPackageId, + dumpPackages, + simpleDumpPackages, getPackageDetails, - lookupModuleInAllPackages, lookupModuleWithSuggestions, + listVisibleModuleNames, + lookupModuleInAllPackages, + lookupModuleWithSuggestions, + LookupResult(..), + ModuleSuggestion(..), + ModuleOrigin(..), -- * Inspecting the set of packages in scope getPackageIncludePath, @@ -29,8 +37,12 @@ module Packages ( collectIncludeDirs, collectLibraryPaths, collectLinkOpts, packageHsLibs, + ModuleExport(..), -- * Utils + packageKeyPackageIdString, + pprFlag, + pprModuleMap, isDllName ) where @@ -51,10 +63,12 @@ import Maybes import System.Environment ( getEnv ) import Distribution.InstalledPackageInfo import Distribution.InstalledPackageInfo.Binary -import Distribution.Package hiding (PackageId,depends) +import Distribution.Package hiding (depends, PackageKey, mkPackageKey) +import Distribution.ModuleExport import FastString import ErrUtils ( debugTraceMsg, putMsg, MsgDoc ) import Exception +import Unique import System.Directory import System.FilePath as FilePath @@ -63,6 +77,7 @@ import Control.Monad import Data.Char (isSpace) import Data.List as List import Data.Map (Map) +import Data.Monoid hiding ((<>)) import qualified Data.Map as Map import qualified FiniteMap as Map import qualified Data.Set as Set @@ -75,12 +90,18 @@ import qualified Data.Set as Set -- provide. -- -- The package state is computed by 'initPackages', and kept in DynFlags. +-- It is influenced by various package flags: -- --- * @-package <pkg>@ causes @<pkg>@ to become exposed, and all other packages --- with the same name to become hidden. +-- * @-package <pkg>@ and @-package-id <pkg>@ cause @<pkg>@ to become exposed. +-- If @-hide-all-packages@ was not specified, these commands also cause +-- all other packages with the same name to become hidden. -- -- * @-hide-package <pkg>@ causes @<pkg>@ to become hidden. -- +-- * (there are a few more flags, check below for their semantics) +-- +-- The package state has the following properties. +-- -- * Let @exposedPackages@ be the set of packages thus exposed. -- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of -- their dependencies. @@ -109,39 +130,166 @@ import qualified Data.Set as Set -- When compiling A, we record in B's Module value whether it's -- in a different DLL, by setting the DLL flag. -data PackageState = PackageState { - pkgIdMap :: PackageConfigMap, -- PackageId -> PackageConfig - -- The exposed flags are adjusted according to -package and - -- -hide-package flags, and -ignore-package removes packages. - - preloadPackages :: [PackageId], - -- The packages we're going to link in eagerly. This list - -- should be in reverse dependency order; that is, a package - -- is always mentioned before the packages it depends on. - - moduleToPkgConfAll :: UniqFM [(PackageConfig,Bool)], -- ModuleEnv mapping - -- Derived from pkgIdMap. - -- Maps Module to (pkgconf,exposed), where pkgconf is the - -- PackageConfig for the package containing the module, and - -- exposed is True if the package exposes that module. +-- | Given a module name, there may be multiple ways it came into scope, +-- possibly simultaneously. This data type tracks all the possible ways +-- it could have come into scope. Warning: don't use the record functions, +-- they're partial! +data ModuleOrigin = + -- | Module is hidden, and thus never will be available for import. + -- (But maybe the user didn't realize), so we'll still keep track + -- of these modules.) + ModHidden + -- | Module is public, and could have come from some places. + | ModOrigin { + -- | @Just False@ means that this module is in + -- someone's @exported-modules@ list, but that package is hidden; + -- @Just True@ means that it is available; @Nothing@ means neither + -- applies. + fromOrigPackage :: Maybe Bool + -- | Is the module available from a reexport of an exposed package? + -- There could be multiple. + , fromExposedReexport :: [PackageConfig] + -- | Is the module available from a reexport of a hidden package? + , fromHiddenReexport :: [PackageConfig] + -- | Did the module export come from a package flag? (ToDo: track + -- more information. + , fromPackageFlag :: Bool + } + +instance Outputable ModuleOrigin where + ppr ModHidden = text "hidden module" + ppr (ModOrigin e res rhs f) = sep (punctuate comma ( + (case e of + Nothing -> [] + Just False -> [text "hidden package"] + Just True -> [text "exposed package"]) ++ + (if null res + then [] + else [text "reexport by" <+> + sep (map (ppr . packageConfigId) res)]) ++ + (if null rhs + then [] + else [text "hidden reexport by" <+> + sep (map (ppr . packageConfigId) res)]) ++ + (if f then [text "package flag"] else []) + )) + +-- | Smart constructor for a module which is in @exposed-modules@. Takes +-- as an argument whether or not the defining package is exposed. +fromExposedModules :: Bool -> ModuleOrigin +fromExposedModules e = ModOrigin (Just e) [] [] False + +-- | Smart constructor for a module which is in @reexported-modules@. Takes +-- as an argument whether or not the reexporting package is expsed, and +-- also its 'PackageConfig'. +fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin +fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False +fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False + +-- | Smart constructor for a module which was bound by a package flag. +fromFlag :: ModuleOrigin +fromFlag = ModOrigin Nothing [] [] True + +instance Monoid ModuleOrigin where + mempty = ModOrigin Nothing [] [] False + mappend (ModOrigin e res rhs f) (ModOrigin e' res' rhs' f') = + ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') + where g (Just b) (Just b') + | b == b' = Just b + | otherwise = panic "ModOrigin: package both exposed/hidden" + g Nothing x = x + g x Nothing = x + mappend _ _ = panic "ModOrigin: hidden module redefined" + +-- | Is the name from the import actually visible? (i.e. does it cause +-- ambiguity, or is it only relevant when we're making suggestions?) +originVisible :: ModuleOrigin -> Bool +originVisible ModHidden = False +originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f + +-- | Are there actually no providers for this module? This will never occur +-- except when we're filtering based on package imports. +originEmpty :: ModuleOrigin -> Bool +originEmpty (ModOrigin Nothing [] [] False) = True +originEmpty _ = False + +-- | When we do a plain lookup (e.g. for an import), initially, all we want +-- to know is if we can find it or not (and if we do and it's a reexport, +-- what the real name is). If the find fails, we'll want to investigate more +-- to give a good error message. +data SimpleModuleConf = + SModConf Module PackageConfig ModuleOrigin + | SModConfAmbiguous + +-- | 'UniqFM' map from 'ModuleName' +type ModuleNameMap = UniqFM + +-- | 'UniqFM' map from 'PackageKey' +type PackageKeyMap = UniqFM + +-- | 'UniqFM' map from 'PackageKey' to 'PackageConfig' +type PackageConfigMap = PackageKeyMap PackageConfig + +-- | 'UniqFM' map from 'PackageKey' to (1) whether or not all modules which +-- are exposed should be dumped into scope, (2) any custom renamings that +-- should also be apply, and (3) what package name is associated with the +-- key, if it might be hidden +type VisibilityMap = + PackageKeyMap (Bool, [(ModuleName, ModuleName)], FastString) + +-- | Map from 'ModuleName' to 'Module' to all the origins of the bindings +-- in scope. The 'PackageConf' is not cached, mostly for convenience reasons +-- (since this is the slow path, we'll just look it up again). +type ModuleToPkgConfAll = + Map ModuleName (Map Module ModuleOrigin) +data PackageState = PackageState { + -- | A mapping of 'PackageKey' to 'PackageConfig'. This list is adjusted + -- so that only valid packages are here. Currently, we also flip the + -- exposed/trusted bits based on package flags; however, the hope is to + -- stop doing that. + pkgIdMap :: PackageConfigMap, + + -- | The packages we're going to link in eagerly. This list + -- should be in reverse dependency order; that is, a package + -- is always mentioned before the packages it depends on. + preloadPackages :: [PackageKey], + + -- | This is a simplified map from 'ModuleName' to original 'Module' and + -- package configuration providing it. + moduleToPkgConf :: ModuleNameMap SimpleModuleConf, + + -- | This is a full map from 'ModuleName' to all modules which may possibly + -- be providing it. These providers may be hidden (but we'll still want + -- to report them in error messages), or it may be an ambiguous import. + moduleToPkgConfAll :: ModuleToPkgConfAll, + + -- | This is a map from 'InstalledPackageId' to 'PackageKey', since GHC + -- internally deals in package keys but the database may refer to installed + -- package IDs. installedPackageIdMap :: InstalledPackageIdMap } --- | A PackageConfigMap maps a 'PackageId' to a 'PackageConfig' -type PackageConfigMap = UniqFM PackageConfig - -type InstalledPackageIdMap = Map InstalledPackageId PackageId - +type InstalledPackageIdMap = Map InstalledPackageId PackageKey type InstalledPackageIndex = Map InstalledPackageId PackageConfig +-- | Empty package configuration map emptyPackageConfigMap :: PackageConfigMap emptyPackageConfigMap = emptyUFM --- | Find the package we know about with the given id (e.g. \"foo-1.0\"), if any -lookupPackage :: PackageConfigMap -> PackageId -> Maybe PackageConfig -lookupPackage = lookupUFM +-- | Find the package we know about with the given key (e.g. @foo_HASH@), if any +lookupPackage :: DynFlags -> PackageKey -> Maybe PackageConfig +lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags)) + +lookupPackage' :: PackageConfigMap -> PackageKey -> Maybe PackageConfig +lookupPackage' = lookupUFM + +-- | Search for packages with a given package ID (e.g. \"foo-0.1\") +searchPackageId :: DynFlags -> PackageId -> [PackageConfig] +searchPackageId dflags pid = filter ((pid ==) . sourcePackageId) + (listPackageConfigMap dflags) +-- | Extends the package configuration map with a list of package configs. extendPackageConfigMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap extendPackageConfigMap pkg_map new_pkgs @@ -150,8 +298,20 @@ extendPackageConfigMap pkg_map new_pkgs -- | Looks up the package with the given id in the package state, panicing if it is -- not found -getPackageDetails :: PackageState -> PackageId -> PackageConfig -getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdMap ps) pid) +getPackageDetails :: DynFlags -> PackageKey -> PackageConfig +getPackageDetails dflags pid = + expectJust "getPackageDetails" (lookupPackage dflags pid) + +-- | Get a list of entries from the package database. NB: be careful with +-- this function, it may not do what you expect it to. +listPackageConfigMap :: DynFlags -> [PackageConfig] +listPackageConfigMap dflags = eltsUFM (pkgIdMap (pkgState dflags)) + +-- | Looks up a 'PackageKey' given an 'InstalledPackageId' +resolveInstalledPackageId :: DynFlags -> InstalledPackageId -> PackageKey +resolveInstalledPackageId dflags ipid = + expectJust "resolveInstalledPackageId" + (Map.lookup ipid (installedPackageIdMap (pkgState dflags))) -- ---------------------------------------------------------------------------- -- Loading the package db files and building up the package state @@ -169,7 +329,7 @@ getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdM -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'pkgState' in 'DynFlags' and return a list of packages to -- link in. -initPackages :: DynFlags -> IO (DynFlags, [PackageId]) +initPackages :: DynFlags -> IO (DynFlags, [PackageKey]) initPackages dflags = do pkg_db <- case pkgDatabase dflags of Nothing -> readPackageConfigs dflags @@ -251,17 +411,12 @@ readPackageConfig dflags conf_file = do return pkg_configs2 setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig] -setBatchPackageFlags dflags pkgs = (maybeDistrustAll . maybeHideAll) pkgs +setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs where - maybeHideAll pkgs' - | gopt Opt_HideAllPackages dflags = map hide pkgs' - | otherwise = pkgs' - maybeDistrustAll pkgs' | gopt Opt_DistrustAllPackages dflags = map distrust pkgs' | otherwise = pkgs' - hide pkg = pkg{ exposed = False } distrust pkg = pkg{ trusted = False } -- TODO: This code is duplicated in utils/ghc-pkg/Main.hs @@ -318,75 +473,88 @@ mungePackagePaths top_dir pkgroot pkg = -- Modify our copy of the package database based on a package flag -- (-package, -hide-package, -ignore-package). +-- | A horrible hack, the problem is the package key we'll turn +-- up here is going to get edited when we select the wired in +-- packages, so preemptively pick up the right one. Also, this elem +-- test is slow. The alternative is to change wired in packages first, but +-- then we are no longer able to match against package keys e.g. from when +-- a user passes in a package flag. +calcKey :: PackageConfig -> PackageKey +calcKey p | pk <- display (pkgName (sourcePackageId p)) + , pk `elem` wired_in_pkgids + = stringToPackageKey pk + | otherwise = packageConfigId p + applyPackageFlag :: DynFlags -> UnusablePackages - -> [PackageConfig] -- Initial database + -> ([PackageConfig], VisibilityMap) -- Initial database -> PackageFlag -- flag to apply - -> IO [PackageConfig] -- new database + -> IO ([PackageConfig], VisibilityMap) -- new database -applyPackageFlag dflags unusable pkgs flag = - case flag of - ExposePackage str -> - case selectPackages (matchingStr str) pkgs unusable of - Left ps -> packageFlagErr dflags flag ps - Right (p:ps,qs) -> return (p':ps') - where p' = p {exposed=True} - ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) - _ -> panic "applyPackageFlag" +-- ToDo: Unfortunately, we still have to plumb the package config through, +-- because Safe Haskell trust is still implemented by modifying the database. +-- Eventually, track that separately and then axe @[PackageConfig]@ from +-- this fold entirely - ExposePackageId str -> - case selectPackages (matchingId str) pkgs unusable of +applyPackageFlag dflags unusable (pkgs, vm) flag = + case flag of + ExposePackage arg m_rns -> + case selectPackages (matching arg) pkgs unusable of Left ps -> packageFlagErr dflags flag ps - Right (p:ps,qs) -> return (p':ps') - where p' = p {exposed=True} - ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) + Right (p:_,_) -> return (pkgs, vm') + where + n = fsPackageName p + vm' = addToUFM_C edit vm_cleared (calcKey p) + (case m_rns of + Nothing -> (True, [], n) + Just rns' -> (False, map convRn rns', n)) + edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n) + convRn (a,b) = (mkModuleName a, mkModuleName b) + -- ToDo: ATM, -hide-all-packages implicitly triggers change in + -- behavior, maybe eventually make it toggleable with a separate + -- flag + vm_cleared | gopt Opt_HideAllPackages dflags = vm + -- NB: -package foo-0.1 (Foo as Foo1) does NOT hide + -- other versions of foo. Presence of renaming means + -- user probably wanted both. + | Just _ <- m_rns = vm + | otherwise = filterUFM_Directly + (\k (_,_,n') -> k == getUnique (calcKey p) + || n /= n') vm _ -> panic "applyPackageFlag" HidePackage str -> case selectPackages (matchingStr str) pkgs unusable of Left ps -> packageFlagErr dflags flag ps - Right (ps,qs) -> return (map hide ps ++ qs) - where hide p = p {exposed=False} + Right (ps,_) -> return (pkgs, vm') + where vm' = delListFromUFM vm (map calcKey ps) -- we trust all matching packages. Maybe should only trust first one? -- and leave others the same or set them untrusted TrustPackage str -> case selectPackages (matchingStr str) pkgs unusable of Left ps -> packageFlagErr dflags flag ps - Right (ps,qs) -> return (map trust ps ++ qs) + Right (ps,qs) -> return (map trust ps ++ qs, vm) where trust p = p {trusted=True} DistrustPackage str -> case selectPackages (matchingStr str) pkgs unusable of Left ps -> packageFlagErr dflags flag ps - Right (ps,qs) -> return (map distrust ps ++ qs) + Right (ps,qs) -> return (map distrust ps ++ qs, vm) where distrust p = p {trusted=False} - _ -> panic "applyPackageFlag" - - where - -- When a package is requested to be exposed, we hide all other - -- packages with the same name. - hideAll name ps = map maybe_hide ps - where maybe_hide p - | pkgName (sourcePackageId p) == name = p {exposed=False} - | otherwise = p - + IgnorePackage _ -> panic "applyPackageFlag: IgnorePackage" selectPackages :: (PackageConfig -> Bool) -> [PackageConfig] -> UnusablePackages -> Either [(PackageConfig, UnusablePackageReason)] ([PackageConfig], [PackageConfig]) selectPackages matches pkgs unusable - = let - (ps,rest) = partition matches pkgs - reasons = [ (p, Map.lookup (installedPackageId p) unusable) - | p <- ps ] - in - if all (isJust.snd) reasons - then Left [ (p, reason) | (p,Just reason) <- reasons ] - else Right (sortByVersion [ p | (p,Nothing) <- reasons ], rest) + = let (ps,rest) = partition matches pkgs + in if null ps + then Left (filter (matches.fst) (Map.elems unusable)) + else Right (sortByVersion ps, rest) -- A package named on the command line can either include the -- version, or just the name if it is unambiguous. @@ -398,6 +566,14 @@ matchingStr str p matchingId :: String -> PackageConfig -> Bool matchingId str p = InstalledPackageId str == installedPackageId p +matchingKey :: String -> PackageConfig -> Bool +matchingKey str p = str == display (packageKey p) + +matching :: PackageArg -> PackageConfig -> Bool +matching (PackageArg str) = matchingStr str +matching (PackageIdArg str) = matchingId str +matching (PackageKeyArg str) = matchingKey str + sortByVersion :: [InstalledPackageInfo_ m] -> [InstalledPackageInfo_ m] sortByVersion = sortBy (flip (comparing (pkgVersion.sourcePackageId))) @@ -411,7 +587,8 @@ packageFlagErr :: DynFlags -- for missing DPH package we emit a more helpful error message, because -- this may be the result of using -fdph-par or -fdph-seq. -packageFlagErr dflags (ExposePackage pkg) [] | is_dph_package pkg +packageFlagErr dflags (ExposePackage (PackageArg pkg) _) [] + | is_dph_package pkg = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err)) where dph_err = text "the " <> text pkg <> text " package is not installed." $$ text "To install it: \"cabal install dph\"." @@ -419,50 +596,37 @@ packageFlagErr dflags (ExposePackage pkg) [] | is_dph_package pkg packageFlagErr dflags flag reasons = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err)) - where err = text "cannot satisfy " <> ppr_flag <> + where err = text "cannot satisfy " <> pprFlag flag <> (if null reasons then empty else text ": ") $$ nest 4 (ppr_reasons $$ + -- ToDo: this admonition seems a bit dodgy text "(use -v for more information)") - ppr_flag = case flag of - IgnorePackage p -> text "-ignore-package " <> text p - HidePackage p -> text "-hide-package " <> text p - ExposePackage p -> text "-package " <> text p - ExposePackageId p -> text "-package-id " <> text p - TrustPackage p -> text "-trust " <> text p - DistrustPackage p -> text "-distrust " <> text p ppr_reasons = vcat (map ppr_reason reasons) ppr_reason (p, reason) = pprReason (pprIPkg p <+> text "is") reason --- ----------------------------------------------------------------------------- --- Hide old versions of packages - --- --- hide all packages for which there is also a later version --- that is already exposed. This just makes it non-fatal to have two --- versions of a package exposed, which can happen if you install a --- later version of a package in the user database, for example. --- -hideOldPackages :: DynFlags -> [PackageConfig] -> IO [PackageConfig] -hideOldPackages dflags pkgs = mapM maybe_hide pkgs - where maybe_hide p - | not (exposed p) = return p - | (p' : _) <- later_versions = do - debugTraceMsg dflags 2 $ - (ptext (sLit "hiding package") <+> pprSPkg p <+> - ptext (sLit "to avoid conflict with later version") <+> - pprSPkg p') - return (p {exposed=False}) - | otherwise = return p - where myname = pkgName (sourcePackageId p) - myversion = pkgVersion (sourcePackageId p) - later_versions = [ p | p <- pkgs, exposed p, - let pkg = sourcePackageId p, - pkgName pkg == myname, - pkgVersion pkg > myversion ] +pprFlag :: PackageFlag -> SDoc +pprFlag flag = case flag of + IgnorePackage p -> text "-ignore-package " <> text p + HidePackage p -> text "-hide-package " <> text p + ExposePackage a rns -> ppr_arg a <> ppr_rns rns + TrustPackage p -> text "-trust " <> text p + DistrustPackage p -> text "-distrust " <> text p + where ppr_arg arg = case arg of + PackageArg p -> text "-package " <> text p + PackageIdArg p -> text "-package-id " <> text p + PackageKeyArg p -> text "-package-key " <> text p + ppr_rns Nothing = empty + ppr_rns (Just rns) = char '(' <> hsep (punctuate comma (map ppr_rn rns)) + <> char ')' + ppr_rn (orig, new) | orig == new = text orig + | otherwise = text orig <+> text "as" <+> text new -- ----------------------------------------------------------------------------- -- Wired-in packages +wired_in_pkgids :: [String] +wired_in_pkgids = map packageKeyString wiredInPackageKeys + findWiredInPackages :: DynFlags -> [PackageConfig] -- database @@ -474,16 +638,6 @@ findWiredInPackages dflags pkgs = do -- their canonical names (eg. base-1.0 ==> base). -- let - wired_in_pkgids :: [String] - wired_in_pkgids = map packageIdString - [ primPackageId, - integerPackageId, - basePackageId, - rtsPackageId, - thPackageId, - dphSeqPackageId, - dphParPackageId ] - matches :: PackageConfig -> String -> Bool pc `matches` pid = display (pkgName (sourcePackageId pc)) == pid @@ -493,9 +647,10 @@ findWiredInPackages dflags pkgs = do -- one. -- -- When choosing which package to map to a wired-in package - -- name, we prefer exposed packages, and pick the latest - -- version. To override the default choice, -hide-package - -- could be used to hide newer versions. + -- name, we pick the latest version (modern Cabal makes it difficult + -- to install multiple versions of wired-in packages, however!) + -- To override the default choice, -ignore-package could be used to + -- hide newer versions. -- findWiredInPackage :: [PackageConfig] -> String -> IO (Maybe InstalledPackageId) @@ -542,7 +697,9 @@ findWiredInPackages dflags pkgs = do updateWiredInDependencies pkgs = map upd_pkg pkgs where upd_pkg p | installedPackageId p `elem` wired_in_ids - = p { sourcePackageId = (sourcePackageId p){ pkgVersion = Version [] [] } } + = let pid = (sourcePackageId p) { pkgVersion = Version [] [] } + in p { sourcePackageId = pid + , packageKey = OldPackageKey pid } | otherwise = p @@ -555,7 +712,8 @@ data UnusablePackageReason | MissingDependencies [InstalledPackageId] | ShadowedBy InstalledPackageId -type UnusablePackages = Map InstalledPackageId UnusablePackageReason +type UnusablePackages = Map InstalledPackageId + (PackageConfig, UnusablePackageReason) pprReason :: SDoc -> UnusablePackageReason -> SDoc pprReason pref reason = case reason of @@ -571,7 +729,7 @@ pprReason pref reason = case reason of reportUnusable :: DynFlags -> UnusablePackages -> IO () reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs) where - report (ipid, reason) = + report (ipid, (_, reason)) = debugTraceMsg dflags 2 $ pprReason (ptext (sLit "package") <+> @@ -591,7 +749,7 @@ findBroken pkgs = go [] Map.empty pkgs go avail ipids not_avail = case partitionWith (depsAvailable ipids) not_avail of ([], not_avail) -> - Map.fromList [ (installedPackageId p, MissingDependencies deps) + Map.fromList [ (installedPackageId p, (p, MissingDependencies deps)) | (p,deps) <- not_avail ] (new_avail, not_avail) -> go (new_avail ++ avail) new_ipids (map fst not_avail) @@ -620,19 +778,20 @@ shadowPackages pkgs preferred in Map.fromList shadowed where check (shadowed,pkgmap) pkg - | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg) + | Just oldpkg <- lookupUFM pkgmap pkgid , let ipid_new = installedPackageId pkg ipid_old = installedPackageId oldpkg -- , ipid_old /= ipid_new = if ipid_old `elem` preferred - then ( (ipid_new, ShadowedBy ipid_old) : shadowed, pkgmap ) - else ( (ipid_old, ShadowedBy ipid_new) : shadowed, pkgmap' ) + then ((ipid_new, (pkg, ShadowedBy ipid_old)) : shadowed, pkgmap) + else ((ipid_old, (oldpkg, ShadowedBy ipid_new)) : shadowed, pkgmap') | otherwise = (shadowed, pkgmap') where - pkgmap' = addToUFM pkgmap (packageConfigId pkg) pkg + pkgid = mkFastString (display (sourcePackageId pkg)) + pkgmap' = addToUFM pkgmap pkgid pkg -- ----------------------------------------------------------------------------- @@ -641,7 +800,7 @@ ignorePackages flags pkgs = Map.fromList (concatMap doit flags) where doit (IgnorePackage str) = case partition (matchingStr str) pkgs of - (ps, _) -> [ (installedPackageId p, IgnoredWithFlag) + (ps, _) -> [ (installedPackageId p, (p, IgnoredWithFlag)) | p <- ps ] -- missing package is not an error for -ignore-package, -- because a common usage is to -ignore-package P as @@ -669,11 +828,11 @@ depClosure index ipids = closure Map.empty ipids mkPackageState :: DynFlags -> [PackageConfig] -- initial database - -> [PackageId] -- preloaded packages - -> PackageId -- this package + -> [PackageKey] -- preloaded packages + -> PackageKey -- this package -> IO (PackageState, - [PackageId], -- new packages to preload - PackageId) -- this package, might be modified if the current + [PackageKey], -- new packages to preload + PackageKey) -- this package, might be modified if the current -- package is a wired-in package. mkPackageState dflags pkgs0 preload0 this_package = do @@ -684,12 +843,12 @@ mkPackageState dflags pkgs0 preload0 this_package = do 1. P = transitive closure of packages selected by -package-id 2. Apply shadowing. When there are multiple packages with the same - sourcePackageId, + packageKey, * if one is in P, use that one * otherwise, use the one highest in the package stack [ - rationale: we cannot use two packages with the same sourcePackageId - in the same program, because sourcePackageId is the symbol prefix. + rationale: we cannot use two packages with the same packageKey + in the same program, because packageKey is the symbol prefix. Hence we must select a consistent set of packages to use. We have a default algorithm for doing this: packages higher in the stack shadow those lower down. This default algorithm can be overriden @@ -737,30 +896,64 @@ mkPackageState dflags pkgs0 preload0 this_package = do ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ] - ipid_selected = depClosure ipid_map [ InstalledPackageId i - | ExposePackageId i <- flags ] + ipid_selected = depClosure ipid_map + [ InstalledPackageId i + | ExposePackage (PackageIdArg i) _ <- flags ] (ignore_flags, other_flags) = partition is_ignore flags is_ignore IgnorePackage{} = True is_ignore _ = False shadowed = shadowPackages pkgs0_unique ipid_selected - ignored = ignorePackages ignore_flags pkgs0_unique - pkgs0' = filter (not . (`Map.member` (Map.union shadowed ignored)) . installedPackageId) pkgs0_unique + isBroken = (`Map.member` (Map.union shadowed ignored)).installedPackageId + pkgs0' = filter (not . isBroken) pkgs0_unique + broken = findBroken pkgs0' + unusable = shadowed `Map.union` ignored `Map.union` broken + pkgs1 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs0' reportUnusable dflags unusable -- + -- Calculate the initial set of packages, prior to any package flags. + -- This set contains the latest version of all valid (not unusable) packages, + -- or is empty if we have -hide-all-packages + -- + let preferLater pkg pkg' = + case comparing (pkgVersion.sourcePackageId) pkg pkg' of + GT -> pkg + _ -> pkg' + calcInitial m pkg = addToUFM_C preferLater m (fsPackageName pkg) pkg + initial = if gopt Opt_HideAllPackages dflags + then emptyUFM + else foldl' calcInitial emptyUFM pkgs1 + vis_map0 = foldUFM (\p vm -> + if exposed p + then addToUFM vm (calcKey p) + (True, [], fsPackageName p) + else vm) + emptyUFM initial + + -- -- Modify the package database according to the command-line flags -- (-package, -hide-package, -ignore-package, -hide-all-packages). + -- This needs to know about the unusable packages, since if a user tries + -- to enable an unusable package, we should let them know. -- - pkgs1 <- foldM (applyPackageFlag dflags unusable) pkgs0_unique other_flags - let pkgs2 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs1 + (pkgs2, vis_map) <- foldM (applyPackageFlag dflags unusable) + (pkgs1, vis_map0) other_flags + -- + -- Sort out which packages are wired in. This has to be done last, since + -- it modifies the package keys of wired in packages, but when we process + -- package arguments we need to key against the old versions. + -- + pkgs3 <- findWiredInPackages dflags pkgs2 + + -- -- Here we build up a set of the packages mentioned in -package -- flags on the command line; these are called the "preload" -- packages. we link these packages in eagerly. The preload set @@ -769,22 +962,15 @@ mkPackageState dflags pkgs0 preload0 this_package = do -- let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ] - get_exposed (ExposePackage s) - = take 1 $ sortByVersion (filter (matchingStr s) pkgs2) - -- -package P means "the latest version of P" (#7030) - get_exposed (ExposePackageId s) = filter (matchingId s) pkgs2 - get_exposed _ = [] + get_exposed (ExposePackage a _) = take 1 . sortByVersion + . filter (matching a) + $ pkgs2 + get_exposed _ = [] - -- hide packages that are subsumed by later versions - pkgs3 <- hideOldPackages dflags pkgs2 - - -- sort out which packages are wired in - pkgs4 <- findWiredInPackages dflags pkgs3 - - let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs4 + let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs3 ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p) - | p <- pkgs4 ] + | p <- pkgs3 ] lookupIPID ipid@(InstalledPackageId str) | Just pid <- Map.lookup ipid ipid_map = return pid @@ -796,7 +982,8 @@ mkPackageState dflags pkgs0 preload0 this_package = do -- add base & rts to the preload packages basicLinkedPackages | gopt Opt_AutoLinkPackages dflags - = filter (flip elemUFM pkg_db) [basePackageId, rtsPackageId] + = filter (flip elemUFM pkg_db) + [basePackageKey, rtsPackageKey] | otherwise = [] -- but in any case remove the current package from the set of -- preloaded packages so that base/rts does not end up in the @@ -808,36 +995,118 @@ mkPackageState dflags pkgs0 preload0 this_package = do dep_preload <- closeDeps dflags pkg_db ipid_map (zip preload3 (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload - let pstate = PackageState{ preloadPackages = dep_preload, - pkgIdMap = pkg_db, - moduleToPkgConfAll = mkModuleMap pkg_db, - installedPackageIdMap = ipid_map - } - + let pstate = PackageState{ + preloadPackages = dep_preload, + pkgIdMap = pkg_db, + moduleToPkgConf = mkModuleToPkgConf dflags pkg_db ipid_map vis_map, + moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map, + installedPackageIdMap = ipid_map + } return (pstate, new_dep_preload, this_package) -- ----------------------------------------------------------------------------- --- Make the mapping from module to package info - -mkModuleMap - :: PackageConfigMap - -> UniqFM [(PackageConfig, Bool)] -mkModuleMap pkg_db = foldr extend_modmap emptyUFM pkgids - where - pkgids = map packageConfigId (eltsUFM pkg_db) - - extend_modmap pkgid modmap = - addListToUFM_C (++) modmap - ([(m, [(pkg, True)]) | m <- exposed_mods] ++ - [(m, [(pkg, False)]) | m <- hidden_mods]) - where - pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid) - exposed_mods = exposedModules pkg - hidden_mods = hiddenModules pkg - -pprSPkg :: PackageConfig -> SDoc -pprSPkg p = text (display (sourcePackageId p)) +-- | Makes the mapping from module to package info + +-- | This function is generic; we instantiate it +mkModuleToPkgConfGeneric + :: forall m e. + -- Empty map, e.g. the initial state of the output + m e + -- How to create an entry in the map based on the calculated information + -> (PackageKey -> ModuleName -> PackageConfig -> ModuleOrigin -> e) + -- How to override the origin of an entry (used for renaming) + -> (e -> ModuleOrigin -> e) + -- How to incorporate a list of entries into the map + -> (m e -> [(ModuleName, e)] -> m e) + -- The proper arguments + -> DynFlags + -> PackageConfigMap + -> InstalledPackageIdMap + -> VisibilityMap + -> m e +mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo + dflags pkg_db ipid_map vis_map = + foldl' extend_modmap emptyMap (eltsUFM pkg_db) + where + extend_modmap modmap pkg = addListTo modmap theBindings + where + theBindings :: [(ModuleName, e)] + theBindings | Just (b,rns,_) <- lookupUFM vis_map (packageConfigId pkg) + = newBindings b rns + | otherwise = newBindings False [] + + newBindings :: Bool -> [(ModuleName, ModuleName)] -> [(ModuleName, e)] + newBindings e rns = es e ++ hiddens ++ map rnBinding rns + + rnBinding :: (ModuleName, ModuleName) -> (ModuleName, e) + rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) + where origEntry = case lookupUFM esmap orig of + Just r -> r + Nothing -> throwGhcException (CmdLineError (showSDoc dflags + (text "package flag: could not find module name" <+> + ppr orig <+> text "in package" <+> ppr pk))) + + es :: Bool -> [(ModuleName, e)] + es e = + [(m, sing pk m pkg (fromExposedModules e)) | m <- exposed_mods] ++ + [(m, sing pk' m' pkg' (fromReexportedModules e pkg)) + | ModuleExport{ exportName = m + , exportCachedTrueOrig = Just (ipid', m')} <- reexported_mods + , let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map) + pkg' = pkg_lookup pk' ] + + esmap :: UniqFM e + esmap = listToUFM (es False) -- parameter here doesn't matter, orig will + -- be overwritten + + hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods] + + pk = packageConfigId pkg + pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db + + exposed_mods = exposedModules pkg + reexported_mods = reexportedModules pkg + hidden_mods = hiddenModules pkg + +-- | This is a quick and efficient module map, which only contains an entry +-- if it is specified unambiguously. +mkModuleToPkgConf + :: DynFlags + -> PackageConfigMap + -> InstalledPackageIdMap + -> VisibilityMap + -> ModuleNameMap SimpleModuleConf +mkModuleToPkgConf = + mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo + where emptyMap = emptyUFM + sing pk m pkg = SModConf (mkModule pk m) pkg + -- NB: don't put hidden entries in the map, they're not valid! + addListTo m xs = addListToUFM_C merge m (filter isVisible xs) + isVisible (_, SModConf _ _ o) = originVisible o + isVisible (_, SModConfAmbiguous) = False + merge (SModConf m pkg o) (SModConf m' _ o') + | m == m' = SModConf m pkg (o `mappend` o') + | otherwise = SModConfAmbiguous + merge _ _ = SModConfAmbiguous + setOrigins (SModConf m pkg _) os = SModConf m pkg os + setOrigins SModConfAmbiguous _ = SModConfAmbiguous + +-- | This is a slow and complete map, which includes information about +-- everything, including hidden modules +mkModuleToPkgConfAll + :: DynFlags + -> PackageConfigMap + -> InstalledPackageIdMap + -> VisibilityMap + -> ModuleToPkgConfAll +mkModuleToPkgConfAll = + mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo + where emptyMap = Map.empty + sing pk m _ = Map.singleton (mkModule pk m) + addListTo = foldl' merge + merge m (k, v) = Map.insertWith (Map.unionWith mappend) k v m + setOrigins m os = fmap (const os) m pprIPkg :: PackageConfig -> SDoc pprIPkg p = text (display (installedPackageId p)) @@ -854,7 +1123,7 @@ pprIPkg p = text (display (installedPackageId p)) -- use. -- | Find all the include directories in these and the preload packages -getPackageIncludePath :: DynFlags -> [PackageId] -> IO [String] +getPackageIncludePath :: DynFlags -> [PackageKey] -> IO [String] getPackageIncludePath dflags pkgs = collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs @@ -862,7 +1131,7 @@ collectIncludeDirs :: [PackageConfig] -> [FilePath] collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps)) -- | Find all the library paths in these and the preload packages -getPackageLibraryPath :: DynFlags -> [PackageId] -> IO [String] +getPackageLibraryPath :: DynFlags -> [PackageKey] -> IO [String] getPackageLibraryPath dflags pkgs = collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs @@ -871,7 +1140,7 @@ collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps)) -- | Find all the link options in these and the preload packages, -- returning (package hs lib options, extra library options, other flags) -getPackageLinkOpts :: DynFlags -> [PackageId] -> IO ([String], [String], [String]) +getPackageLinkOpts :: DynFlags -> [PackageKey] -> IO ([String], [String], [String]) getPackageLinkOpts dflags pkgs = collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs @@ -919,19 +1188,19 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) | otherwise = '_':t -- | Find all the C-compiler options in these and the preload packages -getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String] +getPackageExtraCcOpts :: DynFlags -> [PackageKey] -> IO [String] getPackageExtraCcOpts dflags pkgs = do ps <- getPreloadPackagesAnd dflags pkgs return (concatMap ccOptions ps) -- | Find all the package framework paths in these and the preload packages -getPackageFrameworkPath :: DynFlags -> [PackageId] -> IO [String] +getPackageFrameworkPath :: DynFlags -> [PackageKey] -> IO [String] getPackageFrameworkPath dflags pkgs = do ps <- getPreloadPackagesAnd dflags pkgs return (nub (filter notNull (concatMap frameworkDirs ps))) -- | Find all the package frameworks in these and the preload packages -getPackageFrameworks :: DynFlags -> [PackageId] -> IO [String] +getPackageFrameworks :: DynFlags -> [PackageKey] -> IO [String] getPackageFrameworks dflags pkgs = do ps <- getPreloadPackagesAnd dflags pkgs return (concatMap frameworks ps) @@ -939,41 +1208,114 @@ getPackageFrameworks dflags pkgs = do -- ----------------------------------------------------------------------------- -- Package Utils --- | Takes a 'Module', and if the module is in a package returns --- @(pkgconf, exposed)@ where pkgconf is the PackageConfig for that package, --- and exposed is @True@ if the package exposes the module. -lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(PackageConfig,Bool)] +-- | Takes a 'ModuleName', and if the module is in any package returns +-- list of modules which take that name. +lookupModuleInAllPackages :: DynFlags + -> ModuleName + -> [(Module, PackageConfig)] lookupModuleInAllPackages dflags m - = case lookupModuleWithSuggestions dflags m of - Right pbs -> pbs - Left _ -> [] - -lookupModuleWithSuggestions - :: DynFlags -> ModuleName - -> Either [Module] [(PackageConfig,Bool)] - -- Lookup module in all packages - -- Right pbs => found in pbs - -- Left ms => not found; but here are sugestions -lookupModuleWithSuggestions dflags m - = case lookupUFM (moduleToPkgConfAll pkg_state) m of - Nothing -> Left suggestions - Just ps -> Right ps + = case lookupModuleWithSuggestions dflags m Nothing of + LookupFound a b -> [(a,b)] + LookupMultiple rs -> map f rs + where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags + (modulePackageKey m))) + _ -> [] + +-- | The result of performing a lookup +data LookupResult = + -- | Found the module uniquely, nothing else to do + LookupFound Module PackageConfig + -- | Multiple modules with the same name in scope + | LookupMultiple [(Module, ModuleOrigin)] + -- | No modules found, but there were some hidden ones with + -- an exact name match. First is due to package hidden, second + -- is due to module being hidden + | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)] + -- | Nothing found, here are some suggested different names + | LookupNotFound [ModuleSuggestion] -- suggestions + +data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin + | SuggestHidden ModuleName Module ModuleOrigin + +lookupModuleWithSuggestions :: DynFlags + -> ModuleName + -> Maybe FastString + -> LookupResult +lookupModuleWithSuggestions dflags m mb_pn + = case lookupUFM (moduleToPkgConf pkg_state) m of + Just (SModConf m pkg o) | matches mb_pn pkg o -> + ASSERT( originVisible o ) LookupFound m pkg + _ -> case Map.lookup m (moduleToPkgConfAll pkg_state) of + Nothing -> LookupNotFound suggestions + Just xs -> + case foldl' classify ([],[],[]) (Map.toList xs) of + ([], [], []) -> LookupNotFound suggestions + -- NB: Yes, we have to check this case too, since package qualified + -- imports could cause the main lookup to fail due to ambiguity, + -- but the second lookup to succeed. + (_, _, [(m, _)]) -> LookupFound m (mod_pkg m) + (_, _, exposed@(_:_)) -> LookupMultiple exposed + (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod where + classify (hidden_pkg, hidden_mod, exposed) (m, origin0) = + let origin = filterOrigin mb_pn (mod_pkg m) origin0 + x = (m, origin) + in case origin of + ModHidden -> (hidden_pkg, x:hidden_mod, exposed) + _ | originEmpty origin -> (hidden_pkg, hidden_mod, exposed) + | originVisible origin -> (hidden_pkg, hidden_mod, x:exposed) + | otherwise -> (x:hidden_pkg, hidden_mod, exposed) + + pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags pkg_state = pkgState dflags + mod_pkg = pkg_lookup . modulePackageKey + + matches Nothing _ _ = True -- shortcut for efficiency + matches mb_pn pkg o = originVisible (filterOrigin mb_pn pkg o) + + -- Filters out origins which are not associated with the given package + -- qualifier. No-op if there is no package qualifier. Test if this + -- excluded all origins with 'originEmpty'. + filterOrigin :: Maybe FastString + -> PackageConfig + -> ModuleOrigin + -> ModuleOrigin + filterOrigin Nothing _ o = o + filterOrigin (Just pn) pkg o = + case o of + ModHidden -> if go pkg then ModHidden else mempty + ModOrigin { fromOrigPackage = e, fromExposedReexport = res, + fromHiddenReexport = rhs } + -> ModOrigin { + fromOrigPackage = if go pkg then e else Nothing + , fromExposedReexport = filter go res + , fromHiddenReexport = filter go rhs + , fromPackageFlag = False -- always excluded + } + where go pkg = pn == fsPackageName pkg + suggestions | gopt Opt_HelpfulErrors dflags = fuzzyLookup (moduleNameString m) all_mods | otherwise = [] - all_mods :: [(String, Module)] -- All modules - all_mods = [ (moduleNameString mod_nm, mkModule pkg_id mod_nm) - | pkg_config <- eltsUFM (pkgIdMap pkg_state) - , let pkg_id = packageConfigId pkg_config - , mod_nm <- exposedModules pkg_config ] + all_mods :: [(String, ModuleSuggestion)] -- All modules + all_mods = sortBy (comparing fst) $ + [ (moduleNameString m, suggestion) + | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags)) + , suggestion <- map (getSuggestion m) (Map.toList e) + ] + getSuggestion name (mod, origin) = + (if originVisible origin then SuggestVisible else SuggestHidden) + name mod origin + +listVisibleModuleNames :: DynFlags -> [ModuleName] +listVisibleModuleNames dflags = + Map.keys (moduleToPkgConfAll (pkgState dflags)) -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of -- 'PackageConfig's -getPreloadPackagesAnd :: DynFlags -> [PackageId] -> IO [PackageConfig] +getPreloadPackagesAnd :: DynFlags -> [PackageKey] -> IO [PackageConfig] getPreloadPackagesAnd dflags pkgids = let state = pkgState dflags @@ -983,15 +1325,15 @@ getPreloadPackagesAnd dflags pkgids = pairs = zip pkgids (repeat Nothing) in do all_pkgs <- throwErr dflags (foldM (add_package pkg_map ipid_map) preload pairs) - return (map (getPackageDetails state) all_pkgs) + return (map (getPackageDetails dflags) all_pkgs) -- Takes a list of packages, and returns the list with dependencies included, -- in reverse dependency order (a package appears before those it depends on). closeDeps :: DynFlags -> PackageConfigMap - -> Map InstalledPackageId PackageId - -> [(PackageId, Maybe PackageId)] - -> IO [PackageId] + -> Map InstalledPackageId PackageKey + -> [(PackageKey, Maybe PackageKey)] + -> IO [PackageKey] closeDeps dflags pkg_map ipid_map ps = throwErr dflags (closeDepsErr pkg_map ipid_map ps) @@ -1002,22 +1344,22 @@ throwErr dflags m Succeeded r -> return r closeDepsErr :: PackageConfigMap - -> Map InstalledPackageId PackageId - -> [(PackageId,Maybe PackageId)] - -> MaybeErr MsgDoc [PackageId] + -> Map InstalledPackageId PackageKey + -> [(PackageKey,Maybe PackageKey)] + -> MaybeErr MsgDoc [PackageKey] closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps -- internal helper add_package :: PackageConfigMap - -> Map InstalledPackageId PackageId - -> [PackageId] - -> (PackageId,Maybe PackageId) - -> MaybeErr MsgDoc [PackageId] + -> Map InstalledPackageId PackageKey + -> [PackageKey] + -> (PackageKey,Maybe PackageKey) + -> MaybeErr MsgDoc [PackageKey] add_package pkg_db ipid_map ps (p, mb_parent) | p `elem` ps = return ps -- Check if we've already added this package | otherwise = - case lookupPackage pkg_db p of - Nothing -> Failed (missingPackageMsg (packageIdString p) <> + case lookupPackage' pkg_db p of + Nothing -> Failed (missingPackageMsg (packageKeyString p) <> missingDependencyMsg mb_parent) Just pkg -> do -- Add the package's dependents also @@ -1037,15 +1379,22 @@ missingPackageErr dflags p missingPackageMsg :: String -> SDoc missingPackageMsg p = ptext (sLit "unknown package:") <+> text p -missingDependencyMsg :: Maybe PackageId -> SDoc +missingDependencyMsg :: Maybe PackageKey -> SDoc missingDependencyMsg Nothing = empty missingDependencyMsg (Just parent) - = space <> parens (ptext (sLit "dependency of") <+> ftext (packageIdFS parent)) + = space <> parens (ptext (sLit "dependency of") <+> ftext (packageKeyFS parent)) -- ----------------------------------------------------------------------------- +packageKeyPackageIdString :: DynFlags -> PackageKey -> String +packageKeyPackageIdString dflags pkg_key + | pkg_key == mainPackageKey = "main" + | otherwise = maybe "(unknown)" + (display . sourcePackageId) + (lookupPackage dflags pkg_key) + -- | Will the 'Name' come from a dynamically linked library? -isDllName :: DynFlags -> PackageId -> Module -> Name -> Bool +isDllName :: DynFlags -> PackageKey -> Module -> Name -> Bool -- Despite the "dll", I think this function just means that -- the synbol comes from another dynamically-linked package, -- and applies on all platforms, not just Windows @@ -1086,11 +1435,10 @@ dumpPackages = dumpPackages' showInstalledPackageInfo dumpPackages' :: (InstalledPackageInfo -> String) -> DynFlags -> IO () dumpPackages' showIPI dflags - = do let pkg_map = pkgIdMap (pkgState dflags) - putMsg dflags $ + = do putMsg dflags $ vcat (map (text . showIPI . packageConfigToInstalledPackageInfo) - (eltsUFM pkg_map)) + (listPackageConfigMap dflags)) -- | Show simplified package info on console, if verbosity == 4. -- The idea is to only print package id, and any information that might @@ -1102,4 +1450,18 @@ simpleDumpPackages = dumpPackages' showIPI t = if trusted ipi then "T" else " " in e ++ t ++ " " ++ i +-- | Show the mapping of modules to where they come from. +pprModuleMap :: DynFlags -> SDoc +pprModuleMap dflags = + vcat (map pprLine (Map.toList (moduleToPkgConfAll (pkgState dflags)))) + where + pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e))) + pprEntry m (m',o) + | m == moduleName m' = ppr (modulePackageKey m') <+> parens (ppr o) + | otherwise = ppr m' <+> parens (ppr o) + +fsPackageName :: PackageConfig -> FastString +fsPackageName pkg = case packageName (sourcePackageId pkg) of + PackageName n -> mkFastString n + \end{code} diff --git a/compiler/main/Packages.lhs-boot b/compiler/main/Packages.lhs-boot index 3a1712e2da..3fd0fd5422 100644 --- a/compiler/main/Packages.lhs-boot +++ b/compiler/main/Packages.lhs-boot @@ -1,4 +1,8 @@ \begin{code} module Packages where +-- Well, this is kind of stupid... +import {-# SOURCE #-} Module (PackageKey) +import {-# SOURCE #-} DynFlags (DynFlags) data PackageState +packageKeyPackageIdString :: DynFlags -> PackageKey -> String \end{code} diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index d993ab87c8..eed4671b67 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -7,19 +7,12 @@ ----------------------------------------------------------------------------- {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module PprTyThing ( - pprTyThing, - pprTyThingInContext, - pprTyThingLoc, - pprTyThingInContextLoc, - pprTyThingHdr, + pprTyThing, + pprTyThingInContext, + pprTyThingLoc, + pprTyThingInContextLoc, + pprTyThingHdr, pprTypeForUser, pprFamInst ) where @@ -159,9 +152,9 @@ pprTypeForUser :: Type -> SDoc -- b) Swizzle the foralls to the top, so that without -- -fprint-explicit-foralls we'll suppress all the foralls -- Prime example: a class op might have type --- forall a. C a => forall b. Ord b => stuff +-- forall a. C a => forall b. Ord b => stuff -- Then we want to display --- (C a, Ord b) => stuff +-- (C a, Ord b) => stuff pprTypeForUser ty = pprSigmaType (mkSigmaTy tvs ctxt tau) where @@ -175,6 +168,6 @@ pprTypeForUser ty showWithLoc :: SDoc -> SDoc -> SDoc showWithLoc loc doc = hang doc 2 (char '\t' <> comment <+> loc) - -- The tab tries to make them line up a bit + -- The tab tries to make them line up a bit where comment = ptext (sLit "--") diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 51d5af137c..1c1c52cd1f 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -235,6 +235,8 @@ initSysTools mbMinusB -- to make that possible, so for now you can't. gcc_prog <- getSetting "C compiler command" gcc_args_str <- getSetting "C compiler flags" + cpp_prog <- getSetting "Haskell CPP command" + cpp_args_str <- getSetting "Haskell CPP flags" let unreg_gcc_args = if targetUnregisterised then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] else [] @@ -243,6 +245,7 @@ initSysTools mbMinusB | mkTablesNextToCode targetUnregisterised = ["-DTABLES_NEXT_TO_CODE"] | otherwise = [] + cpp_args= map Option (words cpp_args_str) gcc_args = map Option (words gcc_args_str ++ unreg_gcc_args ++ tntc_gcc_args) @@ -285,10 +288,7 @@ initSysTools mbMinusB -- cpp is derived from gcc on all platforms -- HACK, see setPgmP below. We keep 'words' here to remember to fix -- Config.hs one day. - let cpp_prog = gcc_prog - cpp_args = Option "-E" - : map Option (words cRAWCPP_FLAGS) - ++ gcc_args + -- Other things being equal, as and ld are simply gcc gcc_link_args_str <- getSetting "C compiler link flags" @@ -825,7 +825,57 @@ runLink dflags args = do args1 = map Option (getOpts dflags opt_l) args2 = args0 ++ args1 ++ args ++ linkargs mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "Linker" p args2 mb_env + runSomethingFiltered dflags ld_filter "Linker" p args2 mb_env + where + ld_filter = case (platformOS (targetPlatform dflags)) of + OSSolaris2 -> sunos_ld_filter + _ -> id +{- + SunOS/Solaris ld emits harmless warning messages about unresolved + symbols in case of compiling into shared library when we do not + link against all the required libs. That is the case of GHC which + does not link against RTS library explicitly in order to be able to + choose the library later based on binary application linking + parameters. The warnings look like: + +Undefined first referenced + symbol in file +stg_ap_n_fast ./T2386_Lib.o +stg_upd_frame_info ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o +newCAF ./T2386_Lib.o +stg_bh_upd_frame_info ./T2386_Lib.o +stg_ap_ppp_fast ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o +stg_ap_p_fast ./T2386_Lib.o +stg_ap_pp_fast ./T2386_Lib.o +ld: warning: symbol referencing errors + + this is actually coming from T2386 testcase. The emitting of those + warnings is also a reason why so many TH testcases fail on Solaris. + + Following filter code is SunOS/Solaris linker specific and should + filter out only linker warnings. Please note that the logic is a + little bit more complex due to the simple reason that we need to preserve + any other linker emitted messages. If there are any. Simply speaking + if we see "Undefined" and later "ld: warning:..." then we omit all + text between (including) the marks. Otherwise we copy the whole output. +-} + sunos_ld_filter :: String -> String + sunos_ld_filter = unlines . sunos_ld_filter' . lines + sunos_ld_filter' x = if (undefined_found x && ld_warning_found x) + then (ld_prefix x) ++ (ld_postfix x) + else x + breakStartsWith x y = break (isPrefixOf x) y + ld_prefix = fst . breakStartsWith "Undefined" + undefined_found = not . null . snd . breakStartsWith "Undefined" + ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors" + ld_postfix = tail . snd . ld_warn_break + ld_warning_found = not . null . snd . ld_warn_break + runLibtool :: DynFlags -> [Option] -> IO () runLibtool dflags args = do @@ -1316,7 +1366,7 @@ linesPlatform xs = #endif -linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () +linkDynLib :: DynFlags -> [String] -> [PackageKey] -> IO () linkDynLib dflags0 o_files dep_packages = do let -- This is a rather ugly hack to fix dynamically linked @@ -1362,7 +1412,7 @@ linkDynLib dflags0 o_files dep_packages OSMinGW32 -> pkgs _ -> - filter ((/= rtsPackageId) . packageConfigId) pkgs + filter ((/= rtsPackageKey) . packageConfigId) pkgs let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts in package_hs_libs ++ extra_libs ++ other_flags @@ -1464,7 +1514,7 @@ linkDynLib dflags0 o_files dep_packages ------------------------------------------------------------------- let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } - let buildingRts = thisPackage dflags == rtsPackageId + let buildingRts = thisPackage dflags == rtsPackageKey let bsymbolicFlag = if buildingRts then -- -Bsymbolic breaks the way we implement -- hooks in the RTS diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 7d47330044..6f24e3afb8 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -1019,7 +1019,7 @@ tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds ------------------------ tidyTopBind :: DynFlags - -> PackageId + -> PackageKey -> Module -> Id -> UnfoldEnv @@ -1189,7 +1189,7 @@ it as a CAF. In these cases however, we would need to use an additional CAF list to keep track of non-collectable CAFs. \begin{code} -hasCafRefs :: DynFlags -> PackageId -> Module +hasCafRefs :: DynFlags -> PackageKey -> Module -> (Id, VarEnv Var) -> Arity -> CoreExpr -> CafInfo hasCafRefs dflags this_pkg this_mod p arity expr diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index e53bb11cc3..3c4a551df3 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -1025,15 +1025,15 @@ cmmExprNative referenceKind expr = do CmmReg (CmmGlobal EagerBlackholeInfo) | arch == ArchPPC && not (gopt Opt_PIC dflags) -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info"))) + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit "__stg_EAGER_BLACKHOLE_info"))) CmmReg (CmmGlobal GCEnter1) | arch == ArchPPC && not (gopt Opt_PIC dflags) -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit "__stg_gc_enter_1"))) CmmReg (CmmGlobal GCFun) | arch == ArchPPC && not (gopt Opt_PIC dflags) -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun"))) + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageKey (fsLit "__stg_gc_fun"))) other -> return other diff --git a/compiler/nativeGen/CPrim.hs b/compiler/nativeGen/CPrim.hs index a6f4cab7bd..34782dfc1c 100644 --- a/compiler/nativeGen/CPrim.hs +++ b/compiler/nativeGen/CPrim.hs @@ -1,11 +1,16 @@ -- | Generating C symbol names emitted by the compiler. module CPrim - ( popCntLabel + ( atomicReadLabel + , atomicWriteLabel + , atomicRMWLabel + , cmpxchgLabel + , popCntLabel , bSwapLabel , word2FloatLabel ) where import CmmType +import CmmMachOp import Outputable popCntLabel :: Width -> String @@ -31,3 +36,46 @@ word2FloatLabel w = "hs_word2float" ++ pprWidth w pprWidth W32 = "32" pprWidth W64 = "64" pprWidth w = pprPanic "word2FloatLabel: Unsupported word width " (ppr w) + +atomicRMWLabel :: Width -> AtomicMachOp -> String +atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) + + pprFunName AMO_Add = "add" + pprFunName AMO_Sub = "sub" + pprFunName AMO_And = "and" + pprFunName AMO_Nand = "nand" + pprFunName AMO_Or = "or" + pprFunName AMO_Xor = "xor" + +cmpxchgLabel :: Width -> String +cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "cmpxchgLabel: Unsupported word width " (ppr w) + +atomicReadLabel :: Width -> String +atomicReadLabel w = "hs_atomicread" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "atomicReadLabel: Unsupported word width " (ppr w) + +atomicWriteLabel :: Width -> String +atomicWriteLabel w = "hs_atomicwrite" ++ pprWidth w + where + pprWidth W8 = "8" + pprWidth W16 = "16" + pprWidth W32 = "32" + pprWidth W64 = "64" + pprWidth w = pprPanic "atomicWriteLabel: Unsupported word width " (ppr w) diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 91651e6065..014117dd4c 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -813,15 +813,6 @@ genBranch = return . toOL . mkJumpInstr Conditional jumps are always to local labels, so we can use branch instructions. We peek at the arguments to decide what kind of comparison to do. - -SPARC: First, we have to ensure that the condition codes are set -according to the supplied comparison operation. We generate slightly -different code for floating point comparisons, because a floating -point operation cannot directly precede a @BF@. We assume the worst -and fill that slot with a @NOP@. - -SPARC: Do not fill the delay slots here; you will confuse the register -allocator. -} @@ -1160,6 +1151,10 @@ genCCall' dflags gcp target dest_regs args0 MO_BSwap w -> (fsLit $ bSwapLabel w, False) MO_PopCnt w -> (fsLit $ popCntLabel w, False) + MO_AtomicRMW w amop -> (fsLit $ atomicRMWLabel w amop, False) + MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False) + MO_AtomicRead w -> (fsLit $ atomicReadLabel w, False) + MO_AtomicWrite w -> (fsLit $ atomicWriteLabel w, False) MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported diff --git a/compiler/nativeGen/PPC/Cond.hs b/compiler/nativeGen/PPC/Cond.hs index 2568da5249..0e4b1fd701 100644 --- a/compiler/nativeGen/PPC/Cond.hs +++ b/compiler/nativeGen/PPC/Cond.hs @@ -1,17 +1,9 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module PPC.Cond ( - Cond(..), - condNegate, - condUnsigned, - condToSigned, - condToUnsigned, + Cond(..), + condNegate, + condUnsigned, + condToSigned, + condToUnsigned, ) where @@ -19,18 +11,18 @@ where import Panic data Cond - = ALWAYS - | EQQ - | GE - | GEU - | GTT - | GU - | LE - | LEU - | LTT - | LU - | NE - deriving Eq + = ALWAYS + | EQQ + | GE + | GEU + | GTT + | GU + | LE + | LEU + | LTT + | LU + | NE + deriving Eq condNegate :: Cond -> Cond diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs index bffa9ea63f..c4724d4193 100644 --- a/compiler/nativeGen/PPC/RegInfo.hs +++ b/compiler/nativeGen/PPC/RegInfo.hs @@ -7,20 +7,12 @@ -- (c) The University of Glasgow 1996-2004 -- ----------------------------------------------------------------------------- - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module PPC.RegInfo ( JumpDest( DestBlockId ), getJumpDestBlockId, - canShortcut, - shortcutJump, + canShortcut, + shortcutJump, - shortcutStatics + shortcutStatics ) where @@ -70,14 +62,13 @@ shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) shortcutStatic _ other_static = other_static -shortBlockId - :: (BlockId -> Maybe JumpDest) - -> BlockId - -> CLabel +shortBlockId + :: (BlockId -> Maybe JumpDest) + -> BlockId + -> CLabel shortBlockId fn blockid = case fn blockid of Nothing -> mkAsmTempLabel uq Just (DestBlockId blockid') -> shortBlockId fn blockid' where uq = getUnique blockid - diff --git a/compiler/nativeGen/Reg.hs b/compiler/nativeGen/Reg.hs index 77ca7480d6..862306f0bb 100644 --- a/compiler/nativeGen/Reg.hs +++ b/compiler/nativeGen/Reg.hs @@ -1,36 +1,27 @@ - -- | An architecture independent description of a register. --- This needs to stay architecture independent because it is used --- by NCGMonad and the register allocators, which are shared --- by all architectures. +-- This needs to stay architecture independent because it is used +-- by NCGMonad and the register allocators, which are shared +-- by all architectures. -- - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Reg ( - RegNo, - Reg(..), - regPair, - regSingle, - isRealReg, takeRealReg, - isVirtualReg, takeVirtualReg, - - VirtualReg(..), - renameVirtualReg, - classOfVirtualReg, - getHiVirtualRegFromLo, - getHiVRegFromLo, - - RealReg(..), - regNosOfRealReg, - realRegsAlias, - - liftPatchFnToRegReg + RegNo, + Reg(..), + regPair, + regSingle, + isRealReg, takeRealReg, + isVirtualReg, takeVirtualReg, + + VirtualReg(..), + renameVirtualReg, + classOfVirtualReg, + getHiVirtualRegFromLo, + getHiVRegFromLo, + + RealReg(..), + regNosOfRealReg, + realRegsAlias, + + liftPatchFnToRegReg ) where @@ -41,68 +32,68 @@ import RegClass import Data.List -- | An identifier for a primitive real machine register. -type RegNo - = Int +type RegNo + = Int -- VirtualRegs are virtual registers. The register allocator will --- eventually have to map them into RealRegs, or into spill slots. +-- eventually have to map them into RealRegs, or into spill slots. -- --- VirtualRegs are allocated on the fly, usually to represent a single --- value in the abstract assembly code (i.e. dynamic registers are --- usually single assignment). +-- VirtualRegs are allocated on the fly, usually to represent a single +-- value in the abstract assembly code (i.e. dynamic registers are +-- usually single assignment). -- --- The single assignment restriction isn't necessary to get correct code, --- although a better register allocation will result if single --- assignment is used -- because the allocator maps a VirtualReg into --- a single RealReg, even if the VirtualReg has multiple live ranges. +-- The single assignment restriction isn't necessary to get correct code, +-- although a better register allocation will result if single +-- assignment is used -- because the allocator maps a VirtualReg into +-- a single RealReg, even if the VirtualReg has multiple live ranges. -- --- Virtual regs can be of either class, so that info is attached. +-- Virtual regs can be of either class, so that info is attached. -- data VirtualReg - = VirtualRegI {-# UNPACK #-} !Unique - | VirtualRegHi {-# UNPACK #-} !Unique -- High part of 2-word register - | VirtualRegF {-# UNPACK #-} !Unique - | VirtualRegD {-# UNPACK #-} !Unique - | VirtualRegSSE {-# UNPACK #-} !Unique - deriving (Eq, Show, Ord) + = VirtualRegI {-# UNPACK #-} !Unique + | VirtualRegHi {-# UNPACK #-} !Unique -- High part of 2-word register + | VirtualRegF {-# UNPACK #-} !Unique + | VirtualRegD {-# UNPACK #-} !Unique + | VirtualRegSSE {-# UNPACK #-} !Unique + deriving (Eq, Show, Ord) instance Uniquable VirtualReg where - getUnique reg - = case reg of - VirtualRegI u -> u - VirtualRegHi u -> u - VirtualRegF u -> u - VirtualRegD u -> u - VirtualRegSSE u -> u + getUnique reg + = case reg of + VirtualRegI u -> u + VirtualRegHi u -> u + VirtualRegF u -> u + VirtualRegD u -> u + VirtualRegSSE u -> u instance Outputable VirtualReg where - ppr reg - = case reg of - VirtualRegI u -> text "%vI_" <> pprUnique u - VirtualRegHi u -> text "%vHi_" <> pprUnique u - VirtualRegF u -> text "%vF_" <> pprUnique u - VirtualRegD u -> text "%vD_" <> pprUnique u - VirtualRegSSE u -> text "%vSSE_" <> pprUnique u + ppr reg + = case reg of + VirtualRegI u -> text "%vI_" <> pprUnique u + VirtualRegHi u -> text "%vHi_" <> pprUnique u + VirtualRegF u -> text "%vF_" <> pprUnique u + VirtualRegD u -> text "%vD_" <> pprUnique u + VirtualRegSSE u -> text "%vSSE_" <> pprUnique u renameVirtualReg :: Unique -> VirtualReg -> VirtualReg renameVirtualReg u r = case r of - VirtualRegI _ -> VirtualRegI u - VirtualRegHi _ -> VirtualRegHi u - VirtualRegF _ -> VirtualRegF u - VirtualRegD _ -> VirtualRegD u - VirtualRegSSE _ -> VirtualRegSSE u + VirtualRegI _ -> VirtualRegI u + VirtualRegHi _ -> VirtualRegHi u + VirtualRegF _ -> VirtualRegF u + VirtualRegD _ -> VirtualRegD u + VirtualRegSSE _ -> VirtualRegSSE u classOfVirtualReg :: VirtualReg -> RegClass classOfVirtualReg vr = case vr of - VirtualRegI{} -> RcInteger - VirtualRegHi{} -> RcInteger - VirtualRegF{} -> RcFloat - VirtualRegD{} -> RcDouble - VirtualRegSSE{} -> RcDoubleSSE + VirtualRegI{} -> RcInteger + VirtualRegHi{} -> RcInteger + VirtualRegF{} -> RcFloat + VirtualRegD{} -> RcDouble + VirtualRegSSE{} -> RcDoubleSSE -- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform @@ -111,118 +102,116 @@ classOfVirtualReg vr getHiVirtualRegFromLo :: VirtualReg -> VirtualReg getHiVirtualRegFromLo reg = case reg of - -- makes a pseudo-unique with tag 'H' - VirtualRegI u -> VirtualRegHi (newTagUnique u 'H') - _ -> panic "Reg.getHiVirtualRegFromLo" + -- makes a pseudo-unique with tag 'H' + VirtualRegI u -> VirtualRegHi (newTagUnique u 'H') + _ -> panic "Reg.getHiVirtualRegFromLo" getHiVRegFromLo :: Reg -> Reg getHiVRegFromLo reg = case reg of - RegVirtual vr -> RegVirtual (getHiVirtualRegFromLo vr) - RegReal _ -> panic "Reg.getHiVRegFromLo" - + RegVirtual vr -> RegVirtual (getHiVirtualRegFromLo vr) + RegReal _ -> panic "Reg.getHiVRegFromLo" + ------------------------------------------------------------------------------------ -- | RealRegs are machine regs which are available for allocation, in --- the usual way. We know what class they are, because that's part of --- the processor's architecture. +-- the usual way. We know what class they are, because that's part of +-- the processor's architecture. -- --- RealRegPairs are pairs of real registers that are allocated together --- to hold a larger value, such as with Double regs on SPARC. +-- RealRegPairs are pairs of real registers that are allocated together +-- to hold a larger value, such as with Double regs on SPARC. -- data RealReg - = RealRegSingle {-# UNPACK #-} !RegNo - | RealRegPair {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo - deriving (Eq, Show, Ord) + = RealRegSingle {-# UNPACK #-} !RegNo + | RealRegPair {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo + deriving (Eq, Show, Ord) instance Uniquable RealReg where - getUnique reg - = case reg of - RealRegSingle i -> mkRegSingleUnique i - RealRegPair r1 r2 -> mkRegPairUnique (r1 * 65536 + r2) + getUnique reg + = case reg of + RealRegSingle i -> mkRegSingleUnique i + RealRegPair r1 r2 -> mkRegPairUnique (r1 * 65536 + r2) instance Outputable RealReg where - ppr reg - = case reg of - RealRegSingle i -> text "%r" <> int i - RealRegPair r1 r2 -> text "%r(" <> int r1 <> text "|" <> int r2 <> text ")" + ppr reg + = case reg of + RealRegSingle i -> text "%r" <> int i + RealRegPair r1 r2 -> text "%r(" <> int r1 <> text "|" <> int r2 <> text ")" regNosOfRealReg :: RealReg -> [RegNo] regNosOfRealReg rr = case rr of - RealRegSingle r1 -> [r1] - RealRegPair r1 r2 -> [r1, r2] - + RealRegSingle r1 -> [r1] + RealRegPair r1 r2 -> [r1, r2] + realRegsAlias :: RealReg -> RealReg -> Bool realRegsAlias rr1 rr2 - = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2) + = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2) -------------------------------------------------------------------------------- -- | A register, either virtual or real data Reg - = RegVirtual !VirtualReg - | RegReal !RealReg - deriving (Eq, Ord) + = RegVirtual !VirtualReg + | RegReal !RealReg + deriving (Eq, Ord) regSingle :: RegNo -> Reg -regSingle regNo = RegReal $ RealRegSingle regNo +regSingle regNo = RegReal $ RealRegSingle regNo regPair :: RegNo -> RegNo -> Reg -regPair regNo1 regNo2 = RegReal $ RealRegPair regNo1 regNo2 +regPair regNo1 regNo2 = RegReal $ RealRegPair regNo1 regNo2 --- We like to have Uniques for Reg so that we can make UniqFM and UniqSets +-- We like to have Uniques for Reg so that we can make UniqFM and UniqSets -- in the register allocator. instance Uniquable Reg where - getUnique reg - = case reg of - RegVirtual vr -> getUnique vr - RegReal rr -> getUnique rr - + getUnique reg + = case reg of + RegVirtual vr -> getUnique vr + RegReal rr -> getUnique rr + -- | Print a reg in a generic manner --- If you want the architecture specific names, then use the pprReg --- function from the appropriate Ppr module. +-- If you want the architecture specific names, then use the pprReg +-- function from the appropriate Ppr module. instance Outputable Reg where - ppr reg - = case reg of - RegVirtual vr -> ppr vr - RegReal rr -> ppr rr + ppr reg + = case reg of + RegVirtual vr -> ppr vr + RegReal rr -> ppr rr isRealReg :: Reg -> Bool -isRealReg reg +isRealReg reg = case reg of - RegReal _ -> True - RegVirtual _ -> False + RegReal _ -> True + RegVirtual _ -> False takeRealReg :: Reg -> Maybe RealReg takeRealReg reg = case reg of - RegReal rr -> Just rr - _ -> Nothing + RegReal rr -> Just rr + _ -> Nothing isVirtualReg :: Reg -> Bool isVirtualReg reg = case reg of - RegReal _ -> False - RegVirtual _ -> True + RegReal _ -> False + RegVirtual _ -> True takeVirtualReg :: Reg -> Maybe VirtualReg takeVirtualReg reg = case reg of - RegReal _ -> Nothing - RegVirtual vr -> Just vr + RegReal _ -> Nothing + RegVirtual vr -> Just vr -- | The patch function supplied by the allocator maps VirtualReg to RealReg --- regs, but sometimes we want to apply it to plain old Reg. +-- regs, but sometimes we want to apply it to plain old Reg. -- liftPatchFnToRegReg :: (VirtualReg -> RealReg) -> (Reg -> Reg) liftPatchFnToRegReg patchF reg = case reg of - RegVirtual vr -> RegReal (patchF vr) - RegReal _ -> reg - - + RegVirtual vr -> RegReal (patchF vr) + RegReal _ -> reg diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index ee43d25aa3..fa47a17ac0 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -158,11 +158,11 @@ regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live []) , Nothing ) regAlloc dflags (CmmProc static lbl live sccs) - | LiveInfo info (Just first_id) (Just block_live) _ <- static + | LiveInfo info entry_ids@(first_id:_) (Just block_live) _ <- static = do -- do register allocation on each component. (final_blocks, stats, stack_use) - <- linearRegAlloc dflags first_id block_live sccs + <- linearRegAlloc dflags entry_ids block_live sccs -- make sure the block that was first in the input list -- stays at the front of the output @@ -196,46 +196,50 @@ regAlloc _ (CmmProc _ _ _ _) linearRegAlloc :: (Outputable instr, Instruction instr) => DynFlags - -> BlockId -- ^ the first block - -> BlockMap RegSet -- ^ live regs on entry to each basic block - -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" + -> [BlockId] -- ^ entry points + -> BlockMap RegSet + -- ^ live regs on entry to each basic block + -> [SCC (LiveBasicBlock instr)] + -- ^ instructions annotated with "deaths" -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) -linearRegAlloc dflags first_id block_live sccs - = let platform = targetPlatform dflags - in case platformArch platform of - ArchX86 -> linearRegAlloc' dflags (frInitFreeRegs platform :: X86.FreeRegs) first_id block_live sccs - ArchX86_64 -> linearRegAlloc' dflags (frInitFreeRegs platform :: X86_64.FreeRegs) first_id block_live sccs - ArchSPARC -> linearRegAlloc' dflags (frInitFreeRegs platform :: SPARC.FreeRegs) first_id block_live sccs - ArchPPC -> linearRegAlloc' dflags (frInitFreeRegs platform :: PPC.FreeRegs) first_id block_live sccs - ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" - ArchARM64 -> panic "linearRegAlloc ArchARM64" - ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" - ArchAlpha -> panic "linearRegAlloc ArchAlpha" - ArchMipseb -> panic "linearRegAlloc ArchMipseb" - ArchMipsel -> panic "linearRegAlloc ArchMipsel" +linearRegAlloc dflags entry_ids block_live sccs + = case platformArch platform of + ArchX86 -> go $ (frInitFreeRegs platform :: X86.FreeRegs) + ArchX86_64 -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs) + ArchSPARC -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs) + ArchPPC -> go $ (frInitFreeRegs platform :: PPC.FreeRegs) + ArchARM _ _ _ -> panic "linearRegAlloc ArchARM" + ArchARM64 -> panic "linearRegAlloc ArchARM64" + ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" + ArchAlpha -> panic "linearRegAlloc ArchAlpha" + ArchMipseb -> panic "linearRegAlloc ArchMipseb" + ArchMipsel -> panic "linearRegAlloc ArchMipsel" ArchJavaScript -> panic "linearRegAlloc ArchJavaScript" - ArchUnknown -> panic "linearRegAlloc ArchUnknown" + ArchUnknown -> panic "linearRegAlloc ArchUnknown" + where + go f = linearRegAlloc' dflags f entry_ids block_live sccs + platform = targetPlatform dflags linearRegAlloc' :: (FR freeRegs, Outputable instr, Instruction instr) => DynFlags -> freeRegs - -> BlockId -- ^ the first block + -> [BlockId] -- ^ entry points -> BlockMap RegSet -- ^ live regs on entry to each basic block -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) -linearRegAlloc' dflags initFreeRegs first_id block_live sccs +linearRegAlloc' dflags initFreeRegs entry_ids block_live sccs = do us <- getUs let (_, stack, stats, blocks) = runR dflags emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap dflags) us - $ linearRA_SCCs first_id block_live [] sccs + $ linearRA_SCCs entry_ids block_live [] sccs return (blocks, stats, getStackUse stack) linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockId + => [BlockId] -> BlockMap RegSet -> [NatBasicBlock instr] -> [SCC (LiveBasicBlock instr)] @@ -244,16 +248,16 @@ linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) linearRA_SCCs _ _ blocksAcc [] = return $ reverse blocksAcc -linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs) +linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs) = do blocks' <- processBlock block_live block - linearRA_SCCs first_id block_live + linearRA_SCCs entry_ids block_live ((reverse blocks') ++ blocksAcc) sccs -linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) +linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs) = do - blockss' <- process first_id block_live blocks [] (return []) False - linearRA_SCCs first_id block_live + blockss' <- process entry_ids block_live blocks [] (return []) False + linearRA_SCCs entry_ids block_live (reverse (concat blockss') ++ blocksAcc) sccs @@ -270,7 +274,7 @@ linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) -} process :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockId + => [BlockId] -> BlockMap RegSet -> [GenBasicBlock (LiveInstr instr)] -> [GenBasicBlock (LiveInstr instr)] @@ -281,7 +285,7 @@ process :: (FR freeRegs, Instruction instr, Outputable instr) process _ _ [] [] accum _ = return $ reverse accum -process first_id block_live [] next_round accum madeProgress +process entry_ids block_live [] next_round accum madeProgress | not madeProgress {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming. @@ -291,22 +295,22 @@ process first_id block_live [] next_round accum madeProgress = return $ reverse accum | otherwise - = process first_id block_live + = process entry_ids block_live next_round [] accum False -process first_id block_live (b@(BasicBlock id _) : blocks) +process entry_ids block_live (b@(BasicBlock id _) : blocks) next_round accum madeProgress = do block_assig <- getBlockAssigR if isJust (mapLookup id block_assig) - || id == first_id + || id `elem` entry_ids then do b' <- processBlock block_live b - process first_id block_live blocks + process entry_ids block_live blocks next_round (b' : accum) True - else process first_id block_live blocks + else process entry_ids block_live blocks (b : next_round) accum madeProgress diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 1cb6dc8268..d7fd8bdcb4 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -169,10 +169,11 @@ data Liveness -- | Stash regs live on entry to each basic block in the info part of the cmm code. data LiveInfo = LiveInfo - (BlockEnv CmmStatics) -- cmm info table static stuff - (Maybe BlockId) -- id of the first block - (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block - (Map BlockId (Set Int)) -- stack slots live on entry to this block + (BlockEnv CmmStatics) -- cmm info table static stuff + [BlockId] -- entry points (first one is the + -- entry point for the proc). + (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block + (Map BlockId (Set Int)) -- stack slots live on entry to this block -- | A basic block with liveness information. @@ -223,9 +224,9 @@ instance Outputable instr | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs) instance Outputable LiveInfo where - ppr (LiveInfo mb_static firstId liveVRegsOnEntry liveSlotsOnEntry) + ppr (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry) = (ppr mb_static) - $$ text "# firstId = " <> ppr firstId + $$ text "# entryIds = " <> ppr entryIds $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) @@ -480,7 +481,7 @@ stripLive dflags live where stripCmm :: (Outputable statics, Outputable instr, Instruction instr) => LiveCmmDecl statics instr -> NatCmmDecl statics instr stripCmm (CmmData sec ds) = CmmData sec ds - stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label live sccs) + stripCmm (CmmProc (LiveInfo info (first_id:_) _ _) label live sccs) = let final_blocks = flattenSCCs sccs -- make sure the block that was first in the input list @@ -493,7 +494,7 @@ stripLive dflags live (ListGraph $ map (stripLiveBlock dflags) $ first' : rest') -- procs used for stg_split_markers don't contain any blocks, and have no first_id. - stripCmm (CmmProc (LiveInfo info Nothing _ _) label live []) + stripCmm (CmmProc (LiveInfo info [] _ _) label live []) = CmmProc info label live (ListGraph []) -- If the proc has blocks but we don't know what the first one was, then we're dead. @@ -641,16 +642,19 @@ natCmmTopToLive (CmmData i d) = CmmData i d natCmmTopToLive (CmmProc info lbl live (ListGraph [])) - = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl live [] + = CmmProc (LiveInfo info [] Nothing Map.empty) lbl live [] natCmmTopToLive proc@(CmmProc info lbl live (ListGraph blocks@(first : _))) = let first_id = blockId first - sccs = sccBlocks blocks (entryBlocks proc) + all_entry_ids = entryBlocks proc + sccs = sccBlocks blocks all_entry_ids + entry_ids = filter (/= first_id) all_entry_ids sccsLive = map (fmap (\(BasicBlock l instrs) -> BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) $ sccs - in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl live sccsLive + in CmmProc (LiveInfo info (first_id : entry_ids) Nothing Map.empty) + lbl live sccsLive -- diff --git a/compiler/nativeGen/RegClass.hs b/compiler/nativeGen/RegClass.hs index cac4e64221..0c793173cb 100644 --- a/compiler/nativeGen/RegClass.hs +++ b/compiler/nativeGen/RegClass.hs @@ -1,41 +1,33 @@ -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - - -- | An architecture independent description of a register's class. -module RegClass - ( RegClass (..) ) +module RegClass + ( RegClass (..) ) where -import Outputable -import Unique +import Outputable +import Unique --- | The class of a register. --- Used in the register allocator. --- We treat all registers in a class as being interchangable. +-- | The class of a register. +-- Used in the register allocator. +-- We treat all registers in a class as being interchangable. -- -data RegClass - = RcInteger - | RcFloat - | RcDouble - | RcDoubleSSE -- x86 only: the SSE regs are a separate class - deriving Eq +data RegClass + = RcInteger + | RcFloat + | RcDouble + | RcDoubleSSE -- x86 only: the SSE regs are a separate class + deriving Eq instance Uniquable RegClass where - getUnique RcInteger = mkRegClassUnique 0 - getUnique RcFloat = mkRegClassUnique 1 - getUnique RcDouble = mkRegClassUnique 2 + getUnique RcInteger = mkRegClassUnique 0 + getUnique RcFloat = mkRegClassUnique 1 + getUnique RcDouble = mkRegClassUnique 2 getUnique RcDoubleSSE = mkRegClassUnique 3 instance Outputable RegClass where - ppr RcInteger = Outputable.text "I" - ppr RcFloat = Outputable.text "F" - ppr RcDouble = Outputable.text "D" - ppr RcDoubleSSE = Outputable.text "S" + ppr RcInteger = Outputable.text "I" + ppr RcFloat = Outputable.text "F" + ppr RcDouble = Outputable.text "D" + ppr RcDoubleSSE = Outputable.text "S" diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index f5e61d0a8f..51f89d629f 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -654,6 +654,10 @@ outOfLineMachOp_table mop MO_BSwap w -> fsLit $ bSwapLabel w MO_PopCnt w -> fsLit $ popCntLabel w + MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop + MO_Cmpxchg w -> fsLit $ cmpxchgLabel w + MO_AtomicRead w -> fsLit $ atomicReadLabel w + MO_AtomicWrite w -> fsLit $ atomicWriteLabel w MO_S_QuotRem {} -> unsupported MO_U_QuotRem {} -> unsupported diff --git a/compiler/nativeGen/SPARC/CodeGen/Amode.hs b/compiler/nativeGen/SPARC/CodeGen/Amode.hs index f0aed0d02e..8d9a303f2f 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Amode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Amode.hs @@ -1,13 +1,5 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.CodeGen.Amode ( - getAmode + getAmode ) where @@ -28,11 +20,11 @@ import OrdList -- | Generate code to reference a memory address. -getAmode - :: CmmExpr -- ^ expr producing an address - -> NatM Amode +getAmode + :: CmmExpr -- ^ expr producing an address + -> NatM Amode -getAmode tree@(CmmRegOff _ _) +getAmode tree@(CmmRegOff _ _) = do dflags <- getDynFlags getAmode (mangleIndexTree dflags tree) @@ -50,7 +42,7 @@ getAmode (CmmMachOp (MO_Add _) [x, CmmLit (CmmInt i _)]) = do (reg, code) <- getSomeReg x let - off = ImmInt (fromInteger i) + off = ImmInt (fromInteger i) return (Amode (AddrRegImm reg off) code) getAmode (CmmMachOp (MO_Add _) [x, y]) @@ -58,23 +50,23 @@ getAmode (CmmMachOp (MO_Add _) [x, y]) (regX, codeX) <- getSomeReg x (regY, codeY) <- getSomeReg y let - code = codeX `appOL` codeY + code = codeX `appOL` codeY return (Amode (AddrRegReg regX regY) code) getAmode (CmmLit lit) = do - let imm__2 = litToImm lit - tmp1 <- getNewRegNat II32 - tmp2 <- getNewRegNat II32 + let imm__2 = litToImm lit + tmp1 <- getNewRegNat II32 + tmp2 <- getNewRegNat II32 + + let code = toOL [ SETHI (HI imm__2) tmp1 + , OR False tmp1 (RIImm (LO imm__2)) tmp2] - let code = toOL [ SETHI (HI imm__2) tmp1 - , OR False tmp1 (RIImm (LO imm__2)) tmp2] - - return (Amode (AddrRegReg tmp2 g0) code) + return (Amode (AddrRegReg tmp2 g0) code) getAmode other = do (reg, code) <- getSomeReg other let - off = ImmInt 0 + off = ImmInt 0 return (Amode (AddrRegImm reg off) code) diff --git a/compiler/nativeGen/SPARC/CodeGen/Base.hs b/compiler/nativeGen/SPARC/CodeGen/Base.hs index 45b7801960..270fd699b0 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Base.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Base.hs @@ -1,22 +1,14 @@ +module SPARC.CodeGen.Base ( + InstrBlock, + CondCode(..), + ChildCode64(..), + Amode(..), -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details + Register(..), + setSizeOfRegister, -module SPARC.CodeGen.Base ( - InstrBlock, - CondCode(..), - ChildCode64(..), - Amode(..), - - Register(..), - setSizeOfRegister, - - getRegisterReg, - mangleIndexTree + getRegisterReg, + mangleIndexTree ) where @@ -39,63 +31,63 @@ import OrdList -------------------------------------------------------------------------------- -- | 'InstrBlock's are the insn sequences generated by the insn selectors. --- They are really trees of insns to facilitate fast appending, where a --- left-to-right traversal yields the insns in the correct order. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. -- -type InstrBlock - = OrdList Instr +type InstrBlock + = OrdList Instr -- | Condition codes passed up the tree. -- -data CondCode - = CondCode Bool Cond InstrBlock +data CondCode + = CondCode Bool Cond InstrBlock -- | a.k.a "Register64" --- Reg is the lower 32-bit temporary which contains the result. --- Use getHiVRegFromLo to find the other VRegUnique. +-- Reg is the lower 32-bit temporary which contains the result. +-- Use getHiVRegFromLo to find the other VRegUnique. -- --- Rules of this simplified insn selection game are therefore that --- the returned Reg may be modified +-- Rules of this simplified insn selection game are therefore that +-- the returned Reg may be modified -- -data ChildCode64 - = ChildCode64 +data ChildCode64 + = ChildCode64 InstrBlock - Reg + Reg -- | Holds code that references a memory address. -data Amode - = Amode - -- the AddrMode we can use in the instruction - -- that does the real load\/store. - AddrMode +data Amode + = Amode + -- the AddrMode we can use in the instruction + -- that does the real load\/store. + AddrMode - -- other setup code we have to run first before we can use the - -- above AddrMode. - InstrBlock + -- other setup code we have to run first before we can use the + -- above AddrMode. + InstrBlock -------------------------------------------------------------------------------- -- | Code to produce a result into a register. --- If the result must go in a specific register, it comes out as Fixed. --- Otherwise, the parent can decide which register to put it in. +-- If the result must go in a specific register, it comes out as Fixed. +-- Otherwise, the parent can decide which register to put it in. -- data Register - = Fixed Size Reg InstrBlock - | Any Size (Reg -> InstrBlock) + = Fixed Size Reg InstrBlock + | Any Size (Reg -> InstrBlock) -- | Change the size field in a Register. setSizeOfRegister - :: Register -> Size -> Register + :: Register -> Size -> Register setSizeOfRegister reg size = case reg of - Fixed _ reg code -> Fixed size reg code - Any _ codefn -> Any size codefn + Fixed _ reg code -> Fixed size reg code + Any _ codefn -> Any size codefn -------------------------------------------------------------------------------- @@ -103,7 +95,7 @@ setSizeOfRegister reg size getRegisterReg :: Platform -> CmmReg -> Reg getRegisterReg _ (CmmLocal (LocalReg u pk)) - = RegVirtual $ mkVirtualReg u (cmmTypeSize pk) + = RegVirtual $ mkVirtualReg u (cmmTypeSize pk) getRegisterReg platform (CmmGlobal mid) = case globalRegMaybe platform mid of @@ -118,12 +110,8 @@ getRegisterReg platform (CmmGlobal mid) mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr mangleIndexTree dflags (CmmRegOff reg off) - = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType dflags reg) + = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] + where width = typeWidth (cmmRegType dflags reg) mangleIndexTree _ _ - = panic "SPARC.CodeGen.Base.mangleIndexTree: no match" - - - - + = panic "SPARC.CodeGen.Base.mangleIndexTree: no match" diff --git a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs index 2c3dbe6fc0..cb10830f46 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs @@ -1,15 +1,7 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.CodeGen.CondCode ( - getCondCode, - condIntCode, - condFltCode + getCondCode, + condIntCode, + condFltCode ) where @@ -32,7 +24,7 @@ import Outputable getCondCode :: CmmExpr -> NatM CondCode getCondCode (CmmMachOp mop [x, y]) - = + = case mop of MO_F_Eq W32 -> condFltCode EQQ x y MO_F_Ne W32 -> condFltCode NE x y @@ -86,8 +78,8 @@ condIntCode cond x y = do (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y let - code__2 = code1 `appOL` code2 `snocOL` - SUB False True src1 (RIReg src2) g0 + code__2 = code1 `appOL` code2 `snocOL` + SUB False True src1 (RIReg src2) g0 return (CondCode False cond code__2) @@ -98,19 +90,19 @@ condFltCode cond x y = do (src2, code2) <- getSomeReg y tmp <- getNewRegNat FF64 let - promote x = FxTOy FF32 FF64 x tmp - - pk1 = cmmExprType dflags x - pk2 = cmmExprType dflags y - - code__2 = - if pk1 `cmmEqType` pk2 then - code1 `appOL` code2 `snocOL` - FCMP True (cmmTypeSize pk1) src1 src2 - else if typeWidth pk1 == W32 then - code1 `snocOL` promote src1 `appOL` code2 `snocOL` - FCMP True FF64 tmp src2 - else - code1 `appOL` code2 `snocOL` promote src2 `snocOL` - FCMP True FF64 src1 tmp + promote x = FxTOy FF32 FF64 x tmp + + pk1 = cmmExprType dflags x + pk2 = cmmExprType dflags y + + code__2 = + if pk1 `cmmEqType` pk2 then + code1 `appOL` code2 `snocOL` + FCMP True (cmmTypeSize pk1) src1 src2 + else if typeWidth pk1 == W32 then + code1 `snocOL` promote src1 `appOL` code2 `snocOL` + FCMP True FF64 tmp src2 + else + code1 `appOL` code2 `snocOL` promote src2 `snocOL` + FCMP True FF64 src1 tmp return (CondCode True cond code__2) diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs index 7ebc2f6630..1d4d1379a5 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -1,14 +1,6 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Expand out synthetic instructions into single machine instrs. module SPARC.CodeGen.Expand ( - expandTop + expandTop ) where @@ -17,7 +9,7 @@ import SPARC.Instr import SPARC.Imm import SPARC.AddrMode import SPARC.Regs -import SPARC.Ppr () +import SPARC.Ppr () import Instruction import Reg import Size @@ -30,139 +22,132 @@ import OrdList -- | Expand out synthetic instructions in this top level thing expandTop :: NatCmmDecl CmmStatics Instr -> NatCmmDecl CmmStatics Instr expandTop top@(CmmData{}) - = top + = top expandTop (CmmProc info lbl live (ListGraph blocks)) - = CmmProc info lbl live (ListGraph $ map expandBlock blocks) + = CmmProc info lbl live (ListGraph $ map expandBlock blocks) -- | Expand out synthetic instructions in this block expandBlock :: NatBasicBlock Instr -> NatBasicBlock Instr expandBlock (BasicBlock label instrs) - = let instrs_ol = expandBlockInstrs instrs - instrs' = fromOL instrs_ol - in BasicBlock label instrs' + = let instrs_ol = expandBlockInstrs instrs + instrs' = fromOL instrs_ol + in BasicBlock label instrs' -- | Expand out some instructions expandBlockInstrs :: [Instr] -> OrdList Instr -expandBlockInstrs [] = nilOL - +expandBlockInstrs [] = nilOL + expandBlockInstrs (ii:is) - = let ii_doubleRegs = remapRegPair ii - is_misaligned = expandMisalignedDoubles ii_doubleRegs + = let ii_doubleRegs = remapRegPair ii + is_misaligned = expandMisalignedDoubles ii_doubleRegs + + in is_misaligned `appOL` expandBlockInstrs is - in is_misaligned `appOL` expandBlockInstrs is - -- | In the SPARC instruction set the FP register pairs that are used --- to hold 64 bit floats are refered to by just the first reg --- of the pair. Remap our internal reg pairs to the appropriate reg. +-- to hold 64 bit floats are refered to by just the first reg +-- of the pair. Remap our internal reg pairs to the appropriate reg. -- --- For example: --- ldd [%l1], (%f0 | %f1) +-- For example: +-- ldd [%l1], (%f0 | %f1) -- --- gets mapped to --- ldd [$l1], %f0 +-- gets mapped to +-- ldd [$l1], %f0 -- remapRegPair :: Instr -> Instr remapRegPair instr - = let patchF reg - = case reg of - RegReal (RealRegSingle _) - -> reg + = let patchF reg + = case reg of + RegReal (RealRegSingle _) + -> reg - RegReal (RealRegPair r1 r2) + RegReal (RealRegPair r1 r2) - -- sanity checking - | r1 >= 32 - , r1 <= 63 - , r1 `mod` 2 == 0 - , r2 == r1 + 1 - -> RegReal (RealRegSingle r1) + -- sanity checking + | r1 >= 32 + , r1 <= 63 + , r1 `mod` 2 == 0 + , r2 == r1 + 1 + -> RegReal (RealRegSingle r1) - | otherwise - -> pprPanic "SPARC.CodeGen.Expand: not remapping dodgy looking reg pair " (ppr reg) + | otherwise + -> pprPanic "SPARC.CodeGen.Expand: not remapping dodgy looking reg pair " (ppr reg) - RegVirtual _ - -> pprPanic "SPARC.CodeGen.Expand: not remapping virtual reg " (ppr reg) - - in patchRegsOfInstr instr patchF + RegVirtual _ + -> pprPanic "SPARC.CodeGen.Expand: not remapping virtual reg " (ppr reg) + + in patchRegsOfInstr instr patchF -- Expand out 64 bit load/stores into individual instructions to handle --- possible double alignment problems. +-- possible double alignment problems. -- --- TODO: It'd be better to use a scratch reg instead of the add/sub thing. --- We might be able to do this faster if we use the UA2007 instr set --- instead of restricting ourselves to SPARC V9. +-- TODO: It'd be better to use a scratch reg instead of the add/sub thing. +-- We might be able to do this faster if we use the UA2007 instr set +-- instead of restricting ourselves to SPARC V9. -- expandMisalignedDoubles :: Instr -> OrdList Instr expandMisalignedDoubles instr - -- Translate to: - -- add g1,g2,g1 - -- ld [g1],%fn - -- ld [g1+4],%f(n+1) - -- sub g1,g2,g1 -- to restore g1 - | LD FF64 (AddrRegReg r1 r2) fReg <- instr - = toOL [ ADD False False r1 (RIReg r2) r1 - , LD FF32 (AddrRegReg r1 g0) fReg - , LD FF32 (AddrRegImm r1 (ImmInt 4)) (fRegHi fReg) - , SUB False False r1 (RIReg r2) r1 ] - - -- Translate to - -- ld [addr],%fn - -- ld [addr+4],%f(n+1) - | LD FF64 addr fReg <- instr - = let Just addr' = addrOffset addr 4 - in toOL [ LD FF32 addr fReg - , LD FF32 addr' (fRegHi fReg) ] - - -- Translate to: - -- add g1,g2,g1 - -- st %fn,[g1] - -- st %f(n+1),[g1+4] - -- sub g1,g2,g1 -- to restore g1 - | ST FF64 fReg (AddrRegReg r1 r2) <- instr - = toOL [ ADD False False r1 (RIReg r2) r1 - , ST FF32 fReg (AddrRegReg r1 g0) - , ST FF32 (fRegHi fReg) (AddrRegImm r1 (ImmInt 4)) - , SUB False False r1 (RIReg r2) r1 ] - - -- Translate to - -- ld [addr],%fn - -- ld [addr+4],%f(n+1) - | ST FF64 fReg addr <- instr - = let Just addr' = addrOffset addr 4 - in toOL [ ST FF32 fReg addr - , ST FF32 (fRegHi fReg) addr' ] - - -- some other instr - | otherwise - = unitOL instr - - - --- | The the high partner for this float reg. + -- Translate to: + -- add g1,g2,g1 + -- ld [g1],%fn + -- ld [g1+4],%f(n+1) + -- sub g1,g2,g1 -- to restore g1 + | LD FF64 (AddrRegReg r1 r2) fReg <- instr + = toOL [ ADD False False r1 (RIReg r2) r1 + , LD FF32 (AddrRegReg r1 g0) fReg + , LD FF32 (AddrRegImm r1 (ImmInt 4)) (fRegHi fReg) + , SUB False False r1 (RIReg r2) r1 ] + + -- Translate to + -- ld [addr],%fn + -- ld [addr+4],%f(n+1) + | LD FF64 addr fReg <- instr + = let Just addr' = addrOffset addr 4 + in toOL [ LD FF32 addr fReg + , LD FF32 addr' (fRegHi fReg) ] + + -- Translate to: + -- add g1,g2,g1 + -- st %fn,[g1] + -- st %f(n+1),[g1+4] + -- sub g1,g2,g1 -- to restore g1 + | ST FF64 fReg (AddrRegReg r1 r2) <- instr + = toOL [ ADD False False r1 (RIReg r2) r1 + , ST FF32 fReg (AddrRegReg r1 g0) + , ST FF32 (fRegHi fReg) (AddrRegImm r1 (ImmInt 4)) + , SUB False False r1 (RIReg r2) r1 ] + + -- Translate to + -- ld [addr],%fn + -- ld [addr+4],%f(n+1) + | ST FF64 fReg addr <- instr + = let Just addr' = addrOffset addr 4 + in toOL [ ST FF32 fReg addr + , ST FF32 (fRegHi fReg) addr' ] + + -- some other instr + | otherwise + = unitOL instr + + + +-- | The the high partner for this float reg. fRegHi :: Reg -> Reg fRegHi (RegReal (RealRegSingle r1)) - | r1 >= 32 - , r1 <= 63 - , r1 `mod` 2 == 0 - = (RegReal $ RealRegSingle (r1 + 1)) - + | r1 >= 32 + , r1 <= 63 + , r1 `mod` 2 == 0 + = (RegReal $ RealRegSingle (r1 + 1)) + -- Can't take high partner for non-low reg. fRegHi reg - = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg) - - - - - - - + = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg) diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs index 43a26e525a..90fb41870d 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -1,15 +1,7 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Evaluation of 32 bit values. module SPARC.CodeGen.Gen32 ( - getSomeReg, - getRegister + getSomeReg, + getRegister ) where @@ -37,16 +29,16 @@ import OrdList import Outputable -- | The dual to getAnyReg: compute an expression into a register, but --- we don't mind which one it is. +-- we don't mind which one it is. getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) getSomeReg expr = do r <- getRegister expr case r of Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed _ reg code -> - return (reg, code) + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed _ reg code -> + return (reg, code) @@ -54,13 +46,13 @@ getSomeReg expr = do -- getRegister :: CmmExpr -> NatM Register -getRegister (CmmReg reg) +getRegister (CmmReg reg) = do dflags <- getDynFlags let platform = targetPlatform dflags return (Fixed (cmmTypeSize (cmmRegType dflags reg)) (getRegisterReg platform reg) nilOL) -getRegister tree@(CmmRegOff _ _) +getRegister tree@(CmmRegOff _ _) = do dflags <- getDynFlags getRegister (mangleIndexTree dflags tree) @@ -80,12 +72,12 @@ getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code + return $ Fixed II32 rlo code -- Load a literal float into a float register. --- The actual literal is stored in a new data area, and we load it --- at runtime. +-- The actual literal is stored in a new data area, and we load it +-- at runtime. getRegister (CmmLit (CmmFloat f W32)) = do -- a label for the new data area @@ -93,13 +85,13 @@ getRegister (CmmLit (CmmFloat f W32)) = do tmp <- getNewRegNat II32 let code dst = toOL [ - -- the data area - LDATA ReadOnlyData $ Statics lbl - [CmmStaticLit (CmmFloat f W32)], + -- the data area + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat f W32)], -- load the literal - SETHI (HI (ImmCLbl lbl)) tmp, - LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] + SETHI (HI (ImmCLbl lbl)) tmp, + LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] return (Any FF32 code) @@ -107,342 +99,342 @@ getRegister (CmmLit (CmmFloat d W64)) = do lbl <- getNewLabelNat tmp <- getNewRegNat II32 let code dst = toOL [ - LDATA ReadOnlyData $ Statics lbl - [CmmStaticLit (CmmFloat d W64)], - SETHI (HI (ImmCLbl lbl)) tmp, - LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat d W64)], + SETHI (HI (ImmCLbl lbl)) tmp, + LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] return (Any FF64 code) -- Unary machine ops getRegister (CmmMachOp mop [x]) = case mop of - -- Floating point negation ------------------------- - MO_F_Neg W32 -> trivialUFCode FF32 (FNEG FF32) x - MO_F_Neg W64 -> trivialUFCode FF64 (FNEG FF64) x + -- Floating point negation ------------------------- + MO_F_Neg W32 -> trivialUFCode FF32 (FNEG FF32) x + MO_F_Neg W64 -> trivialUFCode FF64 (FNEG FF64) x - -- Integer negation -------------------------------- - MO_S_Neg rep -> trivialUCode (intSize rep) (SUB False False g0) x - MO_Not rep -> trivialUCode (intSize rep) (XNOR False g0) x + -- Integer negation -------------------------------- + MO_S_Neg rep -> trivialUCode (intSize rep) (SUB False False g0) x + MO_Not rep -> trivialUCode (intSize rep) (XNOR False g0) x - -- Float word size conversion ---------------------- - MO_FF_Conv W64 W32 -> coerceDbl2Flt x - MO_FF_Conv W32 W64 -> coerceFlt2Dbl x + -- Float word size conversion ---------------------- + MO_FF_Conv W64 W32 -> coerceDbl2Flt x + MO_FF_Conv W32 W64 -> coerceFlt2Dbl x - -- Float <-> Signed Int conversion ----------------- - MO_FS_Conv from to -> coerceFP2Int from to x - MO_SF_Conv from to -> coerceInt2FP from to x + -- Float <-> Signed Int conversion ----------------- + MO_FS_Conv from to -> coerceFP2Int from to x + MO_SF_Conv from to -> coerceInt2FP from to x - -- Unsigned integer word size conversions ---------- + -- Unsigned integer word size conversions ---------- - -- If it's the same size, then nothing needs to be done. - MO_UU_Conv from to - | from == to -> conversionNop (intSize to) x + -- If it's the same size, then nothing needs to be done. + MO_UU_Conv from to + | from == to -> conversionNop (intSize to) x - -- To narrow an unsigned word, mask out the high bits to simulate what would - -- happen if we copied the value into a smaller register. - MO_UU_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - MO_UU_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) + -- To narrow an unsigned word, mask out the high bits to simulate what would + -- happen if we copied the value into a smaller register. + MO_UU_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) + MO_UU_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8 - -- case because the only way we can load it is via SETHI, which needs 2 ops. - -- Do some shifts to chop out the high bits instead. - MO_UU_Conv W32 W16 - -> do tmpReg <- getNewRegNat II32 - (xReg, xCode) <- getSomeReg x - let code dst - = xCode - `appOL` toOL - [ SLL xReg (RIImm $ ImmInt 16) tmpReg - , SRL tmpReg (RIImm $ ImmInt 16) dst] - - return $ Any II32 code - - -- trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) + -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8 + -- case because the only way we can load it is via SETHI, which needs 2 ops. + -- Do some shifts to chop out the high bits instead. + MO_UU_Conv W32 W16 + -> do tmpReg <- getNewRegNat II32 + (xReg, xCode) <- getSomeReg x + let code dst + = xCode + `appOL` toOL + [ SLL xReg (RIImm $ ImmInt 16) tmpReg + , SRL tmpReg (RIImm $ ImmInt 16) dst] - -- To widen an unsigned word we don't have to do anything. - -- Just leave it in the same register and mark the result as the new size. - MO_UU_Conv W8 W16 -> conversionNop (intSize W16) x - MO_UU_Conv W8 W32 -> conversionNop (intSize W32) x - MO_UU_Conv W16 W32 -> conversionNop (intSize W32) x + return $ Any II32 code + -- trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) - -- Signed integer word size conversions ------------ + -- To widen an unsigned word we don't have to do anything. + -- Just leave it in the same register and mark the result as the new size. + MO_UU_Conv W8 W16 -> conversionNop (intSize W16) x + MO_UU_Conv W8 W32 -> conversionNop (intSize W32) x + MO_UU_Conv W16 W32 -> conversionNop (intSize W32) x - -- Mask out high bits when narrowing them - MO_SS_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - MO_SS_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) - MO_SS_Conv W32 W16 -> trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) - -- Sign extend signed words when widening them. - MO_SS_Conv W8 W16 -> integerExtend W8 W16 x - MO_SS_Conv W8 W32 -> integerExtend W8 W32 x - MO_SS_Conv W16 W32 -> integerExtend W16 W32 x + -- Signed integer word size conversions ------------ - _ -> panic ("Unknown unary mach op: " ++ show mop) + -- Mask out high bits when narrowing them + MO_SS_Conv W16 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) + MO_SS_Conv W32 W8 -> trivialCode W8 (AND False) x (CmmLit (CmmInt 255 W8)) + MO_SS_Conv W32 W16 -> trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16)) + + -- Sign extend signed words when widening them. + MO_SS_Conv W8 W16 -> integerExtend W8 W16 x + MO_SS_Conv W8 W32 -> integerExtend W8 W32 x + MO_SS_Conv W16 W32 -> integerExtend W16 W32 x + + _ -> panic ("Unknown unary mach op: " ++ show mop) -- Binary machine ops -getRegister (CmmMachOp mop [x, y]) +getRegister (CmmMachOp mop [x, y]) = case mop of - MO_Eq _ -> condIntReg EQQ x y - MO_Ne _ -> condIntReg NE x y - - MO_S_Gt _ -> condIntReg GTT x y - MO_S_Ge _ -> condIntReg GE x y - MO_S_Lt _ -> condIntReg LTT x y - MO_S_Le _ -> condIntReg LE x y - - MO_U_Gt W32 -> condIntReg GU x y - MO_U_Ge W32 -> condIntReg GEU x y - MO_U_Lt W32 -> condIntReg LU x y - MO_U_Le W32 -> condIntReg LEU x y - - MO_U_Gt W16 -> condIntReg GU x y - MO_U_Ge W16 -> condIntReg GEU x y - MO_U_Lt W16 -> condIntReg LU x y - MO_U_Le W16 -> condIntReg LEU x y - - MO_Add W32 -> trivialCode W32 (ADD False False) x y - MO_Sub W32 -> trivialCode W32 (SUB False False) x y + MO_Eq _ -> condIntReg EQQ x y + MO_Ne _ -> condIntReg NE x y + + MO_S_Gt _ -> condIntReg GTT x y + MO_S_Ge _ -> condIntReg GE x y + MO_S_Lt _ -> condIntReg LTT x y + MO_S_Le _ -> condIntReg LE x y + + MO_U_Gt W32 -> condIntReg GU x y + MO_U_Ge W32 -> condIntReg GEU x y + MO_U_Lt W32 -> condIntReg LU x y + MO_U_Le W32 -> condIntReg LEU x y + + MO_U_Gt W16 -> condIntReg GU x y + MO_U_Ge W16 -> condIntReg GEU x y + MO_U_Lt W16 -> condIntReg LU x y + MO_U_Le W16 -> condIntReg LEU x y + + MO_Add W32 -> trivialCode W32 (ADD False False) x y + MO_Sub W32 -> trivialCode W32 (SUB False False) x y MO_S_MulMayOflo rep -> imulMayOflo rep x y - MO_S_Quot W32 -> idiv True False x y - MO_U_Quot W32 -> idiv False False x y - - MO_S_Rem W32 -> irem True x y - MO_U_Rem W32 -> irem False x y - - MO_F_Eq _ -> condFltReg EQQ x y - MO_F_Ne _ -> condFltReg NE x y + MO_S_Quot W32 -> idiv True False x y + MO_U_Quot W32 -> idiv False False x y + + MO_S_Rem W32 -> irem True x y + MO_U_Rem W32 -> irem False x y + + MO_F_Eq _ -> condFltReg EQQ x y + MO_F_Ne _ -> condFltReg NE x y - MO_F_Gt _ -> condFltReg GTT x y - MO_F_Ge _ -> condFltReg GE x y - MO_F_Lt _ -> condFltReg LTT x y - MO_F_Le _ -> condFltReg LE x y + MO_F_Gt _ -> condFltReg GTT x y + MO_F_Ge _ -> condFltReg GE x y + MO_F_Lt _ -> condFltReg LTT x y + MO_F_Le _ -> condFltReg LE x y - MO_F_Add w -> trivialFCode w FADD x y - MO_F_Sub w -> trivialFCode w FSUB x y - MO_F_Mul w -> trivialFCode w FMUL x y - MO_F_Quot w -> trivialFCode w FDIV x y + MO_F_Add w -> trivialFCode w FADD x y + MO_F_Sub w -> trivialFCode w FSUB x y + MO_F_Mul w -> trivialFCode w FMUL x y + MO_F_Quot w -> trivialFCode w FDIV x y - MO_And rep -> trivialCode rep (AND False) x y - MO_Or rep -> trivialCode rep (OR False) x y - MO_Xor rep -> trivialCode rep (XOR False) x y + MO_And rep -> trivialCode rep (AND False) x y + MO_Or rep -> trivialCode rep (OR False) x y + MO_Xor rep -> trivialCode rep (XOR False) x y - MO_Mul rep -> trivialCode rep (SMUL False) x y + MO_Mul rep -> trivialCode rep (SMUL False) x y - MO_Shl rep -> trivialCode rep SLL x y - MO_U_Shr rep -> trivialCode rep SRL x y - MO_S_Shr rep -> trivialCode rep SRA x y + MO_Shl rep -> trivialCode rep SLL x y + MO_U_Shr rep -> trivialCode rep SRL x y + MO_S_Shr rep -> trivialCode rep SRA x y - _ -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop) + _ -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop) where getRegister (CmmLoad mem pk) = do Amode src code <- getAmode mem let - code__2 dst = code `snocOL` LD (cmmTypeSize pk) src dst + code__2 dst = code `snocOL` LD (cmmTypeSize pk) src dst return (Any (cmmTypeSize pk) code__2) getRegister (CmmLit (CmmInt i _)) | fits13Bits i = let - src = ImmInt (fromInteger i) - code dst = unitOL (OR False g0 (RIImm src) dst) + src = ImmInt (fromInteger i) + code dst = unitOL (OR False g0 (RIImm src) dst) in - return (Any II32 code) + return (Any II32 code) getRegister (CmmLit lit) = let imm = litToImm lit - code dst = toOL [ - SETHI (HI imm) dst, - OR False dst (RIImm (LO imm)) dst] + code dst = toOL [ + SETHI (HI imm) dst, + OR False dst (RIImm (LO imm)) dst] in return (Any II32 code) getRegister _ - = panic "SPARC.CodeGen.Gen32.getRegister: no match" + = panic "SPARC.CodeGen.Gen32.getRegister: no match" -- | sign extend and widen -integerExtend - :: Width -- ^ width of source expression - -> Width -- ^ width of result - -> CmmExpr -- ^ source expression - -> NatM Register +integerExtend + :: Width -- ^ width of source expression + -> Width -- ^ width of result + -> CmmExpr -- ^ source expression + -> NatM Register integerExtend from to expr - = do -- load the expr into some register - (reg, e_code) <- getSomeReg expr - tmp <- getNewRegNat II32 - let bitCount - = case (from, to) of - (W8, W32) -> 24 - (W16, W32) -> 16 - (W8, W16) -> 24 - _ -> panic "SPARC.CodeGen.Gen32: no match" - let code dst - = e_code - - -- local shift word left to load the sign bit - `snocOL` SLL reg (RIImm (ImmInt bitCount)) tmp - - -- arithmetic shift right to sign extend - `snocOL` SRA tmp (RIImm (ImmInt bitCount)) dst - - return (Any (intSize to) code) - + = do -- load the expr into some register + (reg, e_code) <- getSomeReg expr + tmp <- getNewRegNat II32 + let bitCount + = case (from, to) of + (W8, W32) -> 24 + (W16, W32) -> 16 + (W8, W16) -> 24 + _ -> panic "SPARC.CodeGen.Gen32: no match" + let code dst + = e_code + + -- local shift word left to load the sign bit + `snocOL` SLL reg (RIImm (ImmInt bitCount)) tmp + + -- arithmetic shift right to sign extend + `snocOL` SRA tmp (RIImm (ImmInt bitCount)) dst + + return (Any (intSize to) code) + -- | For nop word format conversions we set the resulting value to have the --- required size, but don't need to generate any actual code. +-- required size, but don't need to generate any actual code. -- conversionNop - :: Size -> CmmExpr -> NatM Register + :: Size -> CmmExpr -> NatM Register conversionNop new_rep expr - = do e_code <- getRegister expr - return (setSizeOfRegister e_code new_rep) + = do e_code <- getRegister expr + return (setSizeOfRegister e_code new_rep) -- | Generate an integer division instruction. idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register - --- For unsigned division with a 32 bit numerator, --- we can just clear the Y register. -idiv False cc x y + +-- For unsigned division with a 32 bit numerator, +-- we can just clear the Y register. +idiv False cc x y = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ WRY g0 g0 - , UDIV cc a_reg (RIReg b_reg) dst] - - return (Any II32 code) - + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ WRY g0 g0 + , UDIV cc a_reg (RIReg b_reg) dst] + + return (Any II32 code) + -- For _signed_ division with a 32 bit numerator, --- we have to sign extend the numerator into the Y register. -idiv True cc x y +-- we have to sign extend the numerator into the Y register. +idiv True cc x y = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - tmp <- getNewRegNat II32 - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ SRA a_reg (RIImm (ImmInt 16)) tmp -- sign extend - , SRA tmp (RIImm (ImmInt 16)) tmp - - , WRY tmp g0 - , SDIV cc a_reg (RIReg b_reg) dst] - - return (Any II32 code) + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + tmp <- getNewRegNat II32 + + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ SRA a_reg (RIImm (ImmInt 16)) tmp -- sign extend + , SRA tmp (RIImm (ImmInt 16)) tmp + + , WRY tmp g0 + , SDIV cc a_reg (RIReg b_reg) dst] + + return (Any II32 code) -- | Do an integer remainder. -- --- NOTE: The SPARC v8 architecture manual says that integer division --- instructions _may_ generate a remainder, depending on the implementation. --- If so it is _recommended_ that the remainder is placed in the Y register. +-- NOTE: The SPARC v8 architecture manual says that integer division +-- instructions _may_ generate a remainder, depending on the implementation. +-- If so it is _recommended_ that the remainder is placed in the Y register. -- -- The UltraSparc 2007 manual says Y is _undefined_ after division. -- --- The SPARC T2 doesn't store the remainder, not sure about the others. --- It's probably best not to worry about it, and just generate our own --- remainders. +-- The SPARC T2 doesn't store the remainder, not sure about the others. +-- It's probably best not to worry about it, and just generate our own +-- remainders. -- irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register --- For unsigned operands: --- Division is between a 64 bit numerator and a 32 bit denominator, --- so we still have to clear the Y register. -irem False x y +-- For unsigned operands: +-- Division is between a 64 bit numerator and a 32 bit denominator, +-- so we still have to clear the Y register. +irem False x y = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + tmp_reg <- getNewRegNat II32 - tmp_reg <- getNewRegNat II32 + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ WRY g0 g0 + , UDIV False a_reg (RIReg b_reg) tmp_reg + , UMUL False tmp_reg (RIReg b_reg) tmp_reg + , SUB False False a_reg (RIReg tmp_reg) dst] + + return (Any II32 code) - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ WRY g0 g0 - , UDIV False a_reg (RIReg b_reg) tmp_reg - , UMUL False tmp_reg (RIReg b_reg) tmp_reg - , SUB False False a_reg (RIReg tmp_reg) dst] - - return (Any II32 code) - -- For signed operands: --- Make sure to sign extend into the Y register, or the remainder --- will have the wrong sign when the numerator is negative. +-- Make sure to sign extend into the Y register, or the remainder +-- will have the wrong sign when the numerator is negative. -- --- TODO: When sign extending, GCC only shifts the a_reg right by 17 bits, --- not the full 32. Not sure why this is, something to do with overflow? --- If anyone cares enough about the speed of signed remainder they --- can work it out themselves (then tell me). -- BL 2009/01/20 -irem True x y +-- TODO: When sign extending, GCC only shifts the a_reg right by 17 bits, +-- not the full 32. Not sure why this is, something to do with overflow? +-- If anyone cares enough about the speed of signed remainder they +-- can work it out themselves (then tell me). -- BL 2009/01/20 +irem True x y = do - (a_reg, a_code) <- getSomeReg x - (b_reg, b_code) <- getSomeReg y - - tmp1_reg <- getNewRegNat II32 - tmp2_reg <- getNewRegNat II32 - - let code dst - = a_code - `appOL` b_code - `appOL` toOL - [ SRA a_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend - , SRA tmp1_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend - , WRY tmp1_reg g0 - - , SDIV False a_reg (RIReg b_reg) tmp2_reg - , SMUL False tmp2_reg (RIReg b_reg) tmp2_reg - , SUB False False a_reg (RIReg tmp2_reg) dst] - - return (Any II32 code) - + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + tmp1_reg <- getNewRegNat II32 + tmp2_reg <- getNewRegNat II32 + + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ SRA a_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend + , SRA tmp1_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend + , WRY tmp1_reg g0 + + , SDIV False a_reg (RIReg b_reg) tmp2_reg + , SMUL False tmp2_reg (RIReg b_reg) tmp2_reg + , SUB False False a_reg (RIReg tmp2_reg) dst] + + return (Any II32 code) + imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register -imulMayOflo rep a b +imulMayOflo rep a b = do - (a_reg, a_code) <- getSomeReg a - (b_reg, b_code) <- getSomeReg b - res_lo <- getNewRegNat II32 - res_hi <- getNewRegNat II32 - - let shift_amt = case rep of - W32 -> 31 - W64 -> 63 - _ -> panic "shift_amt" - - let code dst = a_code `appOL` b_code `appOL` + (a_reg, a_code) <- getSomeReg a + (b_reg, b_code) <- getSomeReg b + res_lo <- getNewRegNat II32 + res_hi <- getNewRegNat II32 + + let shift_amt = case rep of + W32 -> 31 + W64 -> 63 + _ -> panic "shift_amt" + + let code dst = a_code `appOL` b_code `appOL` toOL [ SMUL False a_reg (RIReg b_reg) res_lo, RDY res_hi, SRA res_lo (RIImm (ImmInt shift_amt)) res_lo, SUB False False res_lo (RIReg res_hi) dst ] - return (Any II32 code) + return (Any II32 code) -- ----------------------------------------------------------------------------- @@ -458,19 +450,19 @@ imulMayOflo rep a b -- have handled the constant-folding. trivialCode - :: Width - -> (Reg -> RI -> Reg -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register - + :: Width + -> (Reg -> RI -> Reg -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register + trivialCode _ instr x (CmmLit (CmmInt y _)) | fits13Bits y = do (src1, code) <- getSomeReg x let - src2 = ImmInt (fromInteger y) - code__2 dst = code `snocOL` instr src1 (RIImm src2) dst + src2 = ImmInt (fromInteger y) + code__2 dst = code `snocOL` instr src1 (RIImm src2) dst return (Any II32 code__2) @@ -478,17 +470,17 @@ trivialCode _ instr x y = do (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y let - code__2 dst = code1 `appOL` code2 `snocOL` - instr src1 (RIReg src2) dst + code__2 dst = code1 `appOL` code2 `snocOL` + instr src1 (RIReg src2) dst return (Any II32 code__2) -trivialFCode - :: Width - -> (Size -> Reg -> Reg -> Reg -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register +trivialFCode + :: Width + -> (Size -> Reg -> Reg -> Reg -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register trivialFCode pk instr x y = do dflags <- getDynFlags @@ -496,49 +488,49 @@ trivialFCode pk instr x y = do (src2, code2) <- getSomeReg y tmp <- getNewRegNat FF64 let - promote x = FxTOy FF32 FF64 x tmp + promote x = FxTOy FF32 FF64 x tmp - pk1 = cmmExprType dflags x - pk2 = cmmExprType dflags y + pk1 = cmmExprType dflags x + pk2 = cmmExprType dflags y - code__2 dst = - if pk1 `cmmEqType` pk2 then - code1 `appOL` code2 `snocOL` - instr (floatSize pk) src1 src2 dst - else if typeWidth pk1 == W32 then - code1 `snocOL` promote src1 `appOL` code2 `snocOL` - instr FF64 tmp src2 dst - else - code1 `appOL` code2 `snocOL` promote src2 `snocOL` - instr FF64 src1 tmp dst - return (Any (cmmTypeSize $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64) - code__2) + code__2 dst = + if pk1 `cmmEqType` pk2 then + code1 `appOL` code2 `snocOL` + instr (floatSize pk) src1 src2 dst + else if typeWidth pk1 == W32 then + code1 `snocOL` promote src1 `appOL` code2 `snocOL` + instr FF64 tmp src2 dst + else + code1 `appOL` code2 `snocOL` promote src2 `snocOL` + instr FF64 src1 tmp dst + return (Any (cmmTypeSize $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64) + code__2) trivialUCode - :: Size - -> (RI -> Reg -> Instr) - -> CmmExpr - -> NatM Register - + :: Size + -> (RI -> Reg -> Instr) + -> CmmExpr + -> NatM Register + trivialUCode size instr x = do (src, code) <- getSomeReg x let - code__2 dst = code `snocOL` instr (RIReg src) dst + code__2 dst = code `snocOL` instr (RIReg src) dst return (Any size code__2) -trivialUFCode - :: Size - -> (Reg -> Reg -> Instr) - -> CmmExpr - -> NatM Register - +trivialUFCode + :: Size + -> (Reg -> Reg -> Instr) + -> CmmExpr + -> NatM Register + trivialUFCode pk instr x = do (src, code) <- getSomeReg x let - code__2 dst = code `snocOL` instr src dst + code__2 dst = code `snocOL` instr src dst return (Any pk code__2) @@ -551,10 +543,10 @@ coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register coerceInt2FP width1 width2 x = do (src, code) <- getSomeReg x let - code__2 dst = code `appOL` toOL [ - ST (intSize width1) src (spRel (-2)), - LD (intSize width1) (spRel (-2)) dst, - FxTOy (intSize width1) (floatSize width2) dst dst] + code__2 dst = code `appOL` toOL [ + ST (intSize width1) src (spRel (-2)), + LD (intSize width1) (spRel (-2)) dst, + FxTOy (intSize width1) (floatSize width2) dst dst] return (Any (floatSize $ width2) code__2) @@ -562,37 +554,37 @@ coerceInt2FP width1 width2 x = do -- | Coerce a floating point value to integer -- -- NOTE: On sparc v9 there are no instructions to move a value from an --- FP register directly to an int register, so we have to use a load/store. +-- FP register directly to an int register, so we have to use a load/store. -- coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register -coerceFP2Int width1 width2 x - = do let fsize1 = floatSize width1 - fsize2 = floatSize width2 - - isize2 = intSize width2 +coerceFP2Int width1 width2 x + = do let fsize1 = floatSize width1 + fsize2 = floatSize width2 + + isize2 = intSize width2 + + (fsrc, code) <- getSomeReg x + fdst <- getNewRegNat fsize2 - (fsrc, code) <- getSomeReg x - fdst <- getNewRegNat fsize2 - - let code2 dst - = code - `appOL` toOL - -- convert float to int format, leaving it in a float reg. - [ FxTOy fsize1 isize2 fsrc fdst + let code2 dst + = code + `appOL` toOL + -- convert float to int format, leaving it in a float reg. + [ FxTOy fsize1 isize2 fsrc fdst - -- store the int into mem, then load it back to move - -- it into an actual int reg. - , ST fsize2 fdst (spRel (-2)) - , LD isize2 (spRel (-2)) dst] + -- store the int into mem, then load it back to move + -- it into an actual int reg. + , ST fsize2 fdst (spRel (-2)) + , LD isize2 (spRel (-2)) dst] - return (Any isize2 code2) + return (Any isize2 code2) -- | Coerce a double precision floating point value to single precision. coerceDbl2Flt :: CmmExpr -> NatM Register coerceDbl2Flt x = do (src, code) <- getSomeReg x - return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst)) + return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst)) -- | Coerce a single precision floating point value to double precision @@ -607,44 +599,44 @@ coerceFlt2Dbl x = do -- Condition Codes ------------------------------------------------------------- -- -- Evaluate a comparison, and get the result into a register. --- +-- -- Do not fill the delay slots here. you will confuse the register allocator. -- condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register condIntReg EQQ x (CmmLit (CmmInt 0 _)) = do (src, code) <- getSomeReg x let - code__2 dst = code `appOL` toOL [ - SUB False True g0 (RIReg src) g0, - SUB True False g0 (RIImm (ImmInt (-1))) dst] + code__2 dst = code `appOL` toOL [ + SUB False True g0 (RIReg src) g0, + SUB True False g0 (RIImm (ImmInt (-1))) dst] return (Any II32 code__2) condIntReg EQQ x y = do (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y let - code__2 dst = code1 `appOL` code2 `appOL` toOL [ - XOR False src1 (RIReg src2) dst, - SUB False True g0 (RIReg dst) g0, - SUB True False g0 (RIImm (ImmInt (-1))) dst] + code__2 dst = code1 `appOL` code2 `appOL` toOL [ + XOR False src1 (RIReg src2) dst, + SUB False True g0 (RIReg dst) g0, + SUB True False g0 (RIImm (ImmInt (-1))) dst] return (Any II32 code__2) condIntReg NE x (CmmLit (CmmInt 0 _)) = do (src, code) <- getSomeReg x let - code__2 dst = code `appOL` toOL [ - SUB False True g0 (RIReg src) g0, - ADD True False g0 (RIImm (ImmInt 0)) dst] + code__2 dst = code `appOL` toOL [ + SUB False True g0 (RIReg src) g0, + ADD True False g0 (RIImm (ImmInt 0)) dst] return (Any II32 code__2) condIntReg NE x y = do (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y let - code__2 dst = code1 `appOL` code2 `appOL` toOL [ - XOR False src1 (RIReg src2) dst, - SUB False True g0 (RIReg dst) g0, - ADD True False g0 (RIImm (ImmInt 0)) dst] + code__2 dst = code1 `appOL` code2 `appOL` toOL [ + XOR False src1 (RIReg src2) dst, + SUB False True g0 (RIReg dst) g0, + ADD True False g0 (RIImm (ImmInt 0)) dst] return (Any II32 code__2) condIntReg cond x y = do @@ -652,22 +644,22 @@ condIntReg cond x y = do bid2 <- liftM (\a -> seq a a) getBlockIdNat CondCode _ cond cond_code <- condIntCode cond x y let - code__2 dst - = cond_code - `appOL` toOL - [ BI cond False bid1 - , NOP + code__2 dst + = cond_code + `appOL` toOL + [ BI cond False bid1 + , NOP - , OR False g0 (RIImm (ImmInt 0)) dst - , BI ALWAYS False bid2 - , NOP + , OR False g0 (RIImm (ImmInt 0)) dst + , BI ALWAYS False bid2 + , NOP - , NEWBLOCK bid1 - , OR False g0 (RIImm (ImmInt 1)) dst - , BI ALWAYS False bid2 - , NOP + , NEWBLOCK bid1 + , OR False g0 (RIImm (ImmInt 1)) dst + , BI ALWAYS False bid2 + , NOP - , NEWBLOCK bid2] + , NEWBLOCK bid2] return (Any II32 code__2) @@ -679,26 +671,22 @@ condFltReg cond x y = do CondCode _ cond cond_code <- condFltCode cond x y let - code__2 dst - = cond_code - `appOL` toOL - [ NOP - , BF cond False bid1 - , NOP + code__2 dst + = cond_code + `appOL` toOL + [ NOP + , BF cond False bid1 + , NOP - , OR False g0 (RIImm (ImmInt 0)) dst - , BI ALWAYS False bid2 - , NOP + , OR False g0 (RIImm (ImmInt 0)) dst + , BI ALWAYS False bid2 + , NOP - , NEWBLOCK bid1 - , OR False g0 (RIImm (ImmInt 1)) dst - , BI ALWAYS False bid2 - , NOP + , NEWBLOCK bid1 + , OR False g0 (RIImm (ImmInt 1)) dst + , BI ALWAYS False bid2 + , NOP - , NEWBLOCK bid2 ] + , NEWBLOCK bid2 ] return (Any II32 code__2) - - - - diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs index 5dff9ce704..81641326f2 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs @@ -1,22 +1,13 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - --- | One ounce of sanity checking is worth 10000000000000000 ounces --- of staring blindly at assembly code trying to find the problem.. --- +-- | One ounce of sanity checking is worth 10000000000000000 ounces +-- of staring blindly at assembly code trying to find the problem.. module SPARC.CodeGen.Sanity ( - checkBlock + checkBlock ) where import SPARC.Instr -import SPARC.Ppr () +import SPARC.Ppr () import Instruction import Cmm @@ -31,48 +22,46 @@ checkBlock :: CmmBlock -> NatBasicBlock Instr checkBlock cmm block@(BasicBlock _ instrs) - | checkBlockInstrs instrs - = block - - | otherwise - = pprPanic - ("SPARC.CodeGen: bad block\n") - ( vcat [ text " -- cmm -----------------\n" - , ppr cmm - , text " -- native code ---------\n" - , ppr block ]) + | checkBlockInstrs instrs + = block + + | otherwise + = pprPanic + ("SPARC.CodeGen: bad block\n") + ( vcat [ text " -- cmm -----------------\n" + , ppr cmm + , text " -- native code ---------\n" + , ppr block ]) checkBlockInstrs :: [Instr] -> Bool checkBlockInstrs ii - -- An unconditional jumps end the block. - -- There must be an unconditional jump in the block, otherwise - -- the register liveness determinator will get the liveness - -- information wrong. - -- - -- If the block ends with a cmm call that never returns - -- then there can be unreachable instructions after the jump, - -- but we don't mind here. - -- - | instr : NOP : _ <- ii - , isUnconditionalJump instr - = True - - -- All jumps must have a NOP in their branch delay slot. - -- The liveness determinator and register allocators aren't smart - -- enough to handle branch delay slots. - -- - | instr : NOP : is <- ii - , isJumpishInstr instr - = checkBlockInstrs is - - -- keep checking - | _:i2:is <- ii - = checkBlockInstrs (i2:is) - - -- this block is no good - | otherwise - = False - - + -- An unconditional jumps end the block. + -- There must be an unconditional jump in the block, otherwise + -- the register liveness determinator will get the liveness + -- information wrong. + -- + -- If the block ends with a cmm call that never returns + -- then there can be unreachable instructions after the jump, + -- but we don't mind here. + -- + | instr : NOP : _ <- ii + , isUnconditionalJump instr + = True + + -- All jumps must have a NOP in their branch delay slot. + -- The liveness determinator and register allocators aren't smart + -- enough to handle branch delay slots. + -- + | instr : NOP : is <- ii + , isJumpishInstr instr + = checkBlockInstrs is + + -- keep checking + | _:i2:is <- ii + = checkBlockInstrs (i2:is) + + -- this block is no good + | otherwise + = False diff --git a/compiler/nativeGen/SPARC/Cond.hs b/compiler/nativeGen/SPARC/Cond.hs index 198e4a7627..da41457950 100644 --- a/compiler/nativeGen/SPARC/Cond.hs +++ b/compiler/nativeGen/SPARC/Cond.hs @@ -1,39 +1,31 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.Cond ( - Cond(..), - condUnsigned, - condToSigned, - condToUnsigned + Cond(..), + condUnsigned, + condToSigned, + condToUnsigned ) where -- | Branch condition codes. data Cond - = ALWAYS - | EQQ - | GE - | GEU - | GTT - | GU - | LE - | LEU - | LTT - | LU - | NE - | NEG - | NEVER - | POS - | VC - | VS - deriving Eq + = ALWAYS + | EQQ + | GE + | GEU + | GTT + | GU + | LE + | LEU + | LTT + | LU + | NE + | NEG + | NEVER + | POS + | VC + | VS + deriving Eq condUnsigned :: Cond -> Bool diff --git a/compiler/nativeGen/SPARC/Imm.hs b/compiler/nativeGen/SPARC/Imm.hs index 844a08824b..cb53ba411c 100644 --- a/compiler/nativeGen/SPARC/Imm.hs +++ b/compiler/nativeGen/SPARC/Imm.hs @@ -1,16 +1,8 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.Imm ( - -- immediate values - Imm(..), - strImmLit, - litToImm + -- immediate values + Imm(..), + strImmLit, + litToImm ) where @@ -21,29 +13,29 @@ import CLabel import Outputable -- | An immediate value. --- Not all of these are directly representable by the machine. --- Things like ImmLit are slurped out and put in a data segment instead. +-- Not all of these are directly representable by the machine. +-- Things like ImmLit are slurped out and put in a data segment instead. -- data Imm - = ImmInt Int + = ImmInt Int - -- Sigh. - | ImmInteger Integer + -- Sigh. + | ImmInteger Integer - -- AbstractC Label (with baggage) - | ImmCLbl CLabel + -- AbstractC Label (with baggage) + | ImmCLbl CLabel - -- Simple string - | ImmLit SDoc - | ImmIndex CLabel Int - | ImmFloat Rational - | ImmDouble Rational + -- Simple string + | ImmLit SDoc + | ImmIndex CLabel Int + | ImmFloat Rational + | ImmDouble Rational - | ImmConstantSum Imm Imm - | ImmConstantDiff Imm Imm + | ImmConstantSum Imm Imm + | ImmConstantDiff Imm Imm - | LO Imm - | HI Imm + | LO Imm + | HI Imm -- | Create a ImmLit containing this string. @@ -52,24 +44,22 @@ strImmLit s = ImmLit (text s) -- | Convert a CmmLit to an Imm. --- Narrow to the width: a CmmInt might be out of --- range, but we assume that ImmInteger only contains --- in-range values. A signed value should be fine here. +-- Narrow to the width: a CmmInt might be out of +-- range, but we assume that ImmInteger only contains +-- in-range values. A signed value should be fine here. -- litToImm :: CmmLit -> Imm litToImm lit = case lit of - CmmInt i w -> ImmInteger (narrowS w i) - CmmFloat f W32 -> ImmFloat f - CmmFloat f W64 -> ImmDouble f - CmmLabel l -> ImmCLbl l - CmmLabelOff l off -> ImmIndex l off + CmmInt i w -> ImmInteger (narrowS w i) + CmmFloat f W32 -> ImmFloat f + CmmFloat f W64 -> ImmDouble f + CmmLabel l -> ImmCLbl l + CmmLabelOff l off -> ImmIndex l off - CmmLabelDiffOff l1 l2 off - -> ImmConstantSum - (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) - (ImmInt off) + CmmLabelDiffOff l1 l2 off + -> ImmConstantSum + (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) + (ImmInt off) _ -> panic "SPARC.Regs.litToImm: no match" - - diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 8e4a2b32df..fb8cc0cadc 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -7,28 +7,20 @@ -- (c) The University of Glasgow 1993-2004 -- ----------------------------------------------------------------------------- - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - #include "HsVersions.h" #include "nativeGen/NCG.h" module SPARC.Instr ( - RI(..), - riZero, - - fpRelEA, - moveSp, - - isUnconditionalJump, - - Instr(..), - maxSpillSlots + RI(..), + riZero, + + fpRelEA, + moveSp, + + isUnconditionalJump, + + Instr(..), + maxSpillSlots ) where @@ -57,23 +49,23 @@ import Platform -- | Register or immediate -data RI - = RIReg Reg - | RIImm Imm +data RI + = RIReg Reg + | RIImm Imm -- | Check if a RI represents a zero value. --- - a literal zero --- - register %g0, which is always zero. +-- - a literal zero +-- - register %g0, which is always zero. -- -riZero :: RI -> Bool -riZero (RIImm (ImmInt 0)) = True -riZero (RIImm (ImmInteger 0)) = True -riZero (RIReg (RegReal (RealRegSingle 0))) = True -riZero _ = False +riZero :: RI -> Bool +riZero (RIImm (ImmInt 0)) = True +riZero (RIImm (ImmInteger 0)) = True +riZero (RIReg (RegReal (RealRegSingle 0))) = True +riZero _ = False -- | Calculate the effective address which would be used by the --- corresponding fpRel sequence. +-- corresponding fpRel sequence. fpRelEA :: Int -> Reg -> Instr fpRelEA n dst = ADD False False fp (RIImm (ImmInt (n * wordLength))) dst @@ -88,294 +80,294 @@ moveSp n isUnconditionalJump :: Instr -> Bool isUnconditionalJump ii = case ii of - CALL{} -> True - JMP{} -> True - JMP_TBL{} -> True - BI ALWAYS _ _ -> True - BF ALWAYS _ _ -> True - _ -> False + CALL{} -> True + JMP{} -> True + JMP_TBL{} -> True + BI ALWAYS _ _ -> True + BF ALWAYS _ _ -> True + _ -> False -- | instance for sparc instruction set instance Instruction Instr where - regUsageOfInstr = sparc_regUsageOfInstr - patchRegsOfInstr = sparc_patchRegsOfInstr - isJumpishInstr = sparc_isJumpishInstr - jumpDestsOfInstr = sparc_jumpDestsOfInstr - patchJumpInstr = sparc_patchJumpInstr - mkSpillInstr = sparc_mkSpillInstr - mkLoadInstr = sparc_mkLoadInstr - takeDeltaInstr = sparc_takeDeltaInstr - isMetaInstr = sparc_isMetaInstr - mkRegRegMoveInstr = sparc_mkRegRegMoveInstr - takeRegRegMoveInstr = sparc_takeRegRegMoveInstr - mkJumpInstr = sparc_mkJumpInstr + regUsageOfInstr = sparc_regUsageOfInstr + patchRegsOfInstr = sparc_patchRegsOfInstr + isJumpishInstr = sparc_isJumpishInstr + jumpDestsOfInstr = sparc_jumpDestsOfInstr + patchJumpInstr = sparc_patchJumpInstr + mkSpillInstr = sparc_mkSpillInstr + mkLoadInstr = sparc_mkLoadInstr + takeDeltaInstr = sparc_takeDeltaInstr + isMetaInstr = sparc_isMetaInstr + mkRegRegMoveInstr = sparc_mkRegRegMoveInstr + takeRegRegMoveInstr = sparc_takeRegRegMoveInstr + mkJumpInstr = sparc_mkJumpInstr mkStackAllocInstr = panic "no sparc_mkStackAllocInstr" mkStackDeallocInstr = panic "no sparc_mkStackDeallocInstr" -- | SPARC instruction set. --- Not complete. This is only the ones we need. +-- Not complete. This is only the ones we need. -- data Instr - -- meta ops -------------------------------------------------- - -- comment pseudo-op - = COMMENT FastString - - -- some static data spat out during code generation. - -- Will be extracted before pretty-printing. - | LDATA Section CmmStatics - - -- Start a new basic block. Useful during codegen, removed later. - -- Preceding instruction should be a jump, as per the invariants - -- for a BasicBlock (see Cmm). - | NEWBLOCK BlockId - - -- specify current stack offset for benefit of subsequent passes. - | DELTA Int - - -- real instrs ----------------------------------------------- - -- Loads and stores. - | LD Size AddrMode Reg -- size, src, dst - | ST Size Reg AddrMode -- size, src, dst - - -- Int Arithmetic. - -- x: add/sub with carry bit. - -- In SPARC V9 addx and friends were renamed addc. - -- - -- cc: modify condition codes - -- - | ADD Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst - | SUB Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst - - | UMUL Bool Reg RI Reg -- cc?, src1, src2, dst - | SMUL Bool Reg RI Reg -- cc?, src1, src2, dst - - - -- The SPARC divide instructions perform 64bit by 32bit division - -- The Y register is xored into the first operand. - - -- On _some implementations_ the Y register is overwritten by - -- the remainder, so we have to make sure it is 0 each time. - - -- dst <- ((Y `shiftL` 32) `or` src1) `div` src2 - | UDIV Bool Reg RI Reg -- cc?, src1, src2, dst - | SDIV Bool Reg RI Reg -- cc?, src1, src2, dst - - | RDY Reg -- move contents of Y register to reg - | WRY Reg Reg -- Y <- src1 `xor` src2 - - -- Logic operations. - | AND Bool Reg RI Reg -- cc?, src1, src2, dst - | ANDN Bool Reg RI Reg -- cc?, src1, src2, dst - | OR Bool Reg RI Reg -- cc?, src1, src2, dst - | ORN Bool Reg RI Reg -- cc?, src1, src2, dst - | XOR Bool Reg RI Reg -- cc?, src1, src2, dst - | XNOR Bool Reg RI Reg -- cc?, src1, src2, dst - | SLL Reg RI Reg -- src1, src2, dst - | SRL Reg RI Reg -- src1, src2, dst - | SRA Reg RI Reg -- src1, src2, dst - - -- Load immediates. - | SETHI Imm Reg -- src, dst - - -- Do nothing. - -- Implemented by the assembler as SETHI 0, %g0, but worth an alias - | NOP - - -- Float Arithmetic. - -- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single - -- instructions right up until we spit them out. - -- - | FABS Size Reg Reg -- src dst - | FADD Size Reg Reg Reg -- src1, src2, dst - | FCMP Bool Size Reg Reg -- exception?, src1, src2, dst - | FDIV Size Reg Reg Reg -- src1, src2, dst - | FMOV Size Reg Reg -- src, dst - | FMUL Size Reg Reg Reg -- src1, src2, dst - | FNEG Size Reg Reg -- src, dst - | FSQRT Size Reg Reg -- src, dst - | FSUB Size Reg Reg Reg -- src1, src2, dst - | FxTOy Size Size Reg Reg -- src, dst - - -- Jumping around. - | BI Cond Bool BlockId -- cond, annul?, target - | BF Cond Bool BlockId -- cond, annul?, target - - | JMP AddrMode -- target - - -- With a tabled jump we know all the possible destinations. - -- We also need this info so we can work out what regs are live across the jump. - -- - | JMP_TBL AddrMode [Maybe BlockId] CLabel - - | CALL (Either Imm Reg) Int Bool -- target, args, terminal + -- meta ops -------------------------------------------------- + -- comment pseudo-op + = COMMENT FastString + + -- some static data spat out during code generation. + -- Will be extracted before pretty-printing. + | LDATA Section CmmStatics + + -- Start a new basic block. Useful during codegen, removed later. + -- Preceding instruction should be a jump, as per the invariants + -- for a BasicBlock (see Cmm). + | NEWBLOCK BlockId + + -- specify current stack offset for benefit of subsequent passes. + | DELTA Int + + -- real instrs ----------------------------------------------- + -- Loads and stores. + | LD Size AddrMode Reg -- size, src, dst + | ST Size Reg AddrMode -- size, src, dst + + -- Int Arithmetic. + -- x: add/sub with carry bit. + -- In SPARC V9 addx and friends were renamed addc. + -- + -- cc: modify condition codes + -- + | ADD Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst + | SUB Bool Bool Reg RI Reg -- x?, cc?, src1, src2, dst + + | UMUL Bool Reg RI Reg -- cc?, src1, src2, dst + | SMUL Bool Reg RI Reg -- cc?, src1, src2, dst + + + -- The SPARC divide instructions perform 64bit by 32bit division + -- The Y register is xored into the first operand. + + -- On _some implementations_ the Y register is overwritten by + -- the remainder, so we have to make sure it is 0 each time. + + -- dst <- ((Y `shiftL` 32) `or` src1) `div` src2 + | UDIV Bool Reg RI Reg -- cc?, src1, src2, dst + | SDIV Bool Reg RI Reg -- cc?, src1, src2, dst + + | RDY Reg -- move contents of Y register to reg + | WRY Reg Reg -- Y <- src1 `xor` src2 + + -- Logic operations. + | AND Bool Reg RI Reg -- cc?, src1, src2, dst + | ANDN Bool Reg RI Reg -- cc?, src1, src2, dst + | OR Bool Reg RI Reg -- cc?, src1, src2, dst + | ORN Bool Reg RI Reg -- cc?, src1, src2, dst + | XOR Bool Reg RI Reg -- cc?, src1, src2, dst + | XNOR Bool Reg RI Reg -- cc?, src1, src2, dst + | SLL Reg RI Reg -- src1, src2, dst + | SRL Reg RI Reg -- src1, src2, dst + | SRA Reg RI Reg -- src1, src2, dst + + -- Load immediates. + | SETHI Imm Reg -- src, dst + + -- Do nothing. + -- Implemented by the assembler as SETHI 0, %g0, but worth an alias + | NOP + + -- Float Arithmetic. + -- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single + -- instructions right up until we spit them out. + -- + | FABS Size Reg Reg -- src dst + | FADD Size Reg Reg Reg -- src1, src2, dst + | FCMP Bool Size Reg Reg -- exception?, src1, src2, dst + | FDIV Size Reg Reg Reg -- src1, src2, dst + | FMOV Size Reg Reg -- src, dst + | FMUL Size Reg Reg Reg -- src1, src2, dst + | FNEG Size Reg Reg -- src, dst + | FSQRT Size Reg Reg -- src, dst + | FSUB Size Reg Reg Reg -- src1, src2, dst + | FxTOy Size Size Reg Reg -- src, dst + + -- Jumping around. + | BI Cond Bool BlockId -- cond, annul?, target + | BF Cond Bool BlockId -- cond, annul?, target + + | JMP AddrMode -- target + + -- With a tabled jump we know all the possible destinations. + -- We also need this info so we can work out what regs are live across the jump. + -- + | JMP_TBL AddrMode [Maybe BlockId] CLabel + + | CALL (Either Imm Reg) Int Bool -- target, args, terminal -- | regUsage returns the sets of src and destination registers used --- by a particular instruction. Machine registers that are --- pre-allocated to stgRegs are filtered out, because they are --- uninteresting from a register allocation standpoint. (We wouldn't --- want them to end up on the free list!) As far as we are concerned, --- the fixed registers simply don't exist (for allocation purposes, --- anyway). - --- regUsage doesn't need to do any trickery for jumps and such. Just --- state precisely the regs read and written by that insn. The --- consequences of control flow transfers, as far as register --- allocation goes, are taken care of by the register allocator. +-- by a particular instruction. Machine registers that are +-- pre-allocated to stgRegs are filtered out, because they are +-- uninteresting from a register allocation standpoint. (We wouldn't +-- want them to end up on the free list!) As far as we are concerned, +-- the fixed registers simply don't exist (for allocation purposes, +-- anyway). + +-- regUsage doesn't need to do any trickery for jumps and such. Just +-- state precisely the regs read and written by that insn. The +-- consequences of control flow transfers, as far as register +-- allocation goes, are taken care of by the register allocator. -- sparc_regUsageOfInstr :: Platform -> Instr -> RegUsage sparc_regUsageOfInstr platform instr = case instr of - LD _ addr reg -> usage (regAddr addr, [reg]) - ST _ reg addr -> usage (reg : regAddr addr, []) - ADD _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SUB _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - UMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - UDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - RDY rd -> usage ([], [rd]) - WRY r1 r2 -> usage ([r1, r2], []) - AND _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ANDN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - OR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ORN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XNOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SLL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRA r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SETHI _ reg -> usage ([], [reg]) - FABS _ r1 r2 -> usage ([r1], [r2]) - FADD _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FCMP _ _ r1 r2 -> usage ([r1, r2], []) - FDIV _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FMOV _ r1 r2 -> usage ([r1], [r2]) - FMUL _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FNEG _ r1 r2 -> usage ([r1], [r2]) - FSQRT _ r1 r2 -> usage ([r1], [r2]) - FSUB _ r1 r2 r3 -> usage ([r1, r2], [r3]) - FxTOy _ _ r1 r2 -> usage ([r1], [r2]) - - JMP addr -> usage (regAddr addr, []) - JMP_TBL addr _ _ -> usage (regAddr addr, []) - - CALL (Left _ ) _ True -> noUsage - CALL (Left _ ) n False -> usage (argRegs n, callClobberedRegs) - CALL (Right reg) _ True -> usage ([reg], []) - CALL (Right reg) n False -> usage (reg : (argRegs n), callClobberedRegs) - _ -> noUsage + LD _ addr reg -> usage (regAddr addr, [reg]) + ST _ reg addr -> usage (reg : regAddr addr, []) + ADD _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SUB _ _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + UMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SMUL _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + UDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SDIV _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + RDY rd -> usage ([], [rd]) + WRY r1 r2 -> usage ([r1, r2], []) + AND _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + ANDN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + OR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + ORN _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + XOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + XNOR _ r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SLL r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SRL r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SRA r1 ar r2 -> usage (r1 : regRI ar, [r2]) + SETHI _ reg -> usage ([], [reg]) + FABS _ r1 r2 -> usage ([r1], [r2]) + FADD _ r1 r2 r3 -> usage ([r1, r2], [r3]) + FCMP _ _ r1 r2 -> usage ([r1, r2], []) + FDIV _ r1 r2 r3 -> usage ([r1, r2], [r3]) + FMOV _ r1 r2 -> usage ([r1], [r2]) + FMUL _ r1 r2 r3 -> usage ([r1, r2], [r3]) + FNEG _ r1 r2 -> usage ([r1], [r2]) + FSQRT _ r1 r2 -> usage ([r1], [r2]) + FSUB _ r1 r2 r3 -> usage ([r1, r2], [r3]) + FxTOy _ _ r1 r2 -> usage ([r1], [r2]) + + JMP addr -> usage (regAddr addr, []) + JMP_TBL addr _ _ -> usage (regAddr addr, []) + + CALL (Left _ ) _ True -> noUsage + CALL (Left _ ) n False -> usage (argRegs n, callClobberedRegs) + CALL (Right reg) _ True -> usage ([reg], []) + CALL (Right reg) n False -> usage (reg : (argRegs n), callClobberedRegs) + _ -> noUsage where - usage (src, dst) + usage (src, dst) = RU (filter (interesting platform) src) (filter (interesting platform) dst) - regAddr (AddrRegReg r1 r2) = [r1, r2] - regAddr (AddrRegImm r1 _) = [r1] + regAddr (AddrRegReg r1 r2) = [r1, r2] + regAddr (AddrRegImm r1 _) = [r1] - regRI (RIReg r) = [r] - regRI _ = [] + regRI (RIReg r) = [r] + regRI _ = [] --- | Interesting regs are virtuals, or ones that are allocatable --- by the register allocator. +-- | Interesting regs are virtuals, or ones that are allocatable +-- by the register allocator. interesting :: Platform -> Reg -> Bool interesting platform reg = case reg of - RegVirtual _ -> True - RegReal (RealRegSingle r1) -> isFastTrue (freeReg platform r1) - RegReal (RealRegPair r1 _) -> isFastTrue (freeReg platform r1) + RegVirtual _ -> True + RegReal (RealRegSingle r1) -> isFastTrue (freeReg platform r1) + RegReal (RealRegPair r1 _) -> isFastTrue (freeReg platform r1) -- | Apply a given mapping to tall the register references in this instruction. sparc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr sparc_patchRegsOfInstr instr env = case instr of - LD sz addr reg -> LD sz (fixAddr addr) (env reg) - ST sz reg addr -> ST sz (env reg) (fixAddr addr) - - ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2) - SUB x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2) - UMUL cc r1 ar r2 -> UMUL cc (env r1) (fixRI ar) (env r2) - SMUL cc r1 ar r2 -> SMUL cc (env r1) (fixRI ar) (env r2) - UDIV cc r1 ar r2 -> UDIV cc (env r1) (fixRI ar) (env r2) - SDIV cc r1 ar r2 -> SDIV cc (env r1) (fixRI ar) (env r2) - RDY rd -> RDY (env rd) - WRY r1 r2 -> WRY (env r1) (env r2) - AND b r1 ar r2 -> AND b (env r1) (fixRI ar) (env r2) - ANDN b r1 ar r2 -> ANDN b (env r1) (fixRI ar) (env r2) - OR b r1 ar r2 -> OR b (env r1) (fixRI ar) (env r2) - ORN b r1 ar r2 -> ORN b (env r1) (fixRI ar) (env r2) - XOR b r1 ar r2 -> XOR b (env r1) (fixRI ar) (env r2) - XNOR b r1 ar r2 -> XNOR b (env r1) (fixRI ar) (env r2) - SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2) - SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2) - SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2) - - SETHI imm reg -> SETHI imm (env reg) - - FABS s r1 r2 -> FABS s (env r1) (env r2) - FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3) - FCMP e s r1 r2 -> FCMP e s (env r1) (env r2) - FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3) - FMOV s r1 r2 -> FMOV s (env r1) (env r2) - FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3) - FNEG s r1 r2 -> FNEG s (env r1) (env r2) - FSQRT s r1 r2 -> FSQRT s (env r1) (env r2) - FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3) - FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2) - - JMP addr -> JMP (fixAddr addr) - JMP_TBL addr ids l -> JMP_TBL (fixAddr addr) ids l - - CALL (Left i) n t -> CALL (Left i) n t - CALL (Right r) n t -> CALL (Right (env r)) n t - _ -> instr + LD sz addr reg -> LD sz (fixAddr addr) (env reg) + ST sz reg addr -> ST sz (env reg) (fixAddr addr) + + ADD x cc r1 ar r2 -> ADD x cc (env r1) (fixRI ar) (env r2) + SUB x cc r1 ar r2 -> SUB x cc (env r1) (fixRI ar) (env r2) + UMUL cc r1 ar r2 -> UMUL cc (env r1) (fixRI ar) (env r2) + SMUL cc r1 ar r2 -> SMUL cc (env r1) (fixRI ar) (env r2) + UDIV cc r1 ar r2 -> UDIV cc (env r1) (fixRI ar) (env r2) + SDIV cc r1 ar r2 -> SDIV cc (env r1) (fixRI ar) (env r2) + RDY rd -> RDY (env rd) + WRY r1 r2 -> WRY (env r1) (env r2) + AND b r1 ar r2 -> AND b (env r1) (fixRI ar) (env r2) + ANDN b r1 ar r2 -> ANDN b (env r1) (fixRI ar) (env r2) + OR b r1 ar r2 -> OR b (env r1) (fixRI ar) (env r2) + ORN b r1 ar r2 -> ORN b (env r1) (fixRI ar) (env r2) + XOR b r1 ar r2 -> XOR b (env r1) (fixRI ar) (env r2) + XNOR b r1 ar r2 -> XNOR b (env r1) (fixRI ar) (env r2) + SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2) + SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2) + SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2) + + SETHI imm reg -> SETHI imm (env reg) + + FABS s r1 r2 -> FABS s (env r1) (env r2) + FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3) + FCMP e s r1 r2 -> FCMP e s (env r1) (env r2) + FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3) + FMOV s r1 r2 -> FMOV s (env r1) (env r2) + FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3) + FNEG s r1 r2 -> FNEG s (env r1) (env r2) + FSQRT s r1 r2 -> FSQRT s (env r1) (env r2) + FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3) + FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2) + + JMP addr -> JMP (fixAddr addr) + JMP_TBL addr ids l -> JMP_TBL (fixAddr addr) ids l + + CALL (Left i) n t -> CALL (Left i) n t + CALL (Right r) n t -> CALL (Right (env r)) n t + _ -> instr where - fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) - fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i + fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) + fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i - fixRI (RIReg r) = RIReg (env r) - fixRI other = other + fixRI (RIReg r) = RIReg (env r) + fixRI other = other -------------------------------------------------------------------------------- sparc_isJumpishInstr :: Instr -> Bool sparc_isJumpishInstr instr = case instr of - BI{} -> True - BF{} -> True - JMP{} -> True - JMP_TBL{} -> True - CALL{} -> True - _ -> False + BI{} -> True + BF{} -> True + JMP{} -> True + JMP_TBL{} -> True + CALL{} -> True + _ -> False sparc_jumpDestsOfInstr :: Instr -> [BlockId] sparc_jumpDestsOfInstr insn = case insn of - BI _ _ id -> [id] - BF _ _ id -> [id] - JMP_TBL _ ids _ -> [id | Just id <- ids] - _ -> [] + BI _ _ id -> [id] + BF _ _ id -> [id] + JMP_TBL _ ids _ -> [id | Just id <- ids] + _ -> [] sparc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr sparc_patchJumpInstr insn patchF = case insn of - BI cc annul id -> BI cc annul (patchF id) - BF cc annul id -> BF cc annul (patchF id) - JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l - _ -> insn + BI cc annul id -> BI cc annul (patchF id) + BF cc annul id -> BF cc annul (patchF id) + JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l + _ -> insn -------------------------------------------------------------------------------- -- | Make a spill instruction. --- On SPARC we spill below frame pointer leaving 2 words/spill +-- On SPARC we spill below frame pointer leaving 2 words/spill sparc_mkSpillInstr :: DynFlags -> Reg -- ^ register to spill @@ -387,12 +379,12 @@ sparc_mkSpillInstr dflags reg _ slot = let platform = targetPlatform dflags off = spillSlotToOffset dflags slot off_w = 1 + (off `div` 4) - sz = case targetClassOfReg platform reg of - RcInteger -> II32 - RcFloat -> FF32 - RcDouble -> FF64 - _ -> panic "sparc_mkSpillInstr" - + sz = case targetClassOfReg platform reg of + RcInteger -> II32 + RcFloat -> FF32 + RcDouble -> FF64 + _ -> panic "sparc_mkSpillInstr" + in ST sz reg (fpRel (negate off_w)) @@ -407,12 +399,12 @@ sparc_mkLoadInstr sparc_mkLoadInstr dflags reg _ slot = let platform = targetPlatform dflags off = spillSlotToOffset dflags slot - off_w = 1 + (off `div` 4) - sz = case targetClassOfReg platform reg of - RcInteger -> II32 - RcFloat -> FF32 - RcDouble -> FF64 - _ -> panic "sparc_mkLoadInstr" + off_w = 1 + (off `div` 4) + sz = case targetClassOfReg platform reg of + RcInteger -> II32 + RcFloat -> FF32 + RcDouble -> FF64 + _ -> panic "sparc_mkLoadInstr" in LD sz (fpRel (- off_w)) reg @@ -420,32 +412,32 @@ sparc_mkLoadInstr dflags reg _ slot -------------------------------------------------------------------------------- -- | See if this instruction is telling us the current C stack delta sparc_takeDeltaInstr - :: Instr - -> Maybe Int - + :: Instr + -> Maybe Int + sparc_takeDeltaInstr instr = case instr of - DELTA i -> Just i - _ -> Nothing + DELTA i -> Just i + _ -> Nothing sparc_isMetaInstr - :: Instr - -> Bool - + :: Instr + -> Bool + sparc_isMetaInstr instr = case instr of - COMMENT{} -> True - LDATA{} -> True - NEWBLOCK{} -> True - DELTA{} -> True - _ -> False - + COMMENT{} -> True + LDATA{} -> True + NEWBLOCK{} -> True + DELTA{} -> True + _ -> False + -- | Make a reg-reg move instruction. --- On SPARC v8 there are no instructions to move directly between --- floating point and integer regs. If we need to do that then we --- have to go via memory. +-- On SPARC v8 there are no instructions to move directly between +-- floating point and integer regs. If we need to do that then we +-- have to go via memory. -- sparc_mkRegRegMoveInstr :: Platform @@ -454,40 +446,39 @@ sparc_mkRegRegMoveInstr -> Instr sparc_mkRegRegMoveInstr platform src dst - | srcClass <- targetClassOfReg platform src - , dstClass <- targetClassOfReg platform dst - , srcClass == dstClass - = case srcClass of - RcInteger -> ADD False False src (RIReg g0) dst - RcDouble -> FMOV FF64 src dst - RcFloat -> FMOV FF32 src dst + | srcClass <- targetClassOfReg platform src + , dstClass <- targetClassOfReg platform dst + , srcClass == dstClass + = case srcClass of + RcInteger -> ADD False False src (RIReg g0) dst + RcDouble -> FMOV FF64 src dst + RcFloat -> FMOV FF32 src dst _ -> panic "sparc_mkRegRegMoveInstr" - - | otherwise - = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same" + + | otherwise + = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same" -- | Check whether an instruction represents a reg-reg move. --- The register allocator attempts to eliminate reg->reg moves whenever it can, --- by assigning the src and dest temporaries to the same real register. +-- The register allocator attempts to eliminate reg->reg moves whenever it can, +-- by assigning the src and dest temporaries to the same real register. -- sparc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg) sparc_takeRegRegMoveInstr instr = case instr of - ADD False False src (RIReg src2) dst - | g0 == src2 -> Just (src, dst) + ADD False False src (RIReg src2) dst + | g0 == src2 -> Just (src, dst) - FMOV FF64 src dst -> Just (src, dst) - FMOV FF32 src dst -> Just (src, dst) - _ -> Nothing + FMOV FF64 src dst -> Just (src, dst) + FMOV FF32 src dst -> Just (src, dst) + _ -> Nothing -- | Make an unconditional branch instruction. sparc_mkJumpInstr - :: BlockId - -> [Instr] - -sparc_mkJumpInstr id - = [BI ALWAYS False id - , NOP] -- fill the branch delay slot. + :: BlockId + -> [Instr] +sparc_mkJumpInstr id + = [BI ALWAYS False id + , NOP] -- fill the branch delay slot. diff --git a/compiler/nativeGen/SPARC/Regs.hs b/compiler/nativeGen/SPARC/Regs.hs index 01db0ed3ac..394389c4bf 100644 --- a/compiler/nativeGen/SPARC/Regs.hs +++ b/compiler/nativeGen/SPARC/Regs.hs @@ -1,39 +1,32 @@ -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 1994-2004 --- +-- -- ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.Regs ( - -- registers - showReg, - virtualRegSqueeze, - realRegSqueeze, - classOfRealReg, - allRealRegs, - - -- machine specific info - gReg, iReg, lReg, oReg, fReg, - fp, sp, g0, g1, g2, o0, o1, f0, f1, f6, f8, f22, f26, f27, - - -- allocatable - allocatableRegs, - - -- args - argRegs, - allArgRegs, - callClobberedRegs, - - -- - mkVirtualReg, - regDotColor + -- registers + showReg, + virtualRegSqueeze, + realRegSqueeze, + classOfRealReg, + allRealRegs, + + -- machine specific info + gReg, iReg, lReg, oReg, fReg, + fp, sp, g0, g1, g2, o0, o1, f0, f1, f6, f8, f22, f26, f27, + + -- allocatable + allocatableRegs, + + -- args + argRegs, + allArgRegs, + callClobberedRegs, + + -- + mkVirtualReg, + regDotColor ) where @@ -50,65 +43,65 @@ import FastTypes import FastBool {- - The SPARC has 64 registers of interest; 32 integer registers and 32 - floating point registers. The mapping of STG registers to SPARC - machine registers is defined in StgRegs.h. We are, of course, - prepared for any eventuality. - - The whole fp-register pairing thing on sparcs is a huge nuisance. See - includes/stg/MachRegs.h for a description of what's going on - here. + The SPARC has 64 registers of interest; 32 integer registers and 32 + floating point registers. The mapping of STG registers to SPARC + machine registers is defined in StgRegs.h. We are, of course, + prepared for any eventuality. + + The whole fp-register pairing thing on sparcs is a huge nuisance. See + includes/stg/MachRegs.h for a description of what's going on + here. -} -- | Get the standard name for the register with this number. showReg :: RegNo -> String showReg n - | n >= 0 && n < 8 = "%g" ++ show n - | n >= 8 && n < 16 = "%o" ++ show (n-8) - | n >= 16 && n < 24 = "%l" ++ show (n-16) - | n >= 24 && n < 32 = "%i" ++ show (n-24) - | n >= 32 && n < 64 = "%f" ++ show (n-32) - | otherwise = panic "SPARC.Regs.showReg: unknown sparc register" + | n >= 0 && n < 8 = "%g" ++ show n + | n >= 8 && n < 16 = "%o" ++ show (n-8) + | n >= 16 && n < 24 = "%l" ++ show (n-16) + | n >= 24 && n < 32 = "%i" ++ show (n-24) + | n >= 32 && n < 64 = "%f" ++ show (n-32) + | otherwise = panic "SPARC.Regs.showReg: unknown sparc register" -- Get the register class of a certain real reg classOfRealReg :: RealReg -> RegClass classOfRealReg reg = case reg of - RealRegSingle i - | i < 32 -> RcInteger - | otherwise -> RcFloat - - RealRegPair{} -> RcDouble + RealRegSingle i + | i < 32 -> RcInteger + | otherwise -> RcFloat + + RealRegPair{} -> RcDouble -- | regSqueeze_class reg --- Calculuate the maximum number of register colors that could be --- denied to a node of this class due to having this reg --- as a neighbour. +-- Calculuate the maximum number of register colors that could be +-- denied to a node of this class due to having this reg +-- as a neighbour. -- {-# INLINE virtualRegSqueeze #-} virtualRegSqueeze :: RegClass -> VirtualReg -> FastInt virtualRegSqueeze cls vr = case cls of - RcInteger - -> case vr of - VirtualRegI{} -> _ILIT(1) - VirtualRegHi{} -> _ILIT(1) + RcInteger + -> case vr of + VirtualRegI{} -> _ILIT(1) + VirtualRegHi{} -> _ILIT(1) _other -> _ILIT(0) - RcFloat - -> case vr of - VirtualRegF{} -> _ILIT(1) - VirtualRegD{} -> _ILIT(2) + RcFloat + -> case vr of + VirtualRegF{} -> _ILIT(1) + VirtualRegD{} -> _ILIT(2) _other -> _ILIT(0) - RcDouble - -> case vr of - VirtualRegF{} -> _ILIT(1) - VirtualRegD{} -> _ILIT(1) + RcDouble + -> case vr of + VirtualRegF{} -> _ILIT(1) + VirtualRegD{} -> _ILIT(1) _other -> _ILIT(0) _other -> _ILIT(0) @@ -118,48 +111,48 @@ realRegSqueeze :: RegClass -> RealReg -> FastInt realRegSqueeze cls rr = case cls of - RcInteger - -> case rr of - RealRegSingle regNo - | regNo < 32 -> _ILIT(1) - | otherwise -> _ILIT(0) - - RealRegPair{} -> _ILIT(0) - - RcFloat - -> case rr of - RealRegSingle regNo - | regNo < 32 -> _ILIT(0) - | otherwise -> _ILIT(1) - - RealRegPair{} -> _ILIT(2) - - RcDouble - -> case rr of - RealRegSingle regNo - | regNo < 32 -> _ILIT(0) - | otherwise -> _ILIT(1) - - RealRegPair{} -> _ILIT(1) - + RcInteger + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(1) + | otherwise -> _ILIT(0) + + RealRegPair{} -> _ILIT(0) + + RcFloat + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(0) + | otherwise -> _ILIT(1) + + RealRegPair{} -> _ILIT(2) + + RcDouble + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(0) + | otherwise -> _ILIT(1) + + RealRegPair{} -> _ILIT(1) + _other -> _ILIT(0) - --- | All the allocatable registers in the machine, --- including register pairs. + +-- | All the allocatable registers in the machine, +-- including register pairs. allRealRegs :: [RealReg] -allRealRegs - = [ (RealRegSingle i) | i <- [0..63] ] - ++ [ (RealRegPair i (i+1)) | i <- [32, 34 .. 62 ] ] +allRealRegs + = [ (RealRegSingle i) | i <- [0..63] ] + ++ [ (RealRegPair i (i+1)) | i <- [32, 34 .. 62 ] ] -- | Get the regno for this sort of reg gReg, lReg, iReg, oReg, fReg :: Int -> RegNo -gReg x = x -- global regs -oReg x = (8 + x) -- output regs -lReg x = (16 + x) -- local regs -iReg x = (24 + x) -- input regs -fReg x = (32 + x) -- float regs +gReg x = x -- global regs +oReg x = (8 + x) -- output regs +lReg x = (16 + x) -- local regs +iReg x = (24 + x) -- input regs +fReg x = (32 + x) -- float regs -- | Some specific regs used by the code generator. @@ -187,88 +180,87 @@ f1 = RegReal (RealRegSingle (fReg 1)) -- | Produce the second-half-of-a-double register given the first half. {- fPair :: Reg -> Maybe Reg -fPair (RealReg n) - | n >= 32 && n `mod` 2 == 0 = Just (RealReg (n+1)) +fPair (RealReg n) + | n >= 32 && n `mod` 2 == 0 = Just (RealReg (n+1)) fPair (VirtualRegD u) - = Just (VirtualRegHi u) + = Just (VirtualRegHi u) fPair reg - = trace ("MachInstrs.fPair: can't get high half of supposed double reg " ++ showPpr reg) - Nothing + = trace ("MachInstrs.fPair: can't get high half of supposed double reg " ++ showPpr reg) + Nothing -} --- | All the regs that the register allocator can allocate to, --- with the the fixed use regs removed. --- +-- | All the regs that the register allocator can allocate to, +-- with the the fixed use regs removed. +-- allocatableRegs :: [RealReg] allocatableRegs - = let isFree rr - = case rr of - RealRegSingle r - -> isFastTrue (freeReg r) + = let isFree rr + = case rr of + RealRegSingle r + -> isFastTrue (freeReg r) - RealRegPair r1 r2 - -> isFastTrue (freeReg r1) - && isFastTrue (freeReg r2) + RealRegPair r1 r2 + -> isFastTrue (freeReg r1) + && isFastTrue (freeReg r2) - in filter isFree allRealRegs + in filter isFree allRealRegs --- | The registers to place arguments for function calls, --- for some number of arguments. +-- | The registers to place arguments for function calls, +-- for some number of arguments. -- argRegs :: RegNo -> [Reg] argRegs r = case r of - 0 -> [] - 1 -> map (RegReal . RealRegSingle . oReg) [0] - 2 -> map (RegReal . RealRegSingle . oReg) [0,1] - 3 -> map (RegReal . RealRegSingle . oReg) [0,1,2] - 4 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3] - 5 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4] - 6 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4,5] - _ -> panic "MachRegs.argRegs(sparc): don't know about >6 arguments!" + 0 -> [] + 1 -> map (RegReal . RealRegSingle . oReg) [0] + 2 -> map (RegReal . RealRegSingle . oReg) [0,1] + 3 -> map (RegReal . RealRegSingle . oReg) [0,1,2] + 4 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3] + 5 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4] + 6 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4,5] + _ -> panic "MachRegs.argRegs(sparc): don't know about >6 arguments!" -- | All all the regs that could possibly be returned by argRegs -- allArgRegs :: [Reg] -allArgRegs - = map (RegReal . RealRegSingle) [oReg i | i <- [0..5]] +allArgRegs + = map (RegReal . RealRegSingle) [oReg i | i <- [0..5]] --- These are the regs that we cannot assume stay alive over a C call. --- TODO: Why can we assume that o6 isn't clobbered? -- BL 2009/02 +-- These are the regs that we cannot assume stay alive over a C call. +-- TODO: Why can we assume that o6 isn't clobbered? -- BL 2009/02 -- callClobberedRegs :: [Reg] callClobberedRegs - = map (RegReal . RealRegSingle) - ( oReg 7 : - [oReg i | i <- [0..5]] ++ - [gReg i | i <- [1..7]] ++ - [fReg i | i <- [0..31]] ) + = map (RegReal . RealRegSingle) + ( oReg 7 : + [oReg i | i <- [0..5]] ++ + [gReg i | i <- [1..7]] ++ + [fReg i | i <- [0..31]] ) -- | Make a virtual reg with this size. mkVirtualReg :: Unique -> Size -> VirtualReg mkVirtualReg u size - | not (isFloatSize size) - = VirtualRegI u + | not (isFloatSize size) + = VirtualRegI u - | otherwise - = case size of - FF32 -> VirtualRegF u - FF64 -> VirtualRegD u - _ -> panic "mkVReg" + | otherwise + = case size of + FF32 -> VirtualRegF u + FF64 -> VirtualRegD u + _ -> panic "mkVReg" regDotColor :: RealReg -> SDoc regDotColor reg = case classOfRealReg reg of - RcInteger -> text "blue" - RcFloat -> text "red" - _other -> text "green" - + RcInteger -> text "blue" + RcFloat -> text "red" + _other -> text "green" diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs index 142ec6e65d..123a345130 100644 --- a/compiler/nativeGen/SPARC/ShortcutJump.hs +++ b/compiler/nativeGen/SPARC/ShortcutJump.hs @@ -1,17 +1,9 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.ShortcutJump ( - JumpDest(..), getJumpDestBlockId, - canShortcut, - shortcutJump, - shortcutStatics, - shortBlockId + JumpDest(..), getJumpDestBlockId, + canShortcut, + shortcutJump, + shortcutStatics, + shortBlockId ) where @@ -28,9 +20,9 @@ import Unique -data JumpDest - = DestBlockId BlockId - | DestImm Imm +data JumpDest + = DestBlockId BlockId + | DestImm Imm getJumpDestBlockId :: JumpDest -> Maybe BlockId getJumpDestBlockId (DestBlockId bid) = Just bid @@ -59,9 +51,9 @@ shortcutLabel fn lab shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. shortcutStatic _ other_static @@ -75,6 +67,3 @@ shortBlockId fn blockid = Just (DestBlockId blockid') -> shortBlockId fn blockid' Just (DestImm (ImmCLbl lbl)) -> lbl _other -> panic "shortBlockId" - - - diff --git a/compiler/nativeGen/SPARC/Stack.hs b/compiler/nativeGen/SPARC/Stack.hs index 3560a0fe82..629b18789f 100644 --- a/compiler/nativeGen/SPARC/Stack.hs +++ b/compiler/nativeGen/SPARC/Stack.hs @@ -1,16 +1,8 @@ - -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module SPARC.Stack ( - spRel, - fpRel, - spillSlotToOffset, - maxSpillSlots + spRel, + fpRel, + spillSlotToOffset, + maxSpillSlots ) where @@ -24,43 +16,42 @@ import DynFlags import Outputable -- | Get an AddrMode relative to the address in sp. --- This gives us a stack relative addressing mode for volatile --- temporaries and for excess call arguments. +-- This gives us a stack relative addressing mode for volatile +-- temporaries and for excess call arguments. -- -spRel :: Int -- ^ stack offset in words, positive or negative +spRel :: Int -- ^ stack offset in words, positive or negative -> AddrMode -spRel n = AddrRegImm sp (ImmInt (n * wordLength)) +spRel n = AddrRegImm sp (ImmInt (n * wordLength)) -- | Get an address relative to the frame pointer. --- This doesn't work work for offsets greater than 13 bits; we just hope for the best +-- This doesn't work work for offsets greater than 13 bits; we just hope for the best -- fpRel :: Int -> AddrMode fpRel n - = AddrRegImm fp (ImmInt (n * wordLength)) + = AddrRegImm fp (ImmInt (n * wordLength)) -- | Convert a spill slot number to a *byte* offset, with no sign. -- spillSlotToOffset :: DynFlags -> Int -> Int spillSlotToOffset dflags slot - | slot >= 0 && slot < maxSpillSlots dflags - = 64 + spillSlotSize * slot + | slot >= 0 && slot < maxSpillSlots dflags + = 64 + spillSlotSize * slot - | otherwise - = pprPanic "spillSlotToOffset:" - ( text "invalid spill location: " <> int slot - $$ text "maxSpillSlots: " <> int (maxSpillSlots dflags)) + | otherwise + = pprPanic "spillSlotToOffset:" + ( text "invalid spill location: " <> int slot + $$ text "maxSpillSlots: " <> int (maxSpillSlots dflags)) -- | The maximum number of spill slots available on the C stack. --- If we use up all of the slots, then we're screwed. +-- If we use up all of the slots, then we're screwed. -- --- Why do we reserve 64 bytes, instead of using the whole thing?? --- -- BL 2009/02/15 +-- Why do we reserve 64 bytes, instead of using the whole thing?? +-- -- BL 2009/02/15 -- maxSpillSlots :: DynFlags -> Int maxSpillSlots dflags - = ((spillAreaLength dflags - 64) `div` spillSlotSize) - 1 - + = ((spillAreaLength dflags - 64) `div` spillSlotSize) - 1 diff --git a/compiler/nativeGen/Size.hs b/compiler/nativeGen/Size.hs index 1b95ceb98b..8fe590f1e9 100644 --- a/compiler/nativeGen/Size.hs +++ b/compiler/nativeGen/Size.hs @@ -1,22 +1,15 @@ -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Sizes on this architecture --- A Size is a combination of width and class --- --- TODO: Rename this to "Format" instead of "Size" to reflect --- the fact that it represents floating point vs integer. +-- A Size is a combination of width and class +-- +-- TODO: Rename this to "Format" instead of "Size" to reflect +-- the fact that it represents floating point vs integer. -- --- TODO: Signed vs unsigned? +-- TODO: Signed vs unsigned? -- --- TODO: This module is currenly shared by all architectures because --- NCGMonad need to know about it to make a VReg. It would be better --- to have architecture specific formats, and do the overloading --- properly. eg SPARC doesn't care about FF80. +-- TODO: This module is currenly shared by all architectures because +-- NCGMonad need to know about it to make a VReg. It would be better +-- to have architecture specific formats, and do the overloading +-- properly. eg SPARC doesn't care about FF80. -- module Size ( Size(..), @@ -37,76 +30,76 @@ import Outputable -- significance, here in the native code generator. You can change it -- without global consequences. -- --- A major use is as an opcode qualifier; thus the opcode --- mov.l a b --- might be encoded --- MOV II32 a b +-- A major use is as an opcode qualifier; thus the opcode +-- mov.l a b +-- might be encoded +-- MOV II32 a b -- where the Size field encodes the ".l" part. -- ToDo: it's not clear to me that we need separate signed-vs-unsigned sizes --- here. I've removed them from the x86 version, we'll see what happens --SDM +-- here. I've removed them from the x86 version, we'll see what happens --SDM -- ToDo: quite a few occurrences of Size could usefully be replaced by Width data Size - = II8 - | II16 - | II32 - | II64 - | FF32 - | FF64 - | FF80 - deriving (Show, Eq) + = II8 + | II16 + | II32 + | II64 + | FF32 + | FF64 + | FF80 + deriving (Show, Eq) -- | Get the integer size of this width. intSize :: Width -> Size intSize width = case width of - W8 -> II8 - W16 -> II16 - W32 -> II32 - W64 -> II64 - other -> pprPanic "Size.intSize" (ppr other) + W8 -> II8 + W16 -> II16 + W32 -> II32 + W64 -> II64 + other -> pprPanic "Size.intSize" (ppr other) -- | Get the float size of this width. floatSize :: Width -> Size floatSize width = case width of - W32 -> FF32 - W64 -> FF64 - other -> pprPanic "Size.floatSize" (ppr other) + W32 -> FF32 + W64 -> FF64 + other -> pprPanic "Size.floatSize" (ppr other) -- | Check if a size represents a floating point value. isFloatSize :: Size -> Bool isFloatSize size = case size of - FF32 -> True - FF64 -> True - FF80 -> True - _ -> False + FF32 -> True + FF64 -> True + FF80 -> True + _ -> False -- | Convert a Cmm type to a Size. cmmTypeSize :: CmmType -> Size -cmmTypeSize ty - | isFloatType ty = floatSize (typeWidth ty) - | otherwise = intSize (typeWidth ty) +cmmTypeSize ty + | isFloatType ty = floatSize (typeWidth ty) + | otherwise = intSize (typeWidth ty) -- | Get the Width of a Size. sizeToWidth :: Size -> Width sizeToWidth size = case size of - II8 -> W8 - II16 -> W16 - II32 -> W32 - II64 -> W64 - FF32 -> W32 - FF64 -> W64 - FF80 -> W80 + II8 -> W8 + II16 -> W16 + II32 -> W32 + II64 -> W64 + FF32 -> W32 + FF64 -> W64 + FF80 -> W80 sizeInBytes :: Size -> Int sizeInBytes = widthInBytes . sizeToWidth diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs index daf1e254c8..96c1777795 100644 --- a/compiler/nativeGen/TargetReg.hs +++ b/compiler/nativeGen/TargetReg.hs @@ -1,28 +1,20 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Hard wired things related to registers. --- This is module is preventing the native code generator being able to --- emit code for non-host architectures. +-- This is module is preventing the native code generator being able to +-- emit code for non-host architectures. -- --- TODO: Do a better job of the overloading, and eliminate this module. --- We'd probably do better with a Register type class, and hook this to --- Instruction somehow. +-- TODO: Do a better job of the overloading, and eliminate this module. +-- We'd probably do better with a Register type class, and hook this to +-- Instruction somehow. -- --- TODO: We should also make arch specific versions of RegAlloc.Graph.TrivColorable - +-- TODO: We should also make arch specific versions of RegAlloc.Graph.TrivColorable module TargetReg ( - targetVirtualRegSqueeze, - targetRealRegSqueeze, - targetClassOfRealReg, - targetMkVirtualReg, - targetRegDotColor, - targetClassOfReg + targetVirtualRegSqueeze, + targetRealRegSqueeze, + targetClassOfRealReg, + targetMkVirtualReg, + targetRegDotColor, + targetClassOfReg ) where @@ -132,5 +124,3 @@ targetClassOfReg platform reg = case reg of RegVirtual vr -> classOfVirtualReg vr RegReal rr -> targetClassOfRealReg platform rr - - diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index fa93767fa3..a9ff8f2853 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -41,7 +41,7 @@ import Platform -- Our intermediate code: import BasicTypes import BlockId -import Module ( primPackageId ) +import Module ( primPackageKey ) import PprCmm () import CmmUtils import Cmm @@ -1057,6 +1057,18 @@ getAmode' _ expr = do (reg,code) <- getSomeReg expr return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code) +-- | Like 'getAmode', but on 32-bit use simple register addressing +-- (i.e. no index register). This stops us from running out of +-- registers on x86 when using instructions such as cmpxchg, which can +-- use up to three virtual registers and one fixed register. +getSimpleAmode :: DynFlags -> Bool -> CmmExpr -> NatM Amode +getSimpleAmode dflags is32Bit addr + | is32Bit = do + addr_code <- getAnyReg addr + addr_r <- getNewRegNat (intSize (wordWidth dflags)) + let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0) + return $! Amode amode (addr_code addr_r) + | otherwise = getAmode addr x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode x86_complex_amode base index shift offset @@ -1749,7 +1761,7 @@ genCCall dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst] genCCall dflags is32Bit target dest_regs args where size = intSize width - lbl = mkCmmCodeLabel primPackageId (fsLit (popCntLabel width)) + lbl = mkCmmCodeLabel primPackageKey (fsLit (popCntLabel width)) genCCall dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args = do targetExpr <- cmmMakeDynamicReference dflags @@ -1759,7 +1771,97 @@ genCCall dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args = do CmmMayReturn) genCCall dflags is32Bit target dest_regs args where - lbl = mkCmmCodeLabel primPackageId (fsLit (word2FloatLabel width)) + lbl = mkCmmCodeLabel primPackageKey (fsLit (word2FloatLabel width)) + +genCCall dflags is32Bit (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = do + Amode amode addr_code <- + if amop `elem` [AMO_Add, AMO_Sub] + then getAmode addr + else getSimpleAmode dflags is32Bit addr -- See genCCall for MO_Cmpxchg + arg <- getNewRegNat size + arg_code <- getAnyReg n + use_sse2 <- sse2Enabled + let platform = targetPlatform dflags + dst_r = getRegisterReg platform use_sse2 (CmmLocal dst) + code <- op_code dst_r arg amode + return $ addr_code `appOL` arg_code arg `appOL` code + where + -- Code for the operation + op_code :: Reg -- Destination reg + -> Reg -- Register containing argument + -> AddrMode -- Address of location to mutate + -> NatM (OrdList Instr) + op_code dst_r arg amode = case amop of + -- In the common case where dst_r is a virtual register the + -- final move should go away, because it's the last use of arg + -- and the first use of dst_r. + AMO_Add -> return $ toOL [ LOCK (XADD size (OpReg arg) (OpAddr amode)) + , MOV size (OpReg arg) (OpReg dst_r) + ] + AMO_Sub -> return $ toOL [ NEGI size (OpReg arg) + , LOCK (XADD size (OpReg arg) (OpAddr amode)) + , MOV size (OpReg arg) (OpReg dst_r) + ] + AMO_And -> cmpxchg_code (\ src dst -> unitOL $ AND size src dst) + AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND size src dst + , NOT size dst + ]) + AMO_Or -> cmpxchg_code (\ src dst -> unitOL $ OR size src dst) + AMO_Xor -> cmpxchg_code (\ src dst -> unitOL $ XOR size src dst) + where + -- Simulate operation that lacks a dedicated instruction using + -- cmpxchg. + cmpxchg_code :: (Operand -> Operand -> OrdList Instr) + -> NatM (OrdList Instr) + cmpxchg_code instrs = do + lbl <- getBlockIdNat + tmp <- getNewRegNat size + return $ toOL + [ MOV size (OpAddr amode) (OpReg eax) + , JXX ALWAYS lbl + , NEWBLOCK lbl + -- Keep old value so we can return it: + , MOV size (OpReg eax) (OpReg dst_r) + , MOV size (OpReg eax) (OpReg tmp) + ] + `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL + [ LOCK (CMPXCHG size (OpReg tmp) (OpAddr amode)) + , JXX NE lbl + ] + + size = intSize width + +genCCall dflags _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] = do + load_code <- intLoadCode (MOV (intSize width)) addr + let platform = targetPlatform dflags + use_sse2 <- sse2Enabled + return (load_code (getRegisterReg platform use_sse2 (CmmLocal dst))) + +genCCall _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do + code <- assignMem_IntCode (intSize width) addr val + return $ code `snocOL` MFENCE + +genCCall dflags is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] = do + -- On x86 we don't have enough registers to use cmpxchg with a + -- complicated addressing mode, so on that architecture we + -- pre-compute the address first. + Amode amode addr_code <- getSimpleAmode dflags is32Bit addr + newval <- getNewRegNat size + newval_code <- getAnyReg new + oldval <- getNewRegNat size + oldval_code <- getAnyReg old + use_sse2 <- sse2Enabled + let platform = targetPlatform dflags + dst_r = getRegisterReg platform use_sse2 (CmmLocal dst) + code = toOL + [ MOV size (OpReg oldval) (OpReg eax) + , LOCK (CMPXCHG size (OpReg newval) (OpAddr amode)) + , MOV size (OpReg eax) (OpReg dst_r) + ] + return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval + `appOL` code + where + size = intSize width genCCall _ is32Bit target dest_regs args | is32Bit = genCCall32 target dest_regs args @@ -2385,6 +2487,11 @@ outOfLineCmmOp mop res args MO_PopCnt _ -> fsLit "popcnt" MO_BSwap _ -> fsLit "bswap" + MO_AtomicRMW _ _ -> fsLit "atomicrmw" + MO_AtomicRead _ -> fsLit "atomicread" + MO_AtomicWrite _ -> fsLit "atomicwrite" + MO_Cmpxchg _ -> fsLit "cmpxchg" + MO_UF_Conv _ -> unsupported MO_S_QuotRem {} -> unsupported diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 05fff9be96..172ce93f50 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -327,6 +327,11 @@ data Instr | PREFETCH PrefetchVariant Size Operand -- prefetch Variant, addr size, address to prefetch -- variant can be NTA, Lvl0, Lvl1, or Lvl2 + | LOCK Instr -- lock prefix + | XADD Size Operand Operand -- src (r), dst (r/m) + | CMPXCHG Size Operand Operand -- src (r), dst (r/m), eax implicit + | MFENCE + data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2 @@ -337,6 +342,8 @@ data Operand +-- | Returns which registers are read and written as a (read, written) +-- pair. x86_regUsageOfInstr :: Platform -> Instr -> RegUsage x86_regUsageOfInstr platform instr = case instr of @@ -428,10 +435,22 @@ x86_regUsageOfInstr platform instr -- note: might be a better way to do this PREFETCH _ _ src -> mkRU (use_R src []) [] + LOCK i -> x86_regUsageOfInstr platform i + XADD _ src dst -> usageMM src dst + CMPXCHG _ src dst -> usageRMM src dst (OpReg eax) + MFENCE -> noUsage _other -> panic "regUsage: unrecognised instr" - where + -- # Definitions + -- + -- Written: If the operand is a register, it's written. If it's an + -- address, registers mentioned in the address are read. + -- + -- Modified: If the operand is a register, it's both read and + -- written. If it's an address, registers mentioned in the address + -- are read. + -- 2 operand form; first operand Read; second Written usageRW :: Operand -> Operand -> RegUsage usageRW op (OpReg reg) = mkRU (use_R op []) [reg] @@ -444,6 +463,18 @@ x86_regUsageOfInstr platform instr usageRM op (OpAddr ea) = mkRUR (use_R op $! use_EA ea []) usageRM _ _ = panic "X86.RegInfo.usageRM: no match" + -- 2 operand form; first operand Modified; second Modified + usageMM :: Operand -> Operand -> RegUsage + usageMM (OpReg src) (OpReg dst) = mkRU [src, dst] [src, dst] + usageMM (OpReg src) (OpAddr ea) = mkRU (use_EA ea [src]) [src] + usageMM _ _ = panic "X86.RegInfo.usageMM: no match" + + -- 3 operand form; first operand Read; second Modified; third Modified + usageRMM :: Operand -> Operand -> Operand -> RegUsage + usageRMM (OpReg src) (OpReg dst) (OpReg reg) = mkRU [src, dst, reg] [dst, reg] + usageRMM (OpReg src) (OpAddr ea) (OpReg reg) = mkRU (use_EA ea [src, reg]) [reg] + usageRMM _ _ _ = panic "X86.RegInfo.usageRMM: no match" + -- 1 operand form; operand Modified usageM :: Operand -> RegUsage usageM (OpReg reg) = mkRU [reg] [reg] @@ -476,6 +507,7 @@ x86_regUsageOfInstr platform instr where src' = filter (interesting platform) src dst' = filter (interesting platform) dst +-- | Is this register interesting for the register allocator? interesting :: Platform -> Reg -> Bool interesting _ (RegVirtual _) = True interesting platform (RegReal (RealRegSingle i)) = isFastTrue (freeReg platform i) @@ -483,6 +515,8 @@ interesting _ (RegReal (RealRegPair{})) = panic "X86.interesting: no re +-- | Applies the supplied function to all registers in instructions. +-- Typically used to change virtual registers to real registers. x86_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr x86_patchRegsOfInstr instr env = case instr of @@ -571,6 +605,11 @@ x86_patchRegsOfInstr instr env PREFETCH lvl size src -> PREFETCH lvl size (patchOp src) + LOCK i -> LOCK (x86_patchRegsOfInstr i env) + XADD sz src dst -> patch2 (XADD sz) src dst + CMPXCHG sz src dst -> patch2 (CMPXCHG sz) src dst + MFENCE -> instr + _other -> panic "patchRegs: unrecognised instr" where diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 459c041ba5..15d29679b0 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -886,6 +886,16 @@ pprInstr GFREE ptext (sLit "\tffree %st(4) ;ffree %st(5)") ] +-- Atomics + +pprInstr (LOCK i) = ptext (sLit "\tlock") $$ pprInstr i + +pprInstr MFENCE = ptext (sLit "\tmfence") + +pprInstr (XADD size src dst) = pprSizeOpOp (sLit "xadd") size src dst + +pprInstr (CMPXCHG size src dst) = pprSizeOpOp (sLit "cmpxchg") size src dst + pprInstr _ = panic "X86.Ppr.pprInstr: no match" diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs index 0303295bc6..39535634d7 100644 --- a/compiler/nativeGen/X86/RegInfo.hs +++ b/compiler/nativeGen/X86/RegInfo.hs @@ -1,14 +1,7 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module X86.RegInfo ( - mkVirtualReg, - regDotColor + mkVirtualReg, + regDotColor ) where @@ -30,9 +23,9 @@ import X86.Regs mkVirtualReg :: Unique -> Size -> VirtualReg mkVirtualReg u size = case size of - FF32 -> VirtualRegSSE u - FF64 -> VirtualRegSSE u - FF80 -> VirtualRegD u + FF32 -> VirtualRegSSE u + FF64 -> VirtualRegSSE u + FF80 -> VirtualRegD u _other -> VirtualRegI u regDotColor :: Platform -> RealReg -> SDoc @@ -65,11 +58,10 @@ normalRegColors platform fpRegColors :: [(Reg,String)] fpRegColors = [ (fake0, "#ff00ff") - , (fake1, "#ff00aa") - , (fake2, "#aa00ff") - , (fake3, "#aa00aa") - , (fake4, "#ff0055") - , (fake5, "#5500ff") ] - - ++ zip (map regSingle [24..39]) (repeat "red") + , (fake1, "#ff00aa") + , (fake2, "#aa00ff") + , (fake3, "#aa00aa") + , (fake4, "#ff0055") + , (fake5, "#5500ff") ] + ++ zip (map regSingle [24..39]) (repeat "red") diff --git a/compiler/parser/Ctype.lhs b/compiler/parser/Ctype.lhs index c024ebe45a..7233f50e7f 100644 --- a/compiler/parser/Ctype.lhs +++ b/compiler/parser/Ctype.lhs @@ -2,32 +2,25 @@ Character classification \begin{code} {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Ctype - ( is_ident -- Char# -> Bool - , is_symbol -- Char# -> Bool - , is_any -- Char# -> Bool - , is_space -- Char# -> Bool - , is_lower -- Char# -> Bool - , is_upper -- Char# -> Bool - , is_digit -- Char# -> Bool - , is_alphanum -- Char# -> Bool - - , is_decdigit, is_hexdigit, is_octdigit, is_bindigit - , hexDigit, octDecDigit - ) where + ( is_ident -- Char# -> Bool + , is_symbol -- Char# -> Bool + , is_any -- Char# -> Bool + , is_space -- Char# -> Bool + , is_lower -- Char# -> Bool + , is_upper -- Char# -> Bool + , is_digit -- Char# -> Bool + , is_alphanum -- Char# -> Bool + + , is_decdigit, is_hexdigit, is_octdigit, is_bindigit + , hexDigit, octDecDigit + ) where #include "HsVersions.h" -import Data.Int ( Int32 ) -import Data.Bits ( Bits((.&.)) ) -import Data.Char ( ord, chr ) +import Data.Int ( Int32 ) +import Data.Bits ( Bits((.&.)) ) +import Data.Char ( ord, chr ) import Panic \end{code} @@ -76,13 +69,13 @@ octDecDigit c = ord c - ord '0' is_decdigit :: Char -> Bool is_decdigit c - = c >= '0' && c <= '9' + = c >= '0' && c <= '9' is_hexdigit :: Char -> Bool is_hexdigit c - = is_decdigit c - || (c >= 'a' && c <= 'f') - || (c >= 'A' && c <= 'F') + = is_decdigit c + || (c >= 'a' && c <= 'f') + || (c >= 'A' && c <= 'F') is_octdigit :: Char -> Bool is_octdigit c = c >= '0' && c <= '7' @@ -112,7 +105,7 @@ charType c = case c of '\7' -> 0 -- \007 '\8' -> 0 -- \010 '\9' -> cSpace -- \t (not allowed in strings, so !cAny) - '\10' -> cSpace -- \n (ditto) + '\10' -> cSpace -- \n (ditto) '\11' -> cSpace -- \v (ditto) '\12' -> cSpace -- \f (ditto) '\13' -> cSpace -- ^M (ditto) diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 78c39c75db..88a0f07d90 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -527,6 +527,10 @@ data Token | ITvect_scalar_prag | ITnovect_prag | ITminimal_prag + | IToverlappable_prag -- instance overlap mode + | IToverlapping_prag -- instance overlap mode + | IToverlaps_prag -- instance overlap mode + | ITincoherent_prag -- instance overlap mode | ITctype | ITdotdot -- reserved symbols @@ -1677,7 +1681,7 @@ getPState = P $ \s -> POk s s instance HasDynFlags P where getDynFlags = P $ \s -> POk s (dflags s) -withThisPackage :: (PackageId -> a) -> P a +withThisPackage :: (PackageKey -> a) -> P a withThisPackage f = do pkg <- liftM thisPackage getDynFlags return $ f pkg @@ -2428,6 +2432,10 @@ oneWordPrags = Map.fromList([("rules", rulePrag), ("vectorize", token ITvect_prag), ("novectorize", token ITnovect_prag), ("minimal", token ITminimal_prag), + ("overlaps", token IToverlaps_prag), + ("overlappable", token IToverlappable_prag), + ("overlapping", token IToverlapping_prag), + ("incoherent", token ITincoherent_prag), ("ctype", token ITctype)]) twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)), diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 4f4ec0b123..72dfc88fa6 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -16,8 +16,25 @@ -- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -module Parser ( parseModule, parseStmt, parseIdentifier, parseType, - parseHeader ) where +-- | This module provides the generated Happy parser for Haskell. It exports +-- a number of parsers which may be used in any library that uses the GHC API. +-- A common usage pattern is to initialize the parser state with a given string +-- and then parse that string: +-- +-- @ +-- runParser :: DynFlags -> String -> P a -> ParseResult a +-- runParser flags str parser = unP parser parseState +-- where +-- filename = "\<interactive\>" +-- location = mkRealSrcLoc (mkFastString filename) 1 1 +-- buffer = stringToStringBuffer str +-- parseState = mkPState flags buffer location in +-- @ +module Parser (parseModule, parseImport, parseStatement, + parseDeclaration, parseExpression, parseTypeSignature, + parseFullStmt, parseStmt, parseIdentifier, + parseType, parseHeader) where + import HsSyn import RdrHsSyn @@ -269,6 +286,10 @@ incorrect. '{-# NOVECTORISE' { L _ ITnovect_prag } '{-# MINIMAL' { L _ ITminimal_prag } '{-# CTYPE' { L _ ITctype } + '{-# OVERLAPPING' { L _ IToverlapping_prag } + '{-# OVERLAPPABLE' { L _ IToverlappable_prag } + '{-# OVERLAPS' { L _ IToverlaps_prag } + '{-# INCOHERENT' { L _ ITincoherent_prag } '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols @@ -360,12 +381,20 @@ TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } %monad { P } { >>= } { return } %lexer { lexer } { L _ ITeof } +%tokentype { (Located Token) } + +-- Exported parsers %name parseModule module +%name parseImport importdecl +%name parseStatement stmt +%name parseDeclaration topdecl +%name parseExpression exp +%name parseTypeSignature sigdecl +%name parseFullStmt stmt %name parseStmt maybe_stmt %name parseIdentifier identifier %name parseType ctype %partial parseHeader header -%tokentype { (Located Token) } %% ----------------------------------------------------------------------------- @@ -654,12 +683,13 @@ ty_decl :: { LTyClDecl RdrName } {% mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) } inst_decl :: { LInstDecl RdrName } - : 'instance' inst_type where_inst - { let (binds, sigs, _, ats, adts, _) = cvBindsAndSigs (unLoc $3) in - let cid = ClsInstDecl { cid_poly_ty = $2, cid_binds = binds + : 'instance' overlap_pragma inst_type where_inst + { let (binds, sigs, _, ats, adts, _) = cvBindsAndSigs (unLoc $4) in + let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_overlap_mode = $2 , cid_datafam_insts = adts } - in L (comb3 $1 $2 $3) (ClsInstD { cid_inst = cid }) } + in L (comb3 $1 $3 $4) (ClsInstD { cid_inst = cid }) } -- type instance declarations | 'type' 'instance' ty_fam_inst_eqn @@ -677,6 +707,14 @@ inst_decl :: { LInstDecl RdrName } {% mkDataFamInst (comb4 $1 $4 $6 $7) (unLoc $1) $3 $4 (unLoc $5) (unLoc $6) (unLoc $7) } +overlap_pragma :: { Maybe OverlapMode } + : '{-# OVERLAPPABLE' '#-}' { Just Overlappable } + | '{-# OVERLAPPING' '#-}' { Just Overlapping } + | '{-# OVERLAPS' '#-}' { Just Overlaps } + | '{-# INCOHERENT' '#-}' { Just Incoherent } + | {- empty -} { Nothing } + + -- Closed type families where_type_family :: { Located (FamilyInfo RdrName) } @@ -783,7 +821,7 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (Header (getSTR -- Glasgow extension: stand-alone deriving declarations stand_alone_deriving :: { LDerivDecl RdrName } - : 'deriving' 'instance' inst_type { LL (DerivDecl $3) } + : 'deriving' 'instance' overlap_pragma inst_type { LL (DerivDecl $4 $3) } ----------------------------------------------------------------------------- -- Role annotations @@ -810,17 +848,29 @@ role : VARID { L1 $ Just $ getVARID $1 } -- Glasgow extension: pattern synonyms pattern_synonym_decl :: { LHsDecl RdrName } - : 'pattern' con vars0 patsyn_token pat { LL . ValD $ mkPatSynBind $2 (PrefixPatSyn $3) $5 $4 } - | 'pattern' varid conop varid patsyn_token pat { LL . ValD $ mkPatSynBind $3 (InfixPatSyn $2 $4) $6 $5 } + : 'pattern' pat '=' pat + {% do { (name, args) <- splitPatSyn $2 + ; return $ LL . ValD $ mkPatSynBind name args $4 ImplicitBidirectional + }} + | 'pattern' pat '<-' pat + {% do { (name, args) <- splitPatSyn $2 + ; return $ LL . ValD $ mkPatSynBind name args $4 Unidirectional + }} + | 'pattern' pat '<-' pat where_decls + {% do { (name, args) <- splitPatSyn $2 + ; mg <- toPatSynMatchGroup name $5 + ; return $ LL . ValD $ + mkPatSynBind name args $4 (ExplicitBidirectional mg) + }} + +where_decls :: { Located (OrdList (LHsDecl RdrName)) } + : 'where' '{' decls '}' { $3 } + | 'where' vocurly decls close { $3 } vars0 :: { [Located RdrName] } : {- empty -} { [] } | varid vars0 { $1 : $2 } -patsyn_token :: { HsPatSynDir RdrName } - : '<-' { Unidirectional } - | '=' { ImplicitBidirectional } - ----------------------------------------------------------------------------- -- Nested declarations diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index af351b7f31..84a284f0ab 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -17,6 +17,7 @@ module RdrHsSyn ( mkTyFamInst, mkFamDecl, splitCon, mkInlinePragma, + splitPatSyn, toPatSynMatchGroup, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp mkTyLit, mkTyClD, mkInstD, @@ -34,6 +35,7 @@ module RdrHsSyn ( mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName mkSimpleConDecl, mkDeprecatedGadtRecordDecl, + mkATDefault, -- Bunch of functions in the parser monad for -- checking and constructing values @@ -73,7 +75,7 @@ import TysWiredIn ( unitTyCon, unitDataCon ) import ForeignCall import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameString ) -import PrelNames ( forall_tv_RDR ) +import PrelNames ( forall_tv_RDR, allNameStrings ) import DynFlags import SrcLoc import OrdList ( OrdList, fromOL ) @@ -124,16 +126,31 @@ mkClassDecl :: SrcSpan -> P (LTyClDecl RdrName) mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls - = do { let (binds, sigs, ats, at_defs, _, docs) = cvBindsAndSigs (unLoc where_cls) + = do { let (binds, sigs, ats, at_insts, _, docs) = cvBindsAndSigs (unLoc where_cls) cxt = fromMaybe (noLoc []) mcxt ; (cls, tparams) <- checkTyClHdr tycl_hdr - ; tyvars <- checkTyVars (ptext (sLit "class")) whereDots - cls tparams -- Only type vars allowed + ; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams + ; at_defs <- mapM (eitherToP . mkATDefault) at_insts ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars, tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds, tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs, tcdFVs = placeHolderNames })) } +mkATDefault :: LTyFamInstDecl RdrName + -> Either (SrcSpan, SDoc) (LTyFamDefltEqn RdrName) +-- Take a type-family instance declaration and turn it into +-- a type-family default equation for a class declaration +-- We parse things as the former and use this function to convert to the latter +-- +-- We use the Either monad because this also called +-- from Convert.hs +mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e })) + | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_rhs = rhs } <- e + = do { tvs <- checkTyVars (ptext (sLit "default")) equalsDots tc (hswb_cts pats) + ; return (L loc (TyFamEqn { tfe_tycon = tc + , tfe_pats = tvs + , tfe_rhs = rhs })) } + mkTyData :: SrcSpan -> NewOrData -> Maybe CType @@ -144,7 +161,7 @@ mkTyData :: SrcSpan -> P (LTyClDecl RdrName) mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams) <- checkTyClHdr tycl_hdr - ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams + ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars, tcdDataDefn = defn, @@ -172,7 +189,7 @@ mkTySynonym :: SrcSpan -> P (LTyClDecl RdrName) mkTySynonym loc lhs rhs = do { (tc, tparams) <- checkTyClHdr lhs - ; tyvars <- checkTyVars (ptext (sLit "type")) equalsDots tc tparams + ; tyvars <- checkTyVarsP (ptext (sLit "type")) equalsDots tc tparams ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars , tcdRhs = rhs, tcdFVs = placeHolderNames })) } @@ -181,9 +198,9 @@ mkTyFamInstEqn :: LHsType RdrName -> P (TyFamInstEqn RdrName) mkTyFamInstEqn lhs rhs = do { (tc, tparams) <- checkTyClHdr lhs - ; return (TyFamInstEqn { tfie_tycon = tc - , tfie_pats = mkHsWithBndrs tparams - , tfie_rhs = rhs }) } + ; return (TyFamEqn { tfe_tycon = tc + , tfe_pats = mkHsWithBndrs tparams + , tfe_rhs = rhs }) } mkDataFamInst :: SrcSpan -> NewOrData @@ -214,7 +231,7 @@ mkFamDecl :: SrcSpan -> P (LTyClDecl RdrName) mkFamDecl loc info lhs ksig = do { (tc, tparams) <- checkTyClHdr lhs - ; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams + ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams ; return (L loc (FamDecl (FamilyDecl { fdInfo = info, fdLName = tc , fdTyVars = tyvars, fdKindSig = ksig }))) } where @@ -412,6 +429,56 @@ splitCon ty mk_rest [L _ (HsRecTy flds)] = RecCon flds mk_rest ts = PrefixCon ts +splitPatSyn :: LPat RdrName + -> P (Located RdrName, HsPatSynDetails (Located RdrName)) +splitPatSyn (L _ (ParPat pat)) = splitPatSyn pat +splitPatSyn pat@(L loc (ConPatIn con details)) = do + details' <- case details of + PrefixCon pats -> liftM PrefixPatSyn (mapM patVar pats) + InfixCon pat1 pat2 -> liftM2 InfixPatSyn (patVar pat1) (patVar pat2) + RecCon{} -> recordPatSynErr loc pat + return (con, details') + where + patVar :: LPat RdrName -> P (Located RdrName) + patVar (L loc (VarPat v)) = return $ L loc v + patVar (L _ (ParPat pat)) = patVar pat + patVar (L loc pat) = parseErrorSDoc loc $ + text "Pattern synonym arguments must be variable names:" $$ + ppr pat +splitPatSyn pat@(L loc _) = parseErrorSDoc loc $ + text "invalid pattern synonym declaration:" $$ ppr pat + +recordPatSynErr :: SrcSpan -> LPat RdrName -> P a +recordPatSynErr loc pat = + parseErrorSDoc loc $ + text "record syntax not supported for pattern synonym declarations:" $$ + ppr pat + +toPatSynMatchGroup :: Located RdrName -> Located (OrdList (LHsDecl RdrName)) -> P (MatchGroup RdrName (LHsExpr RdrName)) +toPatSynMatchGroup (L _ patsyn_name) (L _ decls) = + do { matches <- mapM fromDecl (fromOL decls) + ; return $ mkMatchGroup FromSource matches } + where + fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn (L _ name) details)) rhs _ _ _))) = + do { unless (name == patsyn_name) $ + wrongNameBindingErr loc decl + ; match <- case details of + PrefixCon pats -> return $ Match pats Nothing rhs + InfixCon pat1 pat2 -> return $ Match [pat1, pat2] Nothing rhs + RecCon{} -> recordPatSynErr loc pat + ; return $ L loc match } + fromDecl (L loc decl) = extraDeclErr loc decl + + extraDeclErr loc decl = + parseErrorSDoc loc $ + text "pattern synonym 'where' clause must contain a single binding:" $$ + ppr decl + + wrongNameBindingErr loc decl = + parseErrorSDoc loc $ + text "pattern synonym 'where' clause must bind the pattern synonym's name" <+> + quotes (ppr patsyn_name) $$ ppr decl + mkDeprecatedGadtRecordDecl :: SrcSpan -> Located RdrName -> [ConDeclField RdrName] @@ -502,26 +569,42 @@ we can bring x,y into scope. So: * For RecCon we do not \begin{code} -checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName) +checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName) +-- Same as checkTyVars, but in the P monad +checkTyVarsP pp_what equals_or_where tc tparms + = eitherToP $ checkTyVars pp_what equals_or_where tc tparms + +eitherToP :: Either (SrcSpan, SDoc) a -> P a +-- Adapts the Either monad to the P monad +eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc +eitherToP (Right thing) = return thing +checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] + -> Either (SrcSpan, SDoc) (LHsTyVarBndrs RdrName) -- Check whether the given list of type parameters are all type variables --- (possibly with a kind signature). -checkTyVars pp_what equals_or_where tc tparms = do { tvs <- mapM chk tparms - ; return (mkHsQTvs tvs) } +-- (possibly with a kind signature) +-- We use the Either monad because it's also called (via mkATDefault) from +-- Convert.hs +checkTyVars pp_what equals_or_where tc tparms + = do { tvs <- mapM chk tparms + ; return (mkHsQTvs tvs) } where + -- Check that the name space is correct! chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) | isRdrTyVar tv = return (L l (KindedTyVar tv k)) chk (L l (HsTyVar tv)) | isRdrTyVar tv = return (L l (UserTyVar tv)) - chk t@(L l _) - = parseErrorSDoc l $ - vcat [ ptext (sLit "Unexpected type") <+> quotes (ppr t) - , ptext (sLit "In the") <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc) - , vcat[ (ptext (sLit "A") <+> pp_what <+> ptext (sLit "declaration should have form")) - , nest 2 (pp_what <+> ppr tc <+> ptext (sLit "a b c") - <+> equals_or_where) ] ] + chk t@(L loc _) + = Left (loc, + vcat [ ptext (sLit "Unexpected type") <+> quotes (ppr t) + , ptext (sLit "In the") <+> pp_what <+> ptext (sLit "declaration for") <+> quotes (ppr tc) + , vcat[ (ptext (sLit "A") <+> pp_what <+> ptext (sLit "declaration should have form")) + , nest 2 (pp_what <+> ppr tc + <+> hsep (map text (takeList tparms allNameStrings)) + <+> equals_or_where) ] ]) whereDots, equalsDots :: SDoc +-- Second argument to checkTyVars whereDots = ptext (sLit "where ...") equalsDots = ptext (sLit "= ...") diff --git a/compiler/parser/cutils.c b/compiler/parser/cutils.c index c42ec9e3ce..d714a0cb2a 100644 --- a/compiler/parser/cutils.c +++ b/compiler/parser/cutils.c @@ -37,7 +37,7 @@ ghc_memcmp_off( HsPtr a1, HsInt i, HsPtr a2, HsInt len ) } void -enableTimingStats( void ) /* called from the driver */ +enableTimingStats( void ) /* called from the driver */ { RtsFlags.GcFlags.giveStats = ONELINE_GC_STATS; } @@ -47,9 +47,7 @@ setHeapSize( HsInt size ) { RtsFlags.GcFlags.heapSizeSuggestion = size / BLOCK_SIZE; if (RtsFlags.GcFlags.maxHeapSize != 0 && - RtsFlags.GcFlags.heapSizeSuggestion > RtsFlags.GcFlags.maxHeapSize) { - RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion; + RtsFlags.GcFlags.heapSizeSuggestion > RtsFlags.GcFlags.maxHeapSize) { + RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion; } } - - diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs index 5072908e6a..232f69f67f 100644 --- a/compiler/prelude/ForeignCall.lhs +++ b/compiler/prelude/ForeignCall.lhs @@ -117,7 +117,7 @@ data CCallTarget = StaticTarget CLabelString -- C-land name of label. - (Maybe PackageId) -- What package the function is in. + (Maybe PackageKey) -- What package the function is in. -- If Nothing, then it's taken to be in the current package. -- Note: This information is only used for PrimCalls on Windows. -- See CLabel.labelDynamic and CoreToStg.coreToStgApp diff --git a/compiler/prelude/PrelInfo.lhs b/compiler/prelude/PrelInfo.lhs index 829b5e3bf9..eaefff2364 100644 --- a/compiler/prelude/PrelInfo.lhs +++ b/compiler/prelude/PrelInfo.lhs @@ -5,13 +5,6 @@ \begin{code} {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module PrelInfo ( wiredInIds, ghcPrimIds, primOpRules, builtinRules, @@ -19,7 +12,7 @@ module PrelInfo ( ghcPrimExports, wiredInThings, basicKnownKeyNames, primOpId, - + -- Random other things maybeCharLikeCon, maybeIntLikeCon, @@ -49,9 +42,9 @@ import Data.Array \end{code} %************************************************************************ -%* * +%* * \subsection[builtinNameInfo]{Lookup built-in names} -%* * +%* * %************************************************************************ Notes about wired in things @@ -59,13 +52,13 @@ Notes about wired in things * Wired-in things are Ids\/TyCons that are completely known to the compiler. They are global values in GHC, (e.g. listTyCon :: TyCon). -* A wired in Name contains the thing itself inside the Name: - see Name.wiredInNameTyThing_maybe - (E.g. listTyConName contains listTyCon. +* A wired in Name contains the thing itself inside the Name: + see Name.wiredInNameTyThing_maybe + (E.g. listTyConName contains listTyCon. * The name cache is initialised with (the names of) all wired-in things -* The type checker sees if the Name is wired in before looking up +* The type checker sees if the Name is wired in before looking up the name in the type environment. So the type envt itself contains no wired in things. @@ -78,17 +71,17 @@ wiredInThings :: [TyThing] -- This list is used only to initialise HscMain.knownKeyNames -- to ensure that when you say "Prelude.map" in your source code, you -- get a Name with the correct known key (See Note [Known-key names]) -wiredInThings +wiredInThings = concat - [ -- Wired in TyCons and their implicit Ids - tycon_things - , concatMap implicitTyThings tycon_things + [ -- Wired in TyCons and their implicit Ids + tycon_things + , concatMap implicitTyThings tycon_things - -- Wired in Ids - , map AnId wiredInIds + -- Wired in Ids + , map AnId wiredInIds - -- PrimOps - , map (AnId . primOpId) allThePrimOps + -- PrimOps + , map (AnId . primOpId) allThePrimOps ] where tycon_things = map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons @@ -100,16 +93,16 @@ sense of them in interface pragmas. It's cool, though they all have "non-standard" names, so they won't get past the parser in user code. %************************************************************************ -%* * - PrimOpIds -%* * +%* * + PrimOpIds +%* * %************************************************************************ \begin{code} -primOpIds :: Array Int Id +primOpIds :: Array Int Id -- A cache of the PrimOp Ids, indexed by PrimOp tag -primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op) - | op <- allThePrimOps ] +primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op) + | op <- allThePrimOps ] primOpId :: PrimOp -> Id primOpId op = primOpIds ! primOpTag op @@ -117,9 +110,9 @@ primOpId op = primOpIds ! primOpTag op %************************************************************************ -%* * +%* * \subsection{Export lists for pseudo-modules (GHC.Prim)} -%* * +%* * %************************************************************************ GHC.Prim "exports" all the primops and primitive types, some @@ -130,16 +123,16 @@ ghcPrimExports :: [IfaceExport] ghcPrimExports = map (Avail . idName) ghcPrimIds ++ map (Avail . idName . primOpId) allThePrimOps ++ - [ AvailTC n [n] + [ AvailTC n [n] | tc <- funTyCon : primTyCons, let n = tyConName tc ] \end{code} %************************************************************************ -%* * +%* * \subsection{Built-in keys} -%* * +%* * %************************************************************************ ToDo: make it do the ``like'' part properly (as in 0.26 and before). @@ -152,9 +145,9 @@ maybeIntLikeCon con = con `hasKey` intDataConKey %************************************************************************ -%* * +%* * \subsection{Class predicates} -%* * +%* * %************************************************************************ \begin{code} diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index e7408a16a8..7eefc33ea2 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -130,6 +130,19 @@ import FastString %************************************************************************ %* * + allNameStrings +%* * +%************************************************************************ + +\begin{code} +allNameStrings :: [String] +-- Infinite list of a,b,c...z, aa, ab, ac, ... etc +allNameStrings = [ c:cs | cs <- "" : allNameStrings, c <- ['a'..'z'] ] +\end{code} + + +%************************************************************************ +%* * \subsection{Local Names} %* * %************************************************************************ @@ -448,7 +461,7 @@ rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation mkInteractiveModule :: Int -> Module -- (mkInteractiveMoudule 9) makes module 'interactive:M9' -mkInteractiveModule n = mkModule interactivePackageId (mkModuleName ("Ghci" ++ show n)) +mkInteractiveModule n = mkModule interactivePackageKey (mkModuleName ("Ghci" ++ show n)) pRELUDE_NAME, mAIN_NAME :: ModuleName pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude") @@ -459,28 +472,28 @@ dATA_ARRAY_PARALLEL_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel") dATA_ARRAY_PARALLEL_PRIM_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel.Prim") mkPrimModule :: FastString -> Module -mkPrimModule m = mkModule primPackageId (mkModuleNameFS m) +mkPrimModule m = mkModule primPackageKey (mkModuleNameFS m) mkIntegerModule :: FastString -> Module -mkIntegerModule m = mkModule integerPackageId (mkModuleNameFS m) +mkIntegerModule m = mkModule integerPackageKey (mkModuleNameFS m) mkBaseModule :: FastString -> Module -mkBaseModule m = mkModule basePackageId (mkModuleNameFS m) +mkBaseModule m = mkModule basePackageKey (mkModuleNameFS m) mkBaseModule_ :: ModuleName -> Module -mkBaseModule_ m = mkModule basePackageId m +mkBaseModule_ m = mkModule basePackageKey m mkThisGhcModule :: FastString -> Module -mkThisGhcModule m = mkModule thisGhcPackageId (mkModuleNameFS m) +mkThisGhcModule m = mkModule thisGhcPackageKey (mkModuleNameFS m) mkThisGhcModule_ :: ModuleName -> Module -mkThisGhcModule_ m = mkModule thisGhcPackageId m +mkThisGhcModule_ m = mkModule thisGhcPackageKey m mkMainModule :: FastString -> Module -mkMainModule m = mkModule mainPackageId (mkModuleNameFS m) +mkMainModule m = mkModule mainPackageKey (mkModuleNameFS m) mkMainModule_ :: ModuleName -> Module -mkMainModule_ m = mkModule mainPackageId m +mkMainModule_ m = mkModule mainPackageKey m \end{code} %************************************************************************ @@ -823,20 +836,20 @@ inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey -- Base classes (Eq, Ord, Functor) fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name -eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey -eqName = methName gHC_CLASSES (fsLit "==") eqClassOpKey -ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey -geName = methName gHC_CLASSES (fsLit ">=") geClassOpKey -functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey -fmapName = methName gHC_BASE (fsLit "fmap") fmapClassOpKey +eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey +eqName = varQual gHC_CLASSES (fsLit "==") eqClassOpKey +ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey +geName = varQual gHC_CLASSES (fsLit ">=") geClassOpKey +functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey +fmapName = varQual gHC_BASE (fsLit "fmap") fmapClassOpKey -- Class Monad monadClassName, thenMName, bindMName, returnMName, failMName :: Name -monadClassName = clsQual gHC_BASE (fsLit "Monad") monadClassKey -thenMName = methName gHC_BASE (fsLit ">>") thenMClassOpKey -bindMName = methName gHC_BASE (fsLit ">>=") bindMClassOpKey -returnMName = methName gHC_BASE (fsLit "return") returnMClassOpKey -failMName = methName gHC_BASE (fsLit "fail") failMClassOpKey +monadClassName = clsQual gHC_BASE (fsLit "Monad") monadClassKey +thenMName = varQual gHC_BASE (fsLit ">>") thenMClassOpKey +bindMName = varQual gHC_BASE (fsLit ">>=") bindMClassOpKey +returnMName = varQual gHC_BASE (fsLit "return") returnMClassOpKey +failMName = varQual gHC_BASE (fsLit "fail") failMClassOpKey -- Classes (Applicative, Foldable, Traversable) applicativeClassName, foldableClassName, traversableClassName :: Name @@ -849,10 +862,10 @@ traversableClassName = clsQual dATA_TRAVERSABLE (fsLit "Traversable") trave -- AMP additions joinMName, apAName, pureAName, alternativeClassName :: Name -joinMName = methName mONAD (fsLit "join") joinMIdKey -apAName = methName cONTROL_APPLICATIVE (fsLit "<*>") apAClassOpKey -pureAName = methName cONTROL_APPLICATIVE (fsLit "pure") pureAClassOpKey -alternativeClassName = clsQual cONTROL_APPLICATIVE (fsLit "Alternative") alternativeClassKey +joinMName = varQual mONAD (fsLit "join") joinMIdKey +apAName = varQual cONTROL_APPLICATIVE (fsLit "<*>") apAClassOpKey +pureAName = varQual cONTROL_APPLICATIVE (fsLit "pure") pureAClassOpKey +alternativeClassName = clsQual cONTROL_APPLICATIVE (fsLit "Alternative") alternativeClassKey joinMIdKey, apAClassOpKey, pureAClassOpKey, alternativeClassKey :: Unique joinMIdKey = mkPreludeMiscIdUnique 750 @@ -870,7 +883,7 @@ fromStringName, otherwiseIdName, foldrName, buildName, augmentName, mapName, appendName, assertName, breakpointName, breakpointCondName, breakpointAutoName, opaqueTyConName :: Name -fromStringName = methName dATA_STRING (fsLit "fromString") fromStringClassOpKey +fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey otherwiseIdName = varQual gHC_BASE (fsLit "otherwise") otherwiseIdKey foldrName = varQual gHC_BASE (fsLit "foldr") foldrIdKey buildName = varQual gHC_BASE (fsLit "build") buildIdKey @@ -881,7 +894,7 @@ assertName = varQual gHC_BASE (fsLit "assert") assertIdKey breakpointName = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey breakpointAutoName= varQual gHC_BASE (fsLit "breakpointAuto") breakpointAutoIdKey -opaqueTyConName = tcQual gHC_BASE (fsLit "Opaque") opaqueTyConKey +opaqueTyConName = tcQual gHC_BASE (fsLit "Opaque") opaqueTyConKey breakpointJumpName :: Name breakpointJumpName @@ -909,10 +922,10 @@ sndName = varQual dATA_TUPLE (fsLit "snd") sndIdKey -- Module GHC.Num numClassName, fromIntegerName, minusName, negateName :: Name -numClassName = clsQual gHC_NUM (fsLit "Num") numClassKey -fromIntegerName = methName gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey -minusName = methName gHC_NUM (fsLit "-") minusClassOpKey -negateName = methName gHC_NUM (fsLit "negate") negateClassOpKey +numClassName = clsQual gHC_NUM (fsLit "Num") numClassKey +fromIntegerName = varQual gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey +minusName = varQual gHC_NUM (fsLit "-") minusClassOpKey +negateName = varQual gHC_NUM (fsLit "negate") negateClassOpKey integerTyConName, mkIntegerName, integerToWord64Name, integerToInt64Name, @@ -979,23 +992,23 @@ rationalTyConName, ratioTyConName, ratioDataConName, realClassName, integralClassName, realFracClassName, fractionalClassName, fromRationalName, toIntegerName, toRationalName, fromIntegralName, realToFracName :: Name -rationalTyConName = tcQual gHC_REAL (fsLit "Rational") rationalTyConKey -ratioTyConName = tcQual gHC_REAL (fsLit "Ratio") ratioTyConKey -ratioDataConName = conName gHC_REAL (fsLit ":%") ratioDataConKey -realClassName = clsQual gHC_REAL (fsLit "Real") realClassKey -integralClassName = clsQual gHC_REAL (fsLit "Integral") integralClassKey -realFracClassName = clsQual gHC_REAL (fsLit "RealFrac") realFracClassKey -fractionalClassName = clsQual gHC_REAL (fsLit "Fractional") fractionalClassKey -fromRationalName = methName gHC_REAL (fsLit "fromRational") fromRationalClassOpKey -toIntegerName = methName gHC_REAL (fsLit "toInteger") toIntegerClassOpKey -toRationalName = methName gHC_REAL (fsLit "toRational") toRationalClassOpKey -fromIntegralName = varQual gHC_REAL (fsLit "fromIntegral") fromIntegralIdKey -realToFracName = varQual gHC_REAL (fsLit "realToFrac") realToFracIdKey +rationalTyConName = tcQual gHC_REAL (fsLit "Rational") rationalTyConKey +ratioTyConName = tcQual gHC_REAL (fsLit "Ratio") ratioTyConKey +ratioDataConName = conName gHC_REAL (fsLit ":%") ratioDataConKey +realClassName = clsQual gHC_REAL (fsLit "Real") realClassKey +integralClassName = clsQual gHC_REAL (fsLit "Integral") integralClassKey +realFracClassName = clsQual gHC_REAL (fsLit "RealFrac") realFracClassKey +fractionalClassName = clsQual gHC_REAL (fsLit "Fractional") fractionalClassKey +fromRationalName = varQual gHC_REAL (fsLit "fromRational") fromRationalClassOpKey +toIntegerName = varQual gHC_REAL (fsLit "toInteger") toIntegerClassOpKey +toRationalName = varQual gHC_REAL (fsLit "toRational") toRationalClassOpKey +fromIntegralName = varQual gHC_REAL (fsLit "fromIntegral")fromIntegralIdKey +realToFracName = varQual gHC_REAL (fsLit "realToFrac") realToFracIdKey -- PrelFloat classes floatingClassName, realFloatClassName :: Name -floatingClassName = clsQual gHC_FLOAT (fsLit "Floating") floatingClassKey -realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey +floatingClassName = clsQual gHC_FLOAT (fsLit "Floating") floatingClassKey +realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey -- other GHC.Float functions rationalToFloatName, rationalToDoubleName :: Name @@ -1011,7 +1024,7 @@ typeableClassName, oldTypeableClassName, oldTypeable1ClassName, oldTypeable2ClassName, oldTypeable3ClassName, oldTypeable4ClassName, oldTypeable5ClassName, oldTypeable6ClassName, oldTypeable7ClassName :: Name -typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey +typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey oldTypeableClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable") oldTypeableClassKey oldTypeable1ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable1") oldTypeable1ClassKey oldTypeable2ClassName = clsQual oLDTYPEABLE_INTERNAL (fsLit "Typeable2") oldTypeable2ClassKey @@ -1037,33 +1050,33 @@ assertErrorName = varQual gHC_IO_Exception (fsLit "assertError") assertErrorId -- Enum module (Enum, Bounded) enumClassName, enumFromName, enumFromToName, enumFromThenName, enumFromThenToName, boundedClassName :: Name -enumClassName = clsQual gHC_ENUM (fsLit "Enum") enumClassKey -enumFromName = methName gHC_ENUM (fsLit "enumFrom") enumFromClassOpKey -enumFromToName = methName gHC_ENUM (fsLit "enumFromTo") enumFromToClassOpKey -enumFromThenName = methName gHC_ENUM (fsLit "enumFromThen") enumFromThenClassOpKey -enumFromThenToName = methName gHC_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey -boundedClassName = clsQual gHC_ENUM (fsLit "Bounded") boundedClassKey +enumClassName = clsQual gHC_ENUM (fsLit "Enum") enumClassKey +enumFromName = varQual gHC_ENUM (fsLit "enumFrom") enumFromClassOpKey +enumFromToName = varQual gHC_ENUM (fsLit "enumFromTo") enumFromToClassOpKey +enumFromThenName = varQual gHC_ENUM (fsLit "enumFromThen") enumFromThenClassOpKey +enumFromThenToName = varQual gHC_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey +boundedClassName = clsQual gHC_ENUM (fsLit "Bounded") boundedClassKey -- List functions concatName, filterName, zipName :: Name concatName = varQual gHC_LIST (fsLit "concat") concatIdKey filterName = varQual gHC_LIST (fsLit "filter") filterIdKey -zipName = varQual gHC_LIST (fsLit "zip") zipIdKey +zipName = varQual gHC_LIST (fsLit "zip") zipIdKey -- Overloaded lists isListClassName, fromListName, fromListNName, toListName :: Name -isListClassName = clsQual gHC_EXTS (fsLit "IsList") isListClassKey -fromListName = methName gHC_EXTS (fsLit "fromList") fromListClassOpKey -fromListNName = methName gHC_EXTS (fsLit "fromListN") fromListNClassOpKey -toListName = methName gHC_EXTS (fsLit "toList") toListClassOpKey +isListClassName = clsQual gHC_EXTS (fsLit "IsList") isListClassKey +fromListName = varQual gHC_EXTS (fsLit "fromList") fromListClassOpKey +fromListNName = varQual gHC_EXTS (fsLit "fromListN") fromListNClassOpKey +toListName = varQual gHC_EXTS (fsLit "toList") toListClassOpKey -- Class Show showClassName :: Name -showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey +showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey -- Class Read readClassName :: Name -readClassName = clsQual gHC_READ (fsLit "Read") readClassKey +readClassName = clsQual gHC_READ (fsLit "Read") readClassKey -- Classes Generic and Generic1, Datatype, Constructor and Selector genClassName, gen1ClassName, datatypeClassName, constructorClassName, @@ -1071,24 +1084,27 @@ genClassName, gen1ClassName, datatypeClassName, constructorClassName, genClassName = clsQual gHC_GENERICS (fsLit "Generic") genClassKey gen1ClassName = clsQual gHC_GENERICS (fsLit "Generic1") gen1ClassKey -datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey +datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey -selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey +selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey + +genericClassNames :: [Name] +genericClassNames = [genClassName, gen1ClassName] -- GHCi things ghciIoClassName, ghciStepIoMName :: Name ghciIoClassName = clsQual gHC_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey -ghciStepIoMName = methName gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey +ghciStepIoMName = varQual gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey -- IO things ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName, failIOName :: Name -ioTyConName = tcQual gHC_TYPES (fsLit "IO") ioTyConKey -ioDataConName = conName gHC_TYPES (fsLit "IO") ioDataConKey -thenIOName = varQual gHC_BASE (fsLit "thenIO") thenIOIdKey -bindIOName = varQual gHC_BASE (fsLit "bindIO") bindIOIdKey -returnIOName = varQual gHC_BASE (fsLit "returnIO") returnIOIdKey -failIOName = varQual gHC_IO (fsLit "failIO") failIOIdKey +ioTyConName = tcQual gHC_TYPES (fsLit "IO") ioTyConKey +ioDataConName = conName gHC_TYPES (fsLit "IO") ioDataConKey +thenIOName = varQual gHC_BASE (fsLit "thenIO") thenIOIdKey +bindIOName = varQual gHC_BASE (fsLit "bindIO") bindIOIdKey +returnIOName = varQual gHC_BASE (fsLit "returnIO") returnIOIdKey +failIOName = varQual gHC_IO (fsLit "failIO") failIOIdKey -- IO things printName :: Name @@ -1096,7 +1112,7 @@ printName = varQual sYSTEM_IO (fsLit "print") printIdKey -- Int, Word, and Addr things int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name -int8TyConName = tcQual gHC_INT (fsLit "Int8") int8TyConKey +int8TyConName = tcQual gHC_INT (fsLit "Int8") int8TyConKey int16TyConName = tcQual gHC_INT (fsLit "Int16") int16TyConKey int32TyConName = tcQual gHC_INT (fsLit "Int32") int32TyConKey int64TyConName = tcQual gHC_INT (fsLit "Int64") int64TyConKey @@ -1110,12 +1126,12 @@ word64TyConName = tcQual gHC_WORD (fsLit "Word64") word64TyConKey -- PrelPtr module ptrTyConName, funPtrTyConName :: Name -ptrTyConName = tcQual gHC_PTR (fsLit "Ptr") ptrTyConKey +ptrTyConName = tcQual gHC_PTR (fsLit "Ptr") ptrTyConKey funPtrTyConName = tcQual gHC_PTR (fsLit "FunPtr") funPtrTyConKey -- Foreign objects and weak pointers stablePtrTyConName, newStablePtrName :: Name -stablePtrTyConName = tcQual gHC_STABLE (fsLit "StablePtr") stablePtrTyConKey +stablePtrTyConName = tcQual gHC_STABLE (fsLit "StablePtr") stablePtrTyConKey newStablePtrName = varQual gHC_STABLE (fsLit "newStablePtr") newStablePtrIdKey -- PrelST module @@ -1125,21 +1141,21 @@ runSTRepName = varQual gHC_ST (fsLit "runSTRep") runSTRepIdKey -- Recursive-do notation monadFixClassName, mfixName :: Name monadFixClassName = clsQual mONAD_FIX (fsLit "MonadFix") monadFixClassKey -mfixName = methName mONAD_FIX (fsLit "mfix") mfixIdKey +mfixName = varQual mONAD_FIX (fsLit "mfix") mfixIdKey -- Arrow notation arrAName, composeAName, firstAName, appAName, choiceAName, loopAName :: Name -arrAName = varQual aRROW (fsLit "arr") arrAIdKey +arrAName = varQual aRROW (fsLit "arr") arrAIdKey composeAName = varQual gHC_DESUGAR (fsLit ">>>") composeAIdKey -firstAName = varQual aRROW (fsLit "first") firstAIdKey -appAName = varQual aRROW (fsLit "app") appAIdKey -choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey -loopAName = varQual aRROW (fsLit "loop") loopAIdKey +firstAName = varQual aRROW (fsLit "first") firstAIdKey +appAName = varQual aRROW (fsLit "app") appAIdKey +choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey +loopAName = varQual aRROW (fsLit "loop") loopAIdKey -- Monad comprehensions guardMName, liftMName, mzipName :: Name -guardMName = varQual mONAD (fsLit "guard") guardMIdKey -liftMName = varQual mONAD (fsLit "liftM") liftMIdKey +guardMName = varQual mONAD (fsLit "guard") guardMIdKey +liftMName = varQual mONAD (fsLit "liftM") liftMIdKey mzipName = varQual mONAD_ZIP (fsLit "mzip") mzipIdKey @@ -1150,9 +1166,9 @@ toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAn -- Other classes, needed for type defaulting monadPlusClassName, randomClassName, randomGenClassName, isStringClassName :: Name -monadPlusClassName = clsQual mONAD (fsLit "MonadPlus") monadPlusClassKey -randomClassName = clsQual rANDOM (fsLit "Random") randomClassKey -randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey +monadPlusClassName = clsQual mONAD (fsLit "MonadPlus") monadPlusClassKey +randomClassName = clsQual rANDOM (fsLit "Random") randomClassKey +randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey -- Type-level naturals @@ -1208,10 +1224,6 @@ mk_known_key_name space modu str unique conName :: Module -> FastString -> Unique -> Name conName modu occ unique = mkExternalName unique modu (mkOccNameFS dataName occ) noSrcSpan - -methName :: Module -> FastString -> Unique -> Name -methName modu occ unique - = mkExternalName unique modu (mkVarOccFS occ) noSrcSpan \end{code} %************************************************************************ diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs index 4155a541ba..198078bc9f 100644 --- a/compiler/prelude/PrimOp.lhs +++ b/compiler/prelude/PrimOp.lhs @@ -40,7 +40,7 @@ import Unique ( Unique, mkPrimOpIdUnique ) import Outputable import FastTypes import FastString -import Module ( PackageId ) +import Module ( PackageKey ) \end{code} %************************************************************************ @@ -329,27 +329,89 @@ Note [PrimOp can_fail and has_side_effects] Both can_fail and has_side_effects mean that the primop has some effect that is not captured entirely by its result value. - ---------- has_side_effects --------------------- - Has some imperative side effect, perhaps on the world (I/O), - or perhaps on some mutable data structure (writeIORef). - Generally speaking all such primops have a type like - State -> input -> (State, output) - so the state token guarantees ordering, and also ensures - that the primop is executed even if 'output' is discarded. - - ---------- can_fail ---------------------------- - Can fail with a seg-fault or divide-by-zero error on some elements - of its input domain. Main examples: - division (fails on zero demoninator - array indexing (fails if the index is out of bounds) - However (ASSUMPTION), these can_fail primops are ALWAYS surrounded - with a test that checks for the bad cases. - -Consequences: - -* You can discard a can_fail primop, or float it _inwards_. - But you cannot float it _outwards_, lest you escape the - dynamic scope of the test. Example: +---------- has_side_effects --------------------- +A primop "has_side_effects" if it has some *write* effect, visible +elsewhere + - writing to the world (I/O) + - writing to a mutable data structure (writeIORef) + - throwing a synchronous Haskell exception + +Often such primops have a type like + State -> input -> (State, output) +so the state token guarantees ordering. In general we rely *only* on +data dependencies of the state token to enforce write-effect ordering + + * NB1: if you inline unsafePerformIO, you may end up with + side-effecting ops whose 'state' output is discarded. + And programmers may do that by hand; see Trac #9390. + That is why we (conservatively) do not discard write-effecting + primops even if both their state and result is discarded. + + * NB2: We consider primops, such as raiseIO#, that can raise a + (Haskell) synchronous exception to "have_side_effects" but not + "can_fail". We must be careful about not discarding such things; + see the paper "A semantics for imprecise exceptions". + + * NB3: *Read* effects (like reading an IORef) don't count here, + because it doesn't matter if we don't do them, or do them more than + once. *Sequencing* is maintained by the data dependency of the state + token. + +---------- can_fail ---------------------------- +A primop "can_fail" if it can fail with an *unchecked* exception on +some elements of its input domain. Main examples: + division (fails on zero demoninator) + array indexing (fails if the index is out of bounds) + +An "unchecked exception" is one that is an outright error, (not +turned into a Haskell exception,) such as seg-fault or +divide-by-zero error. Such can_fail primops are ALWAYS surrounded +with a test that checks for the bad cases, but we need to be +very careful about code motion that might move it out of +the scope of the test. + +Note [Transformations affected by can_fail and has_side_effects] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The can_fail and has_side_effects properties have the following effect +on program transformations. Summary table is followed by details. + + can_fail has_side_effects +Discard NO NO +Float in YES YES +Float out NO NO +Duplicate YES NO + +* Discarding. case (a `op` b) of _ -> rhs ===> rhs + You should not discard a has_side_effects primop; e.g. + case (writeIntArray# a i v s of (# _, _ #) -> True + Arguably you should be able to discard this, since the + returned stat token is not used, but that relies on NEVER + inlining unsafePerformIO, and programmers sometimes write + this kind of stuff by hand (Trac #9390). So we (conservatively) + never discard a has_side_effects primop. + + However, it's fine to discard a can_fail primop. For example + case (indexIntArray# a i) of _ -> True + We can discard indexIntArray#; it has can_fail, but not + has_side_effects; see Trac #5658 which was all about this. + Notice that indexIntArray# is (in a more general handling of + effects) read effect, but we don't care about that here, and + treat read effects as *not* has_side_effects. + + Similarly (a `/#` b) can be discarded. It can seg-fault or + cause a hardware exception, but not a synchronous Haskell + exception. + + + + Synchronous Haskell exceptions, e.g. from raiseIO#, are treated + as has_side_effects and hence are not discarded. + +* Float in. You can float a can_fail or has_side_effects primop + *inwards*, but not inside a lambda (see Duplication below). + +* Float out. You must not float a can_fail primop *outwards* lest + you escape the dynamic scope of the test. Example: case d ># 0# of True -> case x /# d of r -> r +# 1 False -> 0 @@ -359,25 +421,21 @@ Consequences: True -> r +# 1 False -> 0 -* I believe that exactly the same rules apply to a has_side_effects - primop; you can discard it (remember, the state token will keep - it alive if necessary), or float it in, but not float it out. - - Example of the latter - if blah then let! s1 = writeMutVar s0 v True in s1 + Nor can you float out a has_side_effects primop. For example: + if blah then case writeMutVar# v True s0 of (# s1 #) -> s1 else s0 - Notice that s0 is mentioned in both branches of the 'if', but + Notice that s0 is mentioned in both branches of the 'if', but only one of these two will actually be consumed. But if we float out to - let! s1 = writeMutVar s0 v True - in if blah then s1 else s0 + case writeMutVar# v True s0 of (# s1 #) -> + if blah then s1 else s0 the writeMutVar will be performed in both branches, which is utterly wrong. -* You cannot duplicate a has_side_effect primop. You might wonder - how this can occur given the state token threading, but just look - at Control.Monad.ST.Lazy.Imp.strictToLazy! We get something like - this +* Duplication. You cannot duplicate a has_side_effect primop. You + might wonder how this can occur given the state token threading, but + just look at Control.Monad.ST.Lazy.Imp.strictToLazy! We get + something like this p = case readMutVar# s v of (# s', r #) -> (S# s', r) s' = case p of (s', r) -> s' @@ -385,28 +443,28 @@ Consequences: (All these bindings are boxed.) If we inline p at its two call sites, we get a catastrophe: because the read is performed once when - s' is demanded, and once when 'r' is demanded, which may be much + s' is demanded, and once when 'r' is demanded, which may be much later. Utterly wrong. Trac #3207 is real example of this happening. - However, it's fine to duplicate a can_fail primop. That is - the difference between can_fail and has_side_effects. + However, it's fine to duplicate a can_fail primop. That is really + the only difference between can_fail and has_side_effects. - can_fail has_side_effects -Discard YES YES -Float in YES YES -Float out NO NO -Duplicate YES NO +Note [Implementation: how can_fail/has_side_effects affect transformations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How do we ensure that that floating/duplication/discarding are done right +in the simplifier? -How do we achieve these effects? +Two main predicates on primpops test these flags: + primOpOkForSideEffects <=> not has_side_effects + primOpOkForSpeculation <=> not (has_side_effects || can_fail) -Note [primOpOkForSpeculation] * The "no-float-out" thing is achieved by ensuring that we never let-bind a can_fail or has_side_effects primop. The RHS of a let-binding (which can float in and out freely) satisfies - exprOkForSpeculation. And exprOkForSpeculation is false of - can_fail and no_side_effect. + exprOkForSpeculation; this is the let/app invariant. And + exprOkForSpeculation is false of can_fail and has_side_effects. - * So can_fail and no_side_effect primops will appear only as the + * So can_fail and has_side_effects primops will appear only as the scrutinees of cases, and that's why the FloatIn pass is capable of floating case bindings inwards. @@ -422,10 +480,14 @@ primOpCanFail :: PrimOp -> Bool #include "primop-can-fail.hs-incl" primOpOkForSpeculation :: PrimOp -> Bool - -- See Note [primOpOkForSpeculation and primOpOkForFloatOut] + -- See Note [PrimOp can_fail and has_side_effects] -- See comments with CoreUtils.exprOkForSpeculation + -- primOpOkForSpeculation => primOpOkForSideEffects primOpOkForSpeculation op - = not (primOpHasSideEffects op || primOpOutOfLine op || primOpCanFail op) + = primOpOkForSideEffects op + && not (primOpOutOfLine op || primOpCanFail op) + -- I think the "out of line" test is because out of line things can + -- be expensive (eg sine, cosine), and so we may not want to speculate them primOpOkForSideEffects :: PrimOp -> Bool primOpOkForSideEffects op @@ -443,6 +505,7 @@ behaviour of 'seq' for primops that can fail, so we don't treat them as cheap. \begin{code} primOpIsCheap :: PrimOp -> Bool +-- See Note [PrimOp can_fail and has_side_effects] primOpIsCheap op = primOpOkForSpeculation op -- In March 2001, we changed this to -- primOpIsCheap op = False @@ -587,7 +650,7 @@ pprPrimOp other_op = pprOccName (primOpOcc other_op) %************************************************************************ \begin{code} -data PrimCall = PrimCall CLabelString PackageId +data PrimCall = PrimCall CLabelString PackageKey instance Outputable PrimCall where ppr (PrimCall lbl pkgId) diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index 4851315eb4..19cd8127e5 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -1363,19 +1363,79 @@ primop SetByteArrayOp "setByteArray#" GenPrimOp code_size = { primOpCodeSizeForeignCall + 4 } can_fail = True +-- Atomic operations + +primop AtomicReadByteArrayOp_Int "atomicReadIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #) + {Given an array and an offset in Int units, read an element. The + index is assumed to be in bounds. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop AtomicWriteByteArrayOp_Int "atomicWriteIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + {Given an array and an offset in Int units, write an element. The + index is assumed to be in bounds. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + primop CasByteArrayOp_Int "casIntArray#" GenPrimOp MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #) - {Machine-level atomic compare and swap on a word within a ByteArray.} - with - out_of_line = True - has_side_effects = True + {Given an array, an offset in Int units, the expected old value, and + the new value, perform an atomic compare and swap i.e. write the new + value if the current value matches the provided old value. Returns + the value of the element before the operation. Implies a full memory + barrier.} + with has_side_effects = True + can_fail = True primop FetchAddByteArrayOp_Int "fetchAddIntArray#" GenPrimOp MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) - {Machine-level word-sized fetch-and-add within a ByteArray.} - with - out_of_line = True - has_side_effects = True + {Given an array, and offset in Int units, and a value to add, + atomically add the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchSubByteArrayOp_Int "fetchSubIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to subtract, + atomically substract the value to the element. Returns the value of + the element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchAndByteArrayOp_Int "fetchAndIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to AND, + atomically AND the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchNandByteArrayOp_Int "fetchNandIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to NAND, + atomically NAND the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchOrByteArrayOp_Int "fetchOrIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to OR, + atomically OR the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True + +primop FetchXorByteArrayOp_Int "fetchXorIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in Int units, and a value to XOR, + atomically XOR the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with has_side_effects = True + can_fail = True ------------------------------------------------------------------------ @@ -1821,6 +1881,11 @@ primop RaiseOp "raise#" GenPrimOp strictness = { \ _arity -> mkClosedStrictSig [topDmd] botRes } -- NB: result is bottom out_of_line = True + has_side_effects = True + -- raise# certainly throws a Haskell exception and hence has_side_effects + -- It doesn't actually make much difference because the fact that it + -- returns bottom independently ensures that we are careful not to discard + -- it. But still, it's better to say the Right Thing. -- raiseIO# needs to be a primop, because exceptions in the IO monad -- must be *precise* - we don't want the strictness analyser turning diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs index 4a7a063897..8a6ed044fb 100644 --- a/compiler/profiling/CostCentre.lhs +++ b/compiler/profiling/CostCentre.lhs @@ -1,32 +1,24 @@ \begin{code} -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - {-# LANGUAGE BangPatterns, DeriveDataTypeable #-} - module CostCentre ( CostCentre(..), CcName, IsCafCC(..), - -- All abstract except to friend: ParseIface.y + -- All abstract except to friend: ParseIface.y - CostCentreStack, - CollectedCCs, + CostCentreStack, + CollectedCCs, noCCS, currentCCS, dontCareCCS, noCCSAttached, isCurrentCCS, maybeSingletonCCS, - mkUserCC, mkAutoCC, mkAllCafsCC, + mkUserCC, mkAutoCC, mkAllCafsCC, mkSingletonCCS, isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule, - pprCostCentreCore, + pprCostCentreCore, costCentreUserName, costCentreUserNameFS, costCentreSrcSpan, - cmpCostCentre -- used for removing dups in a list + cmpCostCentre -- used for removing dups in a list ) where import Binary @@ -34,7 +26,7 @@ import Var import Name import Module import Unique -import Outputable +import Outputable import FastTypes import SrcLoc import FastString @@ -46,7 +38,7 @@ import Data.Data -- Cost Centres -- | A Cost Centre is a single @{-# SCC #-}@ annotation. - + data CostCentre = NormalCC { cc_key :: {-# UNPACK #-} !Int, @@ -66,7 +58,7 @@ data CostCentre cc_is_caf :: IsCafCC -- see below } - | AllCafsCC { + | AllCafsCC { cc_mod :: Module, -- Name of module defining this CC. cc_loc :: SrcSpan } @@ -79,10 +71,10 @@ data IsCafCC = NotCafCC | CafCC instance Eq CostCentre where - c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } + c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } instance Ord CostCentre where - compare = cmpCostCentre + compare = cmpCostCentre cmpCostCentre :: CostCentre -> CostCentre -> Ordering @@ -96,8 +88,8 @@ cmpCostCentre NormalCC {cc_key = n1, cc_mod = m1} cmpCostCentre other_1 other_2 = let - !tag1 = tag_CC other_1 - !tag2 = tag_CC other_2 + !tag1 = tag_CC other_1 + !tag2 = tag_CC other_2 in if tag1 <# tag2 then LT else GT where @@ -143,7 +135,7 @@ mkAutoCC id mod is_caf cc_loc = nameSrcSpan (getName id), cc_is_caf = is_caf } - where + where name = getName id -- beware: only external names are guaranteed to have unique -- Occnames. If the name is not external, we must append its @@ -161,28 +153,28 @@ mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc } -- | A Cost Centre Stack is something that can be attached to a closure. -- This is either: --- +-- -- * the current cost centre stack (CCCS) -- * a pre-defined cost centre stack (there are several --- pre-defined CCSs, see below). +-- pre-defined CCSs, see below). data CostCentreStack = NoCCS - | CurrentCCS -- Pinned on a let(rec)-bound - -- thunk/function/constructor, this says that the - -- cost centre to be attached to the object, when it - -- is allocated, is whatever is in the - -- current-cost-centre-stack register. + | CurrentCCS -- Pinned on a let(rec)-bound + -- thunk/function/constructor, this says that the + -- cost centre to be attached to the object, when it + -- is allocated, is whatever is in the + -- current-cost-centre-stack register. | DontCareCCS -- We need a CCS to stick in static closures - -- (for data), but we *don't* expect them to - -- accumulate any costs. But we still need - -- the placeholder. This CCS is it. + -- (for data), but we *don't* expect them to + -- accumulate any costs. But we still need + -- the placeholder. This CCS is it. | SingletonCCS CostCentre - deriving (Eq, Ord) -- needed for Ord on CLabel + deriving (Eq, Ord) -- needed for Ord on CLabel -- synonym for triple which describes the cost centre info in the generated @@ -196,7 +188,7 @@ type CollectedCCs noCCS, currentCCS, dontCareCCS :: CostCentreStack -noCCS = NoCCS +noCCS = NoCCS currentCCS = CurrentCCS dontCareCCS = DontCareCCS @@ -204,20 +196,20 @@ dontCareCCS = DontCareCCS -- Predicates on Cost-Centre Stacks noCCSAttached :: CostCentreStack -> Bool -noCCSAttached NoCCS = True -noCCSAttached _ = False +noCCSAttached NoCCS = True +noCCSAttached _ = False isCurrentCCS :: CostCentreStack -> Bool -isCurrentCCS CurrentCCS = True -isCurrentCCS _ = False +isCurrentCCS CurrentCCS = True +isCurrentCCS _ = False isCafCCS :: CostCentreStack -> Bool isCafCCS (SingletonCCS cc) = isCafCC cc -isCafCCS _ = False +isCafCCS _ = False maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre maybeSingletonCCS (SingletonCCS cc) = Just cc -maybeSingletonCCS _ = Nothing +maybeSingletonCCS _ = Nothing mkSingletonCCS :: CostCentre -> CostCentreStack mkSingletonCCS cc = SingletonCCS cc @@ -230,31 +222,31 @@ mkSingletonCCS cc = SingletonCCS cc -- expression. instance Outputable CostCentreStack where - ppr NoCCS = ptext (sLit "NO_CCS") - ppr CurrentCCS = ptext (sLit "CCCS") + ppr NoCCS = ptext (sLit "NO_CCS") + ppr CurrentCCS = ptext (sLit "CCCS") ppr DontCareCCS = ptext (sLit "CCS_DONT_CARE") ppr (SingletonCCS cc) = ppr cc <> ptext (sLit "_ccs") ----------------------------------------------------------------------------- -- Printing Cost Centres --- +-- -- There are several different ways in which we might want to print a -- cost centre: --- --- - the name of the cost centre, for profiling output (a C string) --- - the label, i.e. C label for cost centre in .hc file. --- - the debugging name, for output in -ddump things --- - the interface name, for printing in _scc_ exprs in iface files. --- +-- +-- - the name of the cost centre, for profiling output (a C string) +-- - the label, i.e. C label for cost centre in .hc file. +-- - the debugging name, for output in -ddump things +-- - the interface name, for printing in _scc_ exprs in iface files. +-- -- The last 3 are derived from costCentreStr below. The first is given -- by costCentreName. instance Outputable CostCentre where ppr cc = getPprStyle $ \ sty -> - if codeStyle sty - then ppCostCentreLbl cc - else text (costCentreUserName cc) + if codeStyle sty + then ppCostCentreLbl cc + else text (costCentreUserName cc) -- Printing in Core pprCostCentreCore :: CostCentre -> SDoc @@ -281,7 +273,7 @@ ppCostCentreLbl (NormalCC {cc_key = k, cc_name = n, cc_mod = m, = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> case is_caf of { CafCC -> ptext (sLit "CAF"); _ -> ppr (mkUniqueGrimily k)} <> text "_cc" --- This is the name to go in the user-displayed string, +-- This is the name to go in the user-displayed string, -- recorded in the cost centre declaration costCentreUserName :: CostCentre -> String costCentreUserName = unpackFS . costCentreUserNameFS diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index e65d3173d6..0f9f44aed6 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -433,12 +433,12 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = name@(L nameLoc _) }) = do { newname <- applyNameMaker name_maker name ; return (bind { fun_id = L nameLoc newname }) } -rnBindLHS name_maker _ bind@(PatSynBind{ patsyn_id = rdrname@(L nameLoc _) }) +rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname@(L nameLoc _) }) = do { unless (isTopRecNameMaker name_maker) $ addErr localPatternSynonymErr ; addLocM checkConName rdrname ; name <- applyNameMaker name_maker rdrname - ; return (bind{ patsyn_id = L nameLoc name }) } + ; return (PatSynBind psb{ psb_id = L nameLoc name }) } where localPatternSynonymErr :: SDoc localPatternSynonymErr @@ -515,15 +515,37 @@ rnBind sig_fn bind@(FunBind { fun_id = name [plain_name], rhs_fvs) } -rnBind _sig_fn bind@(PatSynBind { patsyn_id = L _ name - , patsyn_args = details - , patsyn_def = pat - , patsyn_dir = dir }) +rnBind sig_fn (PatSynBind bind) + = do { (bind', name, fvs) <- rnPatSynBind sig_fn bind + ; return (PatSynBind bind', name, fvs) } + +rnBind _ b = pprPanic "rnBind" (ppr b) + +{- +Note [Free-variable space leak] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have + fvs' = trim fvs +and we seq fvs' before turning it as part of a record. + +The reason is that trim is sometimes something like + \xs -> intersectNameSet (mkNameSet bound_names) xs +and we don't want to retain the list bound_names. This showed up in +trac ticket #1136. +-} + +rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function + -> PatSynBind Name RdrName + -> RnM (PatSynBind Name Name, [Name], Uses) +rnPatSynBind _sig_fn bind@(PSB { psb_id = L _ name + , psb_args = details + , psb_def = pat + , psb_dir = dir }) -- invariant: no free vars here when it's a FunBind = do { pattern_synonym_ok <- xoptM Opt_PatternSynonyms ; unless pattern_synonym_ok (addErr patternSynonymErr) - ; ((pat', details'), fvs) <- rnPat PatSyn pat $ \pat' -> do + ; ((pat', details'), fvs1) <- rnPat PatSyn pat $ \pat' -> do -- We check the 'RdrName's instead of the 'Name's -- so that the binding locations are reported -- from the left-hand side @@ -539,23 +561,28 @@ rnBind _sig_fn bind@(PatSynBind { patsyn_id = L _ name -- ; checkPrecMatch -- TODO ; return (InfixPatSyn name1 name2, mkFVs (map unLoc [name1, name2])) } ; return ((pat', details'), fvs) } - ; dir' <- case dir of - Unidirectional -> return Unidirectional - ImplicitBidirectional -> return ImplicitBidirectional + ; (dir', fvs2) <- case dir of + Unidirectional -> return (Unidirectional, emptyFVs) + ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs) + ExplicitBidirectional mg -> + do { (mg', fvs) <- rnMatchGroup PatSyn rnLExpr mg + ; return (ExplicitBidirectional mg', fvs) } ; mod <- getModule - ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs + ; let fvs = fvs1 `plusFV` fvs2 + fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs -- Keep locally-defined Names -- As well as dependency analysis, we need these for the -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan - ; let bind' = bind{ patsyn_args = details' - , patsyn_def = pat' - , patsyn_dir = dir' - , bind_fvs = fvs' } + ; let bind' = bind{ psb_args = details' + , psb_def = pat' + , psb_dir = dir' + , psb_fvs = fvs' } ; fvs' `seq` -- See Note [Free-variable space leak] - return (bind', [name], fvs) + return (bind', [name], fvs1) + -- See Note [Pattern synonym wrappers don't yield dependencies] } where lookupVar = wrapLocM lookupOccRn @@ -565,20 +592,34 @@ rnBind _sig_fn bind@(PatSynBind { patsyn_id = L _ name = hang (ptext (sLit "Illegal pattern synonym declaration")) 2 (ptext (sLit "Use -XPatternSynonyms to enable this extension")) +{- +Note [Pattern synonym wrappers don't yield dependencies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -rnBind _ b = pprPanic "rnBind" (ppr b) +When renaming a pattern synonym that has an explicit wrapper, +references in the wrapper definition should not be used when +calculating dependencies. For example, consider the following pattern +synonym definition: -{- -Note [Free-variable space leak] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have - fvs' = trim fvs -and we seq fvs' before turning it as part of a record. +pattern P x <- C1 x where + P x = f (C1 x) + +f (P x) = C2 x + +In this case, 'P' needs to be typechecked in two passes: + +1. Typecheck the pattern definition of 'P', which fully determines the +type of 'P'. This step doesn't require knowing anything about 'f', +since the wrapper definition is not looked at. + +2. Typecheck the wrapper definition, which needs the typechecked +definition of 'f' to be in scope. + +This behaviour is implemented in 'tcValBinds', but it crucially +depends on 'P' not being put in a recursive group with 'f' (which +would make it look like a recursive pattern synonym a la 'pattern P = +P' which is unsound and rejected). -The reason is that trim is sometimes something like - \xs -> intersectNameSet (mkNameSet bound_names) xs -and we don't want to retain the list bound_names. This showed up in -trac ticket #1136. -} --------------------- diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 262fde8d7a..697303f276 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -40,6 +40,7 @@ import UniqSet import Data.List import Util import ListSetOps ( removeDups ) +import ErrUtils import Outputable import SrcLoc import FastString @@ -47,16 +48,6 @@ import Control.Monad import TysWiredIn ( nilDataConName ) \end{code} - -\begin{code} --- XXX -thenM :: Monad a => a b -> (b -> a c) -> a c -thenM = (>>=) - -thenM_ :: Monad a => a b -> a c -> a c -thenM_ = (>>) -\end{code} - %************************************************************************ %* * \subsubsection{Expressions} @@ -68,16 +59,13 @@ rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars) rnExprs ls = rnExprs' ls emptyUniqSet where rnExprs' [] acc = return ([], acc) - rnExprs' (expr:exprs) acc - = rnLExpr expr `thenM` \ (expr', fvExpr) -> - + rnExprs' (expr:exprs) acc = + do { (expr', fvExpr) <- rnLExpr expr -- Now we do a "seq" on the free vars because typically it's small -- or empty, especially in very long lists of constants - let - acc' = acc `plusFV` fvExpr - in - acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) -> - return (expr':exprs', fvExprs) + ; let acc' = acc `plusFV` fvExpr + ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc' + ; return (expr':exprs', fvExprs) } \end{code} Variables. We look up the variable and return the resulting name. @@ -122,27 +110,25 @@ rnExpr (HsIPVar v) = return (HsIPVar v, emptyFVs) rnExpr (HsLit lit@(HsString s)) - = do { - opt_OverloadedStrings <- xoptM Opt_OverloadedStrings + = do { opt_OverloadedStrings <- xoptM Opt_OverloadedStrings ; if opt_OverloadedStrings then rnExpr (HsOverLit (mkHsIsString s placeHolderType)) - else -- Same as below - rnLit lit `thenM_` - return (HsLit lit, emptyFVs) - } + else do { + ; rnLit lit + ; return (HsLit lit, emptyFVs) } } rnExpr (HsLit lit) - = rnLit lit `thenM_` - return (HsLit lit, emptyFVs) + = do { rnLit lit + ; return (HsLit lit, emptyFVs) } rnExpr (HsOverLit lit) - = rnOverLit lit `thenM` \ (lit', fvs) -> - return (HsOverLit lit', fvs) + = do { (lit', fvs) <- rnOverLit lit + ; return (HsOverLit lit', fvs) } rnExpr (HsApp fun arg) - = rnLExpr fun `thenM` \ (fun',fvFun) -> - rnLExpr arg `thenM` \ (arg',fvArg) -> - return (HsApp fun' arg', fvFun `plusFV` fvArg) + = do { (fun',fvFun) <- rnLExpr fun + ; (arg',fvArg) <- rnLExpr arg + ; return (HsApp fun' arg', fvFun `plusFV` fvArg) } rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2) = do { (e1', fv_e1) <- rnLExpr e1 @@ -165,10 +151,10 @@ rnExpr (OpApp _ other_op _ _) , ptext (sLit "(Probably resulting from a Template Haskell splice)") ]) rnExpr (NegApp e _) - = rnLExpr e `thenM` \ (e', fv_e) -> - lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) -> - mkNegAppRn e' neg_name `thenM` \ final_e -> - return (final_e, fv_e `plusFV` fv_neg) + = do { (e', fv_e) <- rnLExpr e + ; (neg_name, fv_neg) <- lookupSyntaxName negateName + ; final_e <- mkNegAppRn e' neg_name + ; return (final_e, fv_e `plusFV` fv_neg) } ------------------------------------------ -- Template Haskell extensions @@ -180,10 +166,10 @@ rnExpr (HsSpliceE is_typed splice) = rnSpliceExpr is_typed splice rnExpr (HsQuasiQuoteE qq) - = runQuasiQuoteExpr qq `thenM` \ lexpr' -> - -- Wrap the result of the quasi-quoter in parens so that we don't - -- lose the outermost location set by runQuasiQuote (#7918) - rnExpr (HsPar lexpr') + = do { lexpr' <- runQuasiQuoteExpr qq + -- Wrap the result of the quasi-quoter in parens so that we don't + -- lose the outermost location set by runQuasiQuote (#7918) + ; rnExpr (HsPar lexpr') } --------------------------------------------- -- Sections @@ -207,33 +193,33 @@ rnExpr expr@(SectionR {}) --------------------------------------------- rnExpr (HsCoreAnn ann expr) - = rnLExpr expr `thenM` \ (expr', fvs_expr) -> - return (HsCoreAnn ann expr', fvs_expr) + = do { (expr', fvs_expr) <- rnLExpr expr + ; return (HsCoreAnn ann expr', fvs_expr) } rnExpr (HsSCC lbl expr) - = rnLExpr expr `thenM` \ (expr', fvs_expr) -> - return (HsSCC lbl expr', fvs_expr) + = do { (expr', fvs_expr) <- rnLExpr expr + ; return (HsSCC lbl expr', fvs_expr) } rnExpr (HsTickPragma info expr) - = rnLExpr expr `thenM` \ (expr', fvs_expr) -> - return (HsTickPragma info expr', fvs_expr) + = do { (expr', fvs_expr) <- rnLExpr expr + ; return (HsTickPragma info expr', fvs_expr) } rnExpr (HsLam matches) - = rnMatchGroup LambdaExpr rnLExpr matches `thenM` \ (matches', fvMatch) -> - return (HsLam matches', fvMatch) + = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches + ; return (HsLam matches', fvMatch) } rnExpr (HsLamCase arg matches) - = rnMatchGroup CaseAlt rnLExpr matches `thenM` \ (matches', fvs_ms) -> - return (HsLamCase arg matches', fvs_ms) + = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches + ; return (HsLamCase arg matches', fvs_ms) } rnExpr (HsCase expr matches) - = rnLExpr expr `thenM` \ (new_expr, e_fvs) -> - rnMatchGroup CaseAlt rnLExpr matches `thenM` \ (new_matches, ms_fvs) -> - return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) + = do { (new_expr, e_fvs) <- rnLExpr expr + ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches + ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) } rnExpr (HsLet binds expr) - = rnLocalBindsAndThen binds $ \ binds' -> - rnLExpr expr `thenM` \ (expr',fvExpr) -> - return (HsLet binds' expr', fvExpr) + = rnLocalBindsAndThen binds $ \binds' -> do + { (expr',fvExpr) <- rnLExpr expr + ; return (HsLet binds' expr', fvExpr) } rnExpr (HsDo do_or_lc stmts _) = do { ((stmts', _), fvs) <- rnStmts do_or_lc rnLExpr stmts (\ _ -> return ((), emptyFVs)) @@ -250,8 +236,8 @@ rnExpr (ExplicitList _ _ exps) return (ExplicitList placeHolderType Nothing exps', fvs) } rnExpr (ExplicitPArr _ exps) - = rnExprs exps `thenM` \ (exps', fvs) -> - return (ExplicitPArr placeHolderType exps', fvs) + = do { (exps', fvs) <- rnExprs exps + ; return (ExplicitPArr placeHolderType exps', fvs) } rnExpr (ExplicitTuple tup_args boxity) = do { checkTupleSection tup_args @@ -292,8 +278,8 @@ rnExpr (HsMultiIf ty alts) ; return (HsMultiIf ty alts', fvs) } rnExpr (HsType a) - = rnLHsType HsTypeCtx a `thenM` \ (t, fvT) -> - return (HsType t, fvT) + = do { (t, fvT) <- rnLHsType HsTypeCtx a + ; return (HsType t, fvT) } rnExpr (ArithSeq _ _ seq) = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists @@ -306,8 +292,8 @@ rnExpr (ArithSeq _ _ seq) return (ArithSeq noPostTcExpr Nothing new_seq, fvs) } rnExpr (PArrSeq _ seq) - = rnArithSeq seq `thenM` \ (new_seq, fvs) -> - return (PArrSeq noPostTcExpr new_seq, fvs) + = do { (new_seq, fvs) <- rnArithSeq seq + ; return (PArrSeq noPostTcExpr new_seq, fvs) } \end{code} These three are pattern syntax appearing in expressions. @@ -334,9 +320,9 @@ rnExpr e@(ELazyPat {}) = patSynErr e \begin{code} rnExpr (HsProc pat body) = newArrowScope $ - rnPat ProcExpr pat $ \ pat' -> - rnCmdTop body `thenM` \ (body',fvBody) -> - return (HsProc pat' body', fvBody) + rnPat ProcExpr pat $ \ pat' -> do + { (body',fvBody) <- rnCmdTop body + ; return (HsProc pat' body', fvBody) } -- Ideally, these would be done in parsing, but to keep parsing simple, we do it here. rnExpr e@(HsArrApp {}) = arrowFail e @@ -404,9 +390,9 @@ rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd }) rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars) rnCmdArgs [] = return ([], emptyFVs) rnCmdArgs (arg:args) - = rnCmdTop arg `thenM` \ (arg',fvArg) -> - rnCmdArgs args `thenM` \ (args',fvArgs) -> - return (arg':args', fvArg `plusFV` fvArgs) + = do { (arg',fvArg) <- rnCmdTop arg + ; (args',fvArgs) <- rnCmdArgs args + ; return (arg':args', fvArg `plusFV` fvArgs) } rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars) rnCmdTop = wrapLocFstM rnCmdTop' @@ -427,10 +413,10 @@ rnLCmd = wrapLocFstM rnCmd rnCmd :: HsCmd RdrName -> RnM (HsCmd Name, FreeVars) rnCmd (HsCmdArrApp arrow arg _ ho rtl) - = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) -> - rnLExpr arg `thenM` \ (arg',fvArg) -> - return (HsCmdArrApp arrow' arg' placeHolderType ho rtl, - fvArrow `plusFV` fvArg) + = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow) + ; (arg',fvArg) <- rnLExpr arg + ; return (HsCmdArrApp arrow' arg' placeHolderType ho rtl, + fvArrow `plusFV` fvArg) } where select_arrow_scope tc = case ho of HsHigherOrderApp -> tc @@ -443,42 +429,37 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl) -- infix form rnCmd (HsCmdArrForm op (Just _) [arg1, arg2]) - = escapeArrowScope (rnLExpr op) - `thenM` \ (op',fv_op) -> - let L _ (HsVar op_name) = op' in - rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) -> - rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) -> - + = do { (op',fv_op) <- escapeArrowScope (rnLExpr op) + ; let L _ (HsVar op_name) = op' + ; (arg1',fv_arg1) <- rnCmdTop arg1 + ; (arg2',fv_arg2) <- rnCmdTop arg2 -- Deal with fixity - - lookupFixityRn op_name `thenM` \ fixity -> - mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e -> - - return (final_e, - fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) + ; fixity <- lookupFixityRn op_name + ; final_e <- mkOpFormRn arg1' op' fixity arg2' + ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) } rnCmd (HsCmdArrForm op fixity cmds) - = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) -> - rnCmdArgs cmds `thenM` \ (cmds',fvCmds) -> - return (HsCmdArrForm op' fixity cmds', fvOp `plusFV` fvCmds) + = do { (op',fvOp) <- escapeArrowScope (rnLExpr op) + ; (cmds',fvCmds) <- rnCmdArgs cmds + ; return (HsCmdArrForm op' fixity cmds', fvOp `plusFV` fvCmds) } rnCmd (HsCmdApp fun arg) - = rnLCmd fun `thenM` \ (fun',fvFun) -> - rnLExpr arg `thenM` \ (arg',fvArg) -> - return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) + = do { (fun',fvFun) <- rnLCmd fun + ; (arg',fvArg) <- rnLExpr arg + ; return (HsCmdApp fun' arg', fvFun `plusFV` fvArg) } rnCmd (HsCmdLam matches) - = rnMatchGroup LambdaExpr rnLCmd matches `thenM` \ (matches', fvMatch) -> - return (HsCmdLam matches', fvMatch) + = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches + ; return (HsCmdLam matches', fvMatch) } rnCmd (HsCmdPar e) = do { (e', fvs_e) <- rnLCmd e ; return (HsCmdPar e', fvs_e) } rnCmd (HsCmdCase expr matches) - = rnLExpr expr `thenM` \ (new_expr, e_fvs) -> - rnMatchGroup CaseAlt rnLCmd matches `thenM` \ (new_matches, ms_fvs) -> - return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) + = do { (new_expr, e_fvs) <- rnLExpr expr + ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches + ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) } rnCmd (HsCmdIf _ p b1 b2) = do { (p', fvP) <- rnLExpr p @@ -488,9 +469,9 @@ rnCmd (HsCmdIf _ p b1 b2) ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } rnCmd (HsCmdLet binds cmd) - = rnLocalBindsAndThen binds $ \ binds' -> - rnLCmd cmd `thenM` \ (cmd',fvExpr) -> - return (HsCmdLet binds' cmd', fvExpr) + = rnLocalBindsAndThen binds $ \ binds' -> do + { (cmd',fvExpr) <- rnLCmd cmd + ; return (HsCmdLet binds' cmd', fvExpr) } rnCmd (HsCmdDo stmts _) = do { ((stmts', _), fvs) <- rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) @@ -580,25 +561,25 @@ methodNamesStmt (TransStmt {}) = emptyFVs \begin{code} rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars) rnArithSeq (From expr) - = rnLExpr expr `thenM` \ (expr', fvExpr) -> - return (From expr', fvExpr) + = do { (expr', fvExpr) <- rnLExpr expr + ; return (From expr', fvExpr) } rnArithSeq (FromThen expr1 expr2) - = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> - rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> - return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) + = do { (expr1', fvExpr1) <- rnLExpr expr1 + ; (expr2', fvExpr2) <- rnLExpr expr2 + ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) } rnArithSeq (FromTo expr1 expr2) - = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> - rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> - return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) + = do { (expr1', fvExpr1) <- rnLExpr expr1 + ; (expr2', fvExpr2) <- rnLExpr expr2 + ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) } rnArithSeq (FromThenTo expr1 expr2 expr3) - = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> - rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> - rnLExpr expr3 `thenM` \ (expr3', fvExpr3) -> - return (FromThenTo expr1' expr2' expr3', - plusFVs [fvExpr1, fvExpr2, fvExpr3]) + = do { (expr1', fvExpr1) <- rnLExpr expr1 + ; (expr2', fvExpr2) <- rnLExpr expr2 + ; (expr3', fvExpr3) <- rnLExpr expr3 + ; return (FromThenTo expr1' expr2' expr3', + plusFVs [fvExpr1, fvExpr2, fvExpr3]) } \end{code} %************************************************************************ @@ -961,21 +942,19 @@ rn_rec_stmt rnBody _ (L loc (LastStmt body _)) _ L loc (LastStmt body' ret_op))] } rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _)) _ - = rnBody body `thenM` \ (body', fvs) -> - lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) -> - return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, - L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] + = do { (body', fvs) <- rnBody body + ; (then_op, fvs1) <- lookupSyntaxName thenMName + ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, + L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] } rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _)) fv_pat - = rnBody body `thenM` \ (body', fv_expr) -> - lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) -> - lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) -> - let - bndrs = mkNameSet (collectPatBinders pat') - fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 - in - return [(bndrs, fvs, bndrs `intersectNameSet` fvs, - L loc (BindStmt pat' body' bind_op fail_op))] + = do { (body', fv_expr) <- rnBody body + ; (bind_op, fvs1) <- lookupSyntaxName bindMName + ; (fail_op, fvs2) <- lookupSyntaxName failMName + ; let bndrs = mkNameSet (collectPatBinders pat') + fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 + ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, + L loc (BindStmt pat' body' bind_op fail_op))] } rn_rec_stmt _ _ (L _ (LetStmt binds@(HsIPBinds _))) _ = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds) @@ -1005,9 +984,9 @@ rn_rec_stmts :: Outputable (body RdrName) => -> [Name] -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)] -> RnM [Segment (LStmt Name (Located (body Name)))] -rn_rec_stmts rnBody bndrs stmts = - mapM (uncurry (rn_rec_stmt rnBody bndrs)) stmts `thenM` \ segs_s -> - return (concat segs_s) +rn_rec_stmts rnBody bndrs stmts + = do { segs_s <- mapM (uncurry (rn_rec_stmt rnBody bndrs)) stmts + ; return (concat segs_s) } --------------------------------------------- segmentRecStmts :: HsStmtContext Name @@ -1247,8 +1226,8 @@ checkStmt :: HsStmtContext Name checkStmt ctxt (L _ stmt) = do { dflags <- getDynFlags ; case okStmt dflags ctxt stmt of - Nothing -> return () - Just extra -> addErr (msg $$ extra) } + IsValid -> return () + NotValid extra -> addErr (msg $$ extra) } where msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement") , ptext (sLit "in") <+> pprAStmtContext ctxt ] @@ -1263,13 +1242,12 @@ pprStmtCat (RecStmt {}) = ptext (sLit "rec") pprStmtCat (ParStmt {}) = ptext (sLit "parallel") ------------ -isOK, notOK :: Maybe SDoc -isOK = Nothing -notOK = Just empty +emptyInvalid :: Validity -- Payload is the empty document +emptyInvalid = NotValid empty okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt :: DynFlags -> HsStmtContext Name - -> Stmt RdrName (Located (body RdrName)) -> Maybe SDoc + -> Stmt RdrName (Located (body RdrName)) -> Validity -- Return Nothing if OK, (Just extra) if not ok -- The "extra" is an SDoc that is appended to an generic error message @@ -1287,59 +1265,59 @@ okStmt dflags ctxt stmt TransStmtCtxt ctxt -> okStmt dflags ctxt stmt ------------- -okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Maybe SDoc +okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Validity okPatGuardStmt stmt = case stmt of - BodyStmt {} -> isOK - BindStmt {} -> isOK - LetStmt {} -> isOK - _ -> notOK + BodyStmt {} -> IsValid + BindStmt {} -> IsValid + LetStmt {} -> IsValid + _ -> emptyInvalid ------------- okParStmt dflags ctxt stmt = case stmt of - LetStmt (HsIPBinds {}) -> notOK + LetStmt (HsIPBinds {}) -> emptyInvalid _ -> okStmt dflags ctxt stmt ---------------- okDoStmt dflags ctxt stmt = case stmt of RecStmt {} - | Opt_RecursiveDo `xopt` dflags -> isOK - | ArrowExpr <- ctxt -> isOK -- Arrows allows 'rec' - | otherwise -> Just (ptext (sLit "Use RecursiveDo")) - BindStmt {} -> isOK - LetStmt {} -> isOK - BodyStmt {} -> isOK - _ -> notOK + | Opt_RecursiveDo `xopt` dflags -> IsValid + | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec' + | otherwise -> NotValid (ptext (sLit "Use RecursiveDo")) + BindStmt {} -> IsValid + LetStmt {} -> IsValid + BodyStmt {} -> IsValid + _ -> emptyInvalid ---------------- okCompStmt dflags _ stmt = case stmt of - BindStmt {} -> isOK - LetStmt {} -> isOK - BodyStmt {} -> isOK + BindStmt {} -> IsValid + LetStmt {} -> IsValid + BodyStmt {} -> IsValid ParStmt {} - | Opt_ParallelListComp `xopt` dflags -> isOK - | otherwise -> Just (ptext (sLit "Use ParallelListComp")) + | Opt_ParallelListComp `xopt` dflags -> IsValid + | otherwise -> NotValid (ptext (sLit "Use ParallelListComp")) TransStmt {} - | Opt_TransformListComp `xopt` dflags -> isOK - | otherwise -> Just (ptext (sLit "Use TransformListComp")) - RecStmt {} -> notOK - LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt) + | Opt_TransformListComp `xopt` dflags -> IsValid + | otherwise -> NotValid (ptext (sLit "Use TransformListComp")) + RecStmt {} -> emptyInvalid + LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) ---------------- okPArrStmt dflags _ stmt = case stmt of - BindStmt {} -> isOK - LetStmt {} -> isOK - BodyStmt {} -> isOK + BindStmt {} -> IsValid + LetStmt {} -> IsValid + BodyStmt {} -> IsValid ParStmt {} - | Opt_ParallelListComp `xopt` dflags -> isOK - | otherwise -> Just (ptext (sLit "Use ParallelListComp")) - TransStmt {} -> notOK - RecStmt {} -> notOK - LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt) + | Opt_ParallelListComp `xopt` dflags -> IsValid + | otherwise -> NotValid (ptext (sLit "Use ParallelListComp")) + TransStmt {} -> emptyInvalid + RecStmt {} -> emptyInvalid + LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) --------- checkTupleSection :: [HsTupArg RdrName] -> RnM () diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index db4258607a..5071828e4d 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -259,7 +259,7 @@ rnImportDecl this_mod imp_mod : dep_finsts deps | otherwise = dep_finsts deps - pkg = modulePackageId (mi_module iface) + pkg = modulePackageKey (mi_module iface) -- Does this import mean we now require our own pkg -- to be trusted? See Note [Trust Own Package] diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 2618792e82..a3bd38a3ec 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -384,8 +384,8 @@ rnHsForeignDecl (ForeignImport name ty _ spec) ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty -- Mark any PackageTarget style imports as coming from the current package - ; let packageId = thisPackage $ hsc_dflags topEnv - spec' = patchForeignImport packageId spec + ; let packageKey = thisPackage $ hsc_dflags topEnv + spec' = patchForeignImport packageKey spec ; return (ForeignImport name' ty' noForeignImportCoercionYet spec', fvs) } @@ -402,20 +402,20 @@ rnHsForeignDecl (ForeignExport name ty _ spec) -- package, so if they get inlined across a package boundry we'll still -- know where they're from. -- -patchForeignImport :: PackageId -> ForeignImport -> ForeignImport -patchForeignImport packageId (CImport cconv safety fs spec) - = CImport cconv safety fs (patchCImportSpec packageId spec) +patchForeignImport :: PackageKey -> ForeignImport -> ForeignImport +patchForeignImport packageKey (CImport cconv safety fs spec) + = CImport cconv safety fs (patchCImportSpec packageKey spec) -patchCImportSpec :: PackageId -> CImportSpec -> CImportSpec -patchCImportSpec packageId spec +patchCImportSpec :: PackageKey -> CImportSpec -> CImportSpec +patchCImportSpec packageKey spec = case spec of - CFunction callTarget -> CFunction $ patchCCallTarget packageId callTarget + CFunction callTarget -> CFunction $ patchCCallTarget packageKey callTarget _ -> spec -patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget -patchCCallTarget packageId callTarget = +patchCCallTarget :: PackageKey -> CCallTarget -> CCallTarget +patchCCallTarget packageKey callTarget = case callTarget of - StaticTarget label Nothing isFun -> StaticTarget label (Just packageId) isFun + StaticTarget label Nothing isFun -> StaticTarget label (Just packageKey) isFun _ -> callTarget @@ -445,12 +445,14 @@ rnSrcInstDecl (ClsInstD { cid_inst = cid }) rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars) rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds , cid_sigs = uprags, cid_tyfam_insts = ats + , cid_overlap_mode = oflag , cid_datafam_insts = adts }) -- Used for both source and interface file decls = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty ; case splitLHsInstDeclTy_maybe inst_ty' of { Nothing -> return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds , cid_sigs = [], cid_tyfam_insts = [] + , cid_overlap_mode = oflag , cid_datafam_insts = [] } , inst_fvs) ; Just (inst_tyvars, _, L _ cls,_) -> @@ -463,7 +465,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds ; traceRn (text "rnSrcInstDecl" <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names) ; ((ats', adts', other_sigs'), more_fvs) <- extendTyVarEnvFVRn ktv_names $ - do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats + do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls inst_tyvars adts ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs ; return ( (ats', adts', other_sigs') @@ -493,6 +495,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds `plusFV` inst_fvs ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds' , cid_sigs = uprags', cid_tyfam_insts = ats' + , cid_overlap_mode = oflag , cid_datafam_insts = adts' }, all_fvs) } } } -- We return the renamed associated data type declarations so @@ -561,14 +564,29 @@ rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn }) rnTyFamInstEqn :: Maybe (Name, [Name]) -> TyFamInstEqn RdrName -> RnM (TyFamInstEqn Name, FreeVars) -rnTyFamInstEqn mb_cls (TyFamInstEqn { tfie_tycon = tycon - , tfie_pats = HsWB { hswb_cts = pats } - , tfie_rhs = rhs }) +rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon + , tfe_pats = HsWB { hswb_cts = pats } + , tfe_rhs = rhs }) = do { (tycon', pats', rhs', fvs) <- rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn - ; return (TyFamInstEqn { tfie_tycon = tycon' - , tfie_pats = pats' - , tfie_rhs = rhs' }, fvs) } + ; return (TyFamEqn { tfe_tycon = tycon' + , tfe_pats = pats' + , tfe_rhs = rhs' }, fvs) } + +rnTyFamDefltEqn :: Name + -> TyFamDefltEqn RdrName + -> RnM (TyFamDefltEqn Name, FreeVars) +rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon + , tfe_pats = tyvars + , tfe_rhs = rhs }) + = bindHsTyVars ctx (Just cls) [] tyvars $ \ tyvars' -> + do { tycon' <- lookupFamInstName (Just cls) tycon + ; (rhs', fvs) <- rnLHsType ctx rhs + ; return (TyFamEqn { tfe_tycon = tycon' + , tfe_pats = tyvars' + , tfe_rhs = rhs' }, fvs) } + where + ctx = TyFamilyCtx tycon rnDataFamInstDecl :: Maybe (Name, [Name]) -> DataFamInstDecl RdrName @@ -587,7 +605,7 @@ rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon Renaming of the associated types in instances. \begin{code} --- rename associated type family decl in class +-- Rename associated type family decl in class rnATDecls :: Name -- Class -> [LFamilyDecl RdrName] -> RnM ([LFamilyDecl Name], FreeVars) @@ -637,11 +655,11 @@ extendTyVarEnvForMethodBinds ktv_names thing_inside \begin{code} rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars) -rnSrcDerivDecl (DerivDecl ty) +rnSrcDerivDecl (DerivDecl ty overlap) = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving ; unless standalone_deriv_ok (addErr standaloneDerivErr) ; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty - ; return (DerivDecl ty', fvs) } + ; return (DerivDecl ty' overlap, fvs) } standaloneDerivErr :: SDoc standaloneDerivErr @@ -865,10 +883,10 @@ packages, it is safe not to add the dependencies on the .hs-boot stuff to B2. See also Note [Grouping of type and class declarations] in TcTyClsDecls. \begin{code} -isInPackage :: PackageId -> Name -> Bool +isInPackage :: PackageKey -> Name -> Bool isInPackage pkgId nm = case nameModule_maybe nm of Nothing -> False - Just m -> pkgId == modulePackageId m + Just m -> pkgId == modulePackageKey m -- We use nameModule_maybe because we might be in a TH splice, in which case -- there is no module name. In that case we cannot have mutual dependencies, -- so it's fine to return False here. @@ -938,7 +956,7 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs }) do { (rhs', fvs) <- rnTySyn doc rhs ; return ((tyvars', rhs'), fvs) } ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars' - , tcdRhs = rhs', tcdFVs = fvs }, fvs) } + , tcdRhs = rhs', tcdFVs = fvs }, fvs) } -- "data", "newtype" declarations -- both top level and (for an associated type) in an instance decl @@ -963,20 +981,20 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls, -- kind signatures on the tyvars -- Tyvars scope over superclass context and method signatures - ; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs) + ; ((tyvars', context', fds', ats', sigs'), stuff_fvs) <- bindHsTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do -- Checks for distinct tyvars { (context', cxt_fvs) <- rnContext cls_doc context - ; fds' <- rnFds (docOfHsDocContext cls_doc) fds + ; fds' <- rnFds fds -- The fundeps have no free variables ; (ats', fv_ats) <- rnATDecls cls' ats - ; (at_defs', fv_at_defs) <- rnATInstDecls rnTyFamInstDecl cls' tyvars' at_defs ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs ; let fvs = cxt_fvs `plusFV` sig_fvs `plusFV` - fv_ats `plusFV` - fv_at_defs - ; return ((tyvars', context', fds', ats', at_defs', sigs'), fvs) } + fv_ats + ; return ((tyvars', context', fds', ats', sigs'), fvs) } + + ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs -- No need to check for duplicate associated type decls -- since that is done by RnNames.extendGlobalRdrEnvRn @@ -1008,7 +1026,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls, -- Haddock docs ; docs' <- mapM (wrapLocM rnDocDecl) docs - ; let all_fvs = meth_fvs `plusFV` stuff_fvs + ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', @@ -1406,21 +1424,20 @@ extendRecordFieldEnv tycl_decls inst_decls %********************************************************* \begin{code} -rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)] - -rnFds doc fds +rnFds :: [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)] +rnFds fds = mapM (wrapLocM rn_fds) fds where rn_fds (tys1, tys2) - = do { tys1' <- rnHsTyVars doc tys1 - ; tys2' <- rnHsTyVars doc tys2 + = do { tys1' <- rnHsTyVars tys1 + ; tys2' <- rnHsTyVars tys2 ; return (tys1', tys2') } -rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name] -rnHsTyVars doc tvs = mapM (rnHsTyVar doc) tvs +rnHsTyVars :: [RdrName] -> RnM [Name] +rnHsTyVars tvs = mapM rnHsTyVar tvs -rnHsTyVar :: SDoc -> RdrName -> RnM Name -rnHsTyVar _doc tyvar = lookupOccRn tyvar +rnHsTyVar :: RdrName -> RnM Name +rnHsTyVar tyvar = lookupOccRn tyvar \end{code} diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index 2cf886c5c6..f00768a9f5 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -26,16 +26,17 @@ module FloatIn ( floatInwards ) where import CoreSyn import MkCore -import CoreUtils ( exprIsDupable, exprIsExpandable, exprOkForSideEffects ) +import CoreUtils ( exprIsDupable, exprIsExpandable, exprType, exprOkForSideEffects ) import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars ) import Id ( isOneShotBndr, idType ) import Var -import Type ( isUnLiftedType ) +import Type ( Type, isUnLiftedType, splitFunTy, applyTy ) import VarSet import Util import UniqFM import DynFlags import Outputable +import Data.List( mapAccumL ) \end{code} Top-level interface function, @floatInwards@. Note that we do not @@ -155,18 +156,42 @@ need to get at all the arguments. The next simplifier run will pull out any silly ones. \begin{code} -fiExpr dflags to_drop (_,AnnApp fun arg@(arg_fvs, ann_arg)) - | noFloatIntoRhs ann_arg = wrapFloats drop_here $ wrapFloats arg_drop $ - App (fiExpr dflags fun_drop fun) (fiExpr dflags [] arg) - -- It's inconvenient to test for an unlifted arg here, - -- and it really doesn't matter if we float into one - | otherwise = wrapFloats drop_here $ - App (fiExpr dflags fun_drop fun) (fiExpr dflags arg_drop arg) +fiExpr dflags to_drop ann_expr@(_,AnnApp {}) + = wrapFloats drop_here $ wrapFloats extra_drop $ + mkApps (fiExpr dflags fun_drop ann_fun) + (zipWith (fiExpr dflags) arg_drops ann_args) where - [drop_here, fun_drop, arg_drop] - = sepBindsByDropPoint dflags False [freeVarsOf fun, arg_fvs] to_drop + (ann_fun@(fun_fvs, _), ann_args) = collectAnnArgs ann_expr + fun_ty = exprType (deAnnotate ann_fun) + ((_,extra_fvs), arg_fvs) = mapAccumL mk_arg_fvs (fun_ty, emptyVarSet) ann_args + + -- All this faffing about is so that we can get hold of + -- the types of the arguments, to pass to noFloatIntoRhs + mk_arg_fvs :: (Type, FreeVarSet) -> CoreExprWithFVs -> ((Type, FreeVarSet), FreeVarSet) + mk_arg_fvs (fun_ty, extra_fvs) (_, AnnType ty) + = ((applyTy fun_ty ty, extra_fvs), emptyVarSet) + + mk_arg_fvs (fun_ty, extra_fvs) (arg_fvs, ann_arg) + | noFloatIntoRhs ann_arg arg_ty + = ((res_ty, extra_fvs `unionVarSet` arg_fvs), emptyVarSet) + | otherwise + = ((res_ty, extra_fvs), arg_fvs) + where + (arg_ty, res_ty) = splitFunTy fun_ty + + drop_here : extra_drop : fun_drop : arg_drops + = sepBindsByDropPoint dflags False (extra_fvs : fun_fvs : arg_fvs) to_drop \end{code} +Note [Do not destroy the let/app invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Watch out for + f (x +# y) +We don't want to float bindings into here + f (case ... of { x -> x +# y }) +because that might destroy the let/app invariant, which requires +unlifted function arguments to be ok-for-speculation. + Note [Floating in past a lambda group] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * We must be careful about floating inside inside a value lambda. @@ -275,8 +300,8 @@ arrange to dump bindings that bind extra_fvs before the entire let. Note [extra_fvs (2): free variables of rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - let x{rule mentioning y} = rhs in body +Consider + let x{rule mentioning y} = rhs in body Here y is not free in rhs or body; but we still want to dump bindings that bind y outside the let. So we augment extra_fvs with the idRuleAndUnfoldingVars of x. No need for type variables, hence not using @@ -288,11 +313,11 @@ fiExpr dflags to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) = fiExpr dflags new_to_drop body where body_fvs = freeVarsOf body `delVarSet` id + rhs_ty = idType id rule_fvs = idRuleAndUnfoldingVars id -- See Note [extra_fvs (2): free variables of rules] - extra_fvs | noFloatIntoRhs ann_rhs - || isUnLiftedType (idType id) = rule_fvs `unionVarSet` rhs_fvs - | otherwise = rule_fvs + extra_fvs | noFloatIntoRhs ann_rhs rhs_ty = rule_fvs `unionVarSet` rhs_fvs + | otherwise = rule_fvs -- See Note [extra_fvs (1): avoid floating into RHS] -- No point in floating in only to float straight out again -- Ditto ok-for-speculation unlifted RHSs @@ -322,7 +347,7 @@ fiExpr dflags to_drop (_,AnnLet (AnnRec bindings) body) rule_fvs = foldr (unionVarSet . idRuleAndUnfoldingVars) emptyVarSet ids extra_fvs = rule_fvs `unionVarSet` unionVarSets [ fvs | (fvs, rhs) <- rhss - , noFloatIntoRhs rhs ] + , noFloatIntoExpr rhs ] (shared_binds:extra_binds:body_binds:rhss_binds) = sepBindsByDropPoint dflags False (extra_fvs:body_fvs:rhss_fvs) to_drop @@ -364,6 +389,7 @@ floating in cases with a single alternative that may bind values. fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)]) | isUnLiftedType (idType case_bndr) , exprOkForSideEffects (deAnnotate scrut) + -- See PrimOp, Note [PrimOp can_fail and has_side_effects] = wrapFloats shared_binds $ fiExpr dflags (case_float : rhs_binds) rhs where @@ -403,8 +429,15 @@ okToFloatInside bndrs = all ok bndrs ok b = not (isId b) || isOneShotBndr b -- Push the floats inside there are no non-one-shot value binders -noFloatIntoRhs :: AnnExpr' Var (UniqFM Var) -> Bool -noFloatIntoRhs (AnnLam bndr e) +noFloatIntoRhs :: AnnExpr' Var (UniqFM Var) -> Type -> Bool +-- ^ True if it's a bad idea to float bindings into this RHS +-- Preconditio: rhs :: rhs_ty +noFloatIntoRhs rhs rhs_ty + = isUnLiftedType rhs_ty -- See Note [Do not destroy the let/app invariant] + || noFloatIntoExpr rhs + +noFloatIntoExpr :: AnnExpr' Var (UniqFM Var) -> Bool +noFloatIntoExpr (AnnLam bndr e) = not (okToFloatInside (bndr:bndrs)) -- NB: Must line up with fiExpr (AnnLam...); see Trac #7088 where @@ -418,7 +451,7 @@ noFloatIntoRhs (AnnLam bndr e) -- boxing constructor into it, else we box it every time which is very bad -- news indeed. -noFloatIntoRhs rhs = exprIsExpandable (deAnnotate' rhs) +noFloatIntoExpr rhs = exprIsExpandable (deAnnotate' rhs) -- We'd just float right back out again... -- Should match the test in SimplEnv.doFloatFromRhs \end{code} diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs index dbab552431..37d6dc8568 100644 --- a/compiler/simplCore/FloatOut.lhs +++ b/compiler/simplCore/FloatOut.lhs @@ -458,11 +458,6 @@ data FloatBinds = FB !(Bag FloatLet) -- Destined for top level !MajorEnv -- Levels other than top -- See Note [Representation of FloatBinds] -instance Outputable FloatBind where - ppr (FloatLet b) = ptext (sLit "LET") <+> ppr b - ppr (FloatCase e b c bs) = hang (ptext (sLit "CASE") <+> ppr e <+> ptext (sLit "of") <+> ppr b) - 2 (ppr c <+> ppr bs) - instance Outputable FloatBinds where ppr (FB fbs defs) = ptext (sLit "FB") <+> (braces $ vcat diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 1c5ebc501b..d8aec03b03 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -31,8 +31,8 @@ module SimplEnv ( -- Floats Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats, - wrapFloats, floatBinds, setFloats, zapFloats, addRecFloats, - doFloatFromRhs, getFloatBinds, getFloats, mapFloats + wrapFloats, setFloats, zapFloats, addRecFloats, + doFloatFromRhs, getFloatBinds ) where #include "HsVersions.h" @@ -47,7 +47,7 @@ import VarEnv import VarSet import OrdList import Id -import MkCore +import MkCore ( mkWildValBinder ) import TysWiredIn import qualified CoreSubst import qualified Type @@ -344,15 +344,21 @@ Note [Simplifier floats] ~~~~~~~~~~~~~~~~~~~~~~~~~ The Floats is a bunch of bindings, classified by a FloatFlag. +* All of them satisfy the let/app invariant + +Examples + NonRec x (y:ys) FltLifted Rec [(x,rhs)] FltLifted + NonRec x* (p:q) FltOKSpec -- RHS is WHNF. Question: why not FltLifted? NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n - NonRec x# (a /# b) FltCareful NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge - NonRec x# (f y) FltCareful -- Unboxed binding: might fail or diverge - -- (where f :: Int -> Int#) + +Can't happen: + NonRec x# (a /# b) -- Might fail; does not satisfy let/app + NonRec x# (f y) -- Might diverge; does not satisfy let/app \begin{code} data Floats = Floats (OrdList OutBind) FloatFlag @@ -388,13 +394,6 @@ andFF FltOkSpec FltCareful = FltCareful andFF FltOkSpec _ = FltOkSpec andFF FltLifted flt = flt -classifyFF :: CoreBind -> FloatFlag -classifyFF (Rec _) = FltLifted -classifyFF (NonRec bndr rhs) - | not (isStrictId bndr) = FltLifted - | exprOkForSpeculation rhs = FltOkSpec - | otherwise = FltCareful - doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool -- If you change this function look also at FloatIn.noFloatFromRhs doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff}) @@ -423,8 +422,16 @@ emptyFloats :: Floats emptyFloats = Floats nilOL FltLifted unitFloat :: OutBind -> Floats --- A single-binding float -unitFloat bind = Floats (unitOL bind) (classifyFF bind) +-- This key function constructs a singleton float with the right form +unitFloat bind = Floats (unitOL bind) (flag bind) + where + flag (Rec {}) = FltLifted + flag (NonRec bndr rhs) + | not (isStrictId bndr) = FltLifted + | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) + | otherwise = ASSERT2( not (isUnLiftedType (idType bndr)), ppr bndr ) + FltCareful + -- Unlifted binders can only be let-bound if exprOkForSpeculation holds addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv -- Add a non-recursive binding and extend the in-scope set @@ -437,13 +444,6 @@ addNonRec env id rhs env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs), seInScope = extendInScopeSet (seInScope env) id } -mapFloats :: SimplEnv -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> SimplEnv -mapFloats env@SimplEnv { seFloats = Floats fs ff } fun - = env { seFloats = Floats (mapOL app fs) ff } - where - app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e' - app (Rec bs) = Rec (map fun bs) - extendFloats :: SimplEnv -> OutBind -> SimplEnv -- Add these bindings to the floats, and extend the in-scope env too extendFloats env bind @@ -477,31 +477,30 @@ addRecFloats env1 env2@(SimplEnv {seFloats = Floats bs ff}) env2 {seFloats = seFloats env1 `addFlts` unitFloat (Rec (flattenBinds (fromOL bs)))} wrapFloats :: SimplEnv -> OutExpr -> OutExpr -wrapFloats env expr = wrapFlts (seFloats env) expr - -wrapFlts :: Floats -> OutExpr -> OutExpr --- Wrap the floats around the expression, using case-binding where necessary -wrapFlts (Floats bs _) body = foldrOL wrap body bs - where - wrap (Rec prs) body = Let (Rec prs) body - wrap (NonRec b r) body = bindNonRec b r body +-- Wrap the floats around the expression; they should all +-- satisfy the let/app invariant, so mkLets should do the job just fine +wrapFloats (SimplEnv {seFloats = Floats bs _}) body + = foldrOL Let body bs getFloatBinds :: SimplEnv -> [CoreBind] -getFloatBinds env = floatBinds (seFloats env) - -getFloats :: SimplEnv -> Floats -getFloats env = seFloats env +getFloatBinds (SimplEnv {seFloats = Floats bs _}) + = fromOL bs isEmptyFloats :: SimplEnv -> Bool -isEmptyFloats env = isEmptyFlts (seFloats env) - -isEmptyFlts :: Floats -> Bool -isEmptyFlts (Floats bs _) = isNilOL bs - -floatBinds :: Floats -> [OutBind] -floatBinds (Floats bs _) = fromOL bs +isEmptyFloats (SimplEnv {seFloats = Floats bs _}) + = isNilOL bs \end{code} +-- mapFloats commented out: used only in a commented-out bit of Simplify, +-- concerning ticks +-- +-- mapFloats :: SimplEnv -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> SimplEnv +-- mapFloats env@SimplEnv { seFloats = Floats fs ff } fun +-- = env { seFloats = Floats (mapOL app fs) ff } +-- where +-- app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e' +-- app (Rec bs) = Rec (map fun bs) + %************************************************************************ %* * diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 14789c44a4..888c923254 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -854,6 +854,10 @@ the former. \begin{code} preInlineUnconditionally :: DynFlags -> SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool +-- Precondition: rhs satisfies the let/app invariant +-- See Note [CoreSyn let/app invariant] in CoreSyn +-- Reason: we don't want to inline single uses, or discard dead bindings, +-- for unlifted, side-effect-full bindings preInlineUnconditionally dflags env top_lvl bndr rhs | not active = False | isStableUnfolding (idUnfolding bndr) = False -- Note [InlineRule and preInlineUnconditionally] @@ -963,6 +967,10 @@ postInlineUnconditionally -> OutExpr -> Unfolding -> Bool +-- Precondition: rhs satisfies the let/app invariant +-- See Note [CoreSyn let/app invariant] in CoreSyn +-- Reason: we don't want to inline single uses, or discard dead bindings, +-- for unlifted, side-effect-full bindings postInlineUnconditionally dflags env top_lvl bndr occ_info rhs unfolding | not active = False | isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 1125c2e883..cc214f7513 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -326,7 +326,7 @@ simplLazyBind :: SimplEnv -- The OutId has IdInfo, except arity, unfolding -> InExpr -> SimplEnv -- The RHS and its environment -> SimplM SimplEnv - +-- Precondition: rhs obeys the let/app invariant simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se = -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ do { let rhs_env = rhs_se `setInScope` env @@ -378,11 +378,12 @@ simplNonRecX :: SimplEnv -> InId -- Old binder -> OutExpr -- Simplified RHS -> SimplM SimplEnv - +-- Precondition: rhs satisfies the let/app invariant simplNonRecX env bndr new_rhs | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } - = return env -- Here c is dead, and we avoid creating - -- the binding c = (a,b) + = return env -- Here c is dead, and we avoid creating + -- the binding c = (a,b) + | Coercion co <- new_rhs = return (extendCvSubst env bndr co) @@ -397,6 +398,8 @@ completeNonRecX :: TopLevelFlag -> SimplEnv -> OutId -- New binder -> OutExpr -- Simplified RHS -> SimplM SimplEnv +-- Precondition: rhs satisfies the let/app invariant +-- See Note [CoreSyn let/app invariant] in CoreSyn completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs = do { (env1, rhs1) <- prepareRhs top_lvl (zapFloats env) new_bndr new_rhs @@ -644,7 +647,8 @@ completeBind :: SimplEnv -- completeBind may choose to do its work -- * by extending the substitution (e.g. let x = y in ...) -- * or by adding to the floats in the envt - +-- +-- Precondition: rhs obeys the let/app invariant completeBind env top_lvl old_bndr new_bndr new_rhs | isCoVar old_bndr = case new_rhs of @@ -1177,6 +1181,8 @@ rebuild env expr cont Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr + -- expr satisfies let/app since it started life + -- in a call to simplNonRecE ; simplLam env' bs body cont } ApplyTo dup_flag arg se cont -- See Note [Avoid redundant simplification] | isSimplified dup_flag -> rebuild env (App expr arg) cont @@ -1327,6 +1333,9 @@ simplNonRecE :: SimplEnv -- It deals with strict bindings, via the StrictBind continuation, -- which may abort the whole process -- +-- Precondition: rhs satisfies the let/app invariant +-- Note [CoreSyn let/app invariant] in CoreSyn +-- -- The "body" of the binding comes as a pair of ([InId],InExpr) -- representing a lambda; so we recurse back to simplLam -- Why? Because of the binder-occ-info-zapping done before @@ -1342,22 +1351,21 @@ simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont = do dflags <- getDynFlags case () of - _ - | preInlineUnconditionally dflags env NotTopLevel bndr rhs -> - do { tick (PreInlineUnconditionally bndr) - ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ + _ | preInlineUnconditionally dflags env NotTopLevel bndr rhs + -> do { tick (PreInlineUnconditionally bndr) + ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont } - | isStrictId bndr -> -- Includes coercions - do { simplExprF (rhs_se `setFloats` env) rhs - (StrictBind bndr bndrs body env cont) } + | isStrictId bndr -- Includes coercions + -> simplExprF (rhs_se `setFloats` env) rhs + (StrictBind bndr bndrs body env cont) - | otherwise -> - ASSERT( not (isTyVar bndr) ) - do { (env1, bndr1) <- simplNonRecBndr env bndr - ; let (env2, bndr2) = addBndrRules env1 bndr bndr1 - ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se - ; simplLam env3 bndrs body cont } + | otherwise + -> ASSERT( not (isTyVar bndr) ) + do { (env1, bndr1) <- simplNonRecBndr env bndr + ; let (env2, bndr2) = addBndrRules env1 bndr bndr1 + ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se + ; simplLam env3 bndrs body cont } \end{code} %************************************************************************ @@ -1717,7 +1725,13 @@ transformation: or (b) 'x' is not used at all and e is ok-for-speculation The ok-for-spec bit checks that we don't lose any - exceptions or divergence + exceptions or divergence. + + NB: it'd be *sound* to switch from case to let if the + scrutinee was not yet WHNF but was guaranteed to + converge; but sticking with case means we won't build a + thunk + or (c) 'x' is used strictly in the body, and 'e' is a variable Then we can just substitute 'e' for 'x' in the body. @@ -1863,6 +1877,8 @@ rebuildCase env scrut case_bndr alts cont where simple_rhs bs rhs = ASSERT( null bs ) do { env' <- simplNonRecX env case_bndr scrut + -- scrut is a constructor application, + -- hence satisfies let/app invariant ; simplExprF env' rhs cont } @@ -1870,56 +1886,41 @@ rebuildCase env scrut case_bndr alts cont -- 2. Eliminate the case if scrutinee is evaluated -------------------------------------------------- -rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont +rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont -- See if we can get rid of the case altogether -- See Note [Case elimination] -- mkCase made sure that if all the alternatives are equal, -- then there is now only one (DEFAULT) rhs - | all isDeadBinder bndrs -- bndrs are [InId] - - , if isUnLiftedType (idType case_bndr) - then elim_unlifted -- Satisfy the let-binding invariant - else elim_lifted - = do { -- pprTrace "case elim" (vcat [ppr case_bndr, ppr (exprIsHNF scrut), - -- ppr ok_for_spec, - -- ppr scrut]) $ - tick (CaseElim case_bndr) - ; env' <- simplNonRecX env case_bndr scrut - -- If case_bndr is dead, simplNonRecX will discard - ; simplExprF env' rhs cont } - where - elim_lifted -- See Note [Case elimination: lifted case] - = exprIsHNF scrut - || (is_plain_seq && ok_for_spec) - -- Note: not the same as exprIsHNF - || (strict_case_bndr && scrut_is_var scrut) - -- See Note [Eliminating redundant seqs] - - elim_unlifted - | is_plain_seq = exprOkForSideEffects scrut - -- The entire case is dead, so we can drop it, - -- _unless_ the scrutinee has side effects - | otherwise = ok_for_spec - -- The case-binder is alive, but we may be able - -- turn the case into a let, if the expression is ok-for-spec - -- See Note [Case elimination: unlifted case] - ok_for_spec = exprOkForSpeculation scrut - is_plain_seq = isDeadBinder case_bndr -- Evaluation *only* for effect - strict_case_bndr = isStrictDmd (idDemandInfo case_bndr) - - scrut_is_var :: CoreExpr -> Bool - scrut_is_var (Cast s _) = scrut_is_var s - scrut_is_var (Var _) = True - scrut_is_var _ = False - - --------------------------------------------------- --- 3. Try seq rules; see Note [User-defined RULES for seq] in MkId --------------------------------------------------- - -rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont - | all isDeadBinder (case_bndr : bndrs) -- So this is just 'seq' + -- 2a. Dropping the case altogether, if + -- a) it binds nothing (so it's really just a 'seq') + -- b) evaluating the scrutinee has no side effects + | is_plain_seq + , exprOkForSideEffects scrut + -- The entire case is dead, so we can drop it + -- if the scrutinee converges without having imperative + -- side effects or raising a Haskell exception + -- See Note [PrimOp can_fail and has_side_effects] in PrimOp + = simplExprF env rhs cont + + -- 2b. Turn the case into a let, if + -- a) it binds only the case-binder + -- b) unlifted case: the scrutinee is ok-for-speculation + -- lifted case: the scrutinee is in HNF (or will later be demanded) + | all_dead_bndrs + , if is_unlifted + then exprOkForSpeculation scrut -- See Note [Case elimination: unlifted case] + else exprIsHNF scrut -- See Note [Case elimination: lifted case] + || scrut_is_demanded_var scrut + = do { tick (CaseElim case_bndr) + ; env' <- simplNonRecX env case_bndr scrut + ; simplExprF env' rhs cont } + + -- 2c. Try the seq rules if + -- a) it binds only the case binder + -- b) a rule for seq applies + -- See Note [User-defined RULES for seq] in MkId + | is_plain_seq = do { let rhs' = substExpr (text "rebuild-case") env rhs env' = zapSubstEnv env out_args = [Type (substTy env (idType case_bndr)), @@ -1931,6 +1932,17 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont ; case mb_rule of Just (rule_rhs, cont') -> simplExprF env' rule_rhs cont' Nothing -> reallyRebuildCase env scrut case_bndr alts cont } + where + is_unlifted = isUnLiftedType (idType case_bndr) + all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] + is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect + + scrut_is_demanded_var :: CoreExpr -> Bool + -- See Note [Eliminating redundant seqs] + scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s + scrut_is_demanded_var (Var _) = isStrictDmd (idDemandInfo case_bndr) + scrut_is_demanded_var _ = False + rebuildCase env scrut case_bndr alts cont = reallyRebuildCase env scrut case_bndr alts cont @@ -2267,7 +2279,7 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont -- it via postInlineUnconditionally. -- Nevertheless we must keep it if the case-binder is alive, -- because it may be used in the con_app. See Note [knownCon occ info] - ; env'' <- simplNonRecX env' b' arg + ; env'' <- simplNonRecX env' b' arg -- arg satisfies let/app invariant ; bind_args env'' bs' args } bind_args _ _ _ = diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index f240be4cd7..a3b7c0b72a 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -115,7 +115,7 @@ dmdAnalStar :: AnalEnv -> Demand -- This one takes a *Demand* -> CoreExpr -> (BothDmdArg, CoreExpr) dmdAnalStar env dmd e - | (cd, defer_and_use) <- toCleanDmd dmd + | (cd, defer_and_use) <- toCleanDmd dmd (exprType e) , (dmd_ty, e') <- dmdAnal env cd e = (postProcessDmdTypeM defer_and_use dmd_ty, e') diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 4d5eeeacf7..d0b2d0da5a 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -217,9 +217,12 @@ tcLookupFamInst tycon tys | otherwise = do { instEnv <- tcGetFamInstEnvs ; let mb_match = lookupFamInstEnv instEnv tycon tys - ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ - pprTvBndrs (varSetElems (tyVarsOfTypes tys)) $$ - ppr mb_match $$ ppr instEnv) + ; traceTc "lookupFamInst" $ + vcat [ ppr tycon <+> ppr tys + , pprTvBndrs (varSetElems (tyVarsOfTypes tys)) + , ppr mb_match + -- , ppr instEnv + ] ; case mb_match of [] -> return Nothing (match:_) @@ -297,8 +300,11 @@ checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool checkForConflicts inst_envs fam_inst = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst no_conflicts = null conflicts - ; traceTc "checkForConflicts" (ppr (map fim_instance conflicts) $$ - ppr fam_inst $$ ppr inst_envs) + ; traceTc "checkForConflicts" $ + vcat [ ppr (map fim_instance conflicts) + , ppr fam_inst + -- , ppr inst_envs + ] ; unless no_conflicts $ conflictInstErr fam_inst conflicts ; return no_conflicts } diff --git a/compiler/typecheck/FunDeps.lhs b/compiler/typecheck/FunDeps.lhs index e5cd356712..5cfd22664a 100644 --- a/compiler/typecheck/FunDeps.lhs +++ b/compiler/typecheck/FunDeps.lhs @@ -28,8 +28,8 @@ import Unify import InstEnv import VarSet import VarEnv -import Maybes( firstJusts ) import Outputable +import ErrUtils( Validity(..), allValid ) import Util import FastString @@ -417,7 +417,7 @@ makes instance inference go into a loop, because it requires the constraint \begin{code} checkInstCoverage :: Bool -- Be liberal -> Class -> [PredType] -> [Type] - -> Maybe SDoc + -> Validity -- "be_liberal" flag says whether to use "liberal" coverage of -- See Note [Coverage Condition] below -- @@ -426,14 +426,14 @@ checkInstCoverage :: Bool -- Be liberal -- Just msg => coverage problem described by msg checkInstCoverage be_liberal clas theta inst_taus - = firstJusts (map fundep_ok fds) + = allValid (map fundep_ok fds) where (tyvars, fds) = classTvsFds clas fundep_ok fd | if be_liberal then liberal_ok else conservative_ok - = Nothing + = IsValid | otherwise - = Just msg + = NotValid msg where (ls,rs) = instFD fd tyvars inst_taus ls_tvs = closeOverKinds (tyVarsOfTypes ls) -- See Note [Closing over kinds in coverage] diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 2bcf981e06..a27c0bd0f6 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -49,7 +49,6 @@ import TcMType import Type import Coercion ( Role(..) ) import TcType -import Unify import HscTypes import Id import Name @@ -60,9 +59,9 @@ import PrelNames import SrcLoc import DynFlags import Bag -import Maybes import Util import Outputable +import Control.Monad( unless ) import Data.List( mapAccumL ) \end{code} @@ -383,14 +382,15 @@ syntaxNameCtxt name orig ty tidy_env \begin{code} getOverlapFlag :: TcM OverlapFlag -getOverlapFlag +getOverlapFlag = do { dflags <- getDynFlags ; let overlap_ok = xopt Opt_OverlappingInstances dflags incoherent_ok = xopt Opt_IncoherentInstances dflags - safeOverlap = safeLanguageOn dflags - overlap_flag | incoherent_ok = Incoherent safeOverlap - | overlap_ok = OverlapOk safeOverlap - | otherwise = NoOverlap safeOverlap + use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags + , overlapMode = x } + overlap_flag | incoherent_ok = use Incoherent + | overlap_ok = use Overlaps + | otherwise = use NoOverlap ; return overlap_flag } @@ -409,22 +409,24 @@ tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a tcExtendLocalInstEnv dfuns thing_inside = do { traceDFuns dfuns ; env <- getGblEnv - ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns - ; let env' = env { tcg_insts = dfuns ++ tcg_insts env, - tcg_inst_env = inst_env' } + ; (inst_env', cls_insts') <- foldlM addLocalInst + (tcg_inst_env env, tcg_insts env) + dfuns + ; let env' = env { tcg_insts = cls_insts' + , tcg_inst_env = inst_env' } ; setGblEnv env' thing_inside } -addLocalInst :: InstEnv -> ClsInst -> TcM InstEnv --- Check that the proposed new instance is OK, +addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst]) +-- Check that the proposed new instance is OK, -- and then add it to the home inst env -- If overwrite_inst, then we can overwrite a direct match -addLocalInst home_ie ispec +addLocalInst (home_ie, my_insts) ispec = do { -- Instantiate the dfun type so that we extend the instance -- envt with completely fresh template variables -- This is important because the template variables must -- not overlap with anything in the things being looked up - -- (since we do unification). + -- (since we do unification). -- -- We use tcInstSkolType because we don't want to allocate fresh -- *meta* type variables. @@ -437,9 +439,23 @@ addLocalInst home_ie ispec -- Load imported instances, so that we report -- duplicates correctly - eps <- getEps - ; let inst_envs = (eps_inst_env eps, home_ie) - (tvs, cls, tys) = instanceHead ispec + + -- 'matches' are existing instance declarations that are less + -- specific than the new one + -- 'dups' are those 'matches' that are equal to the new one + ; isGHCi <- getIsGHCi + ; eps <- getEps + ; let (home_ie', my_insts') + | isGHCi = ( deleteFromInstEnv home_ie ispec + , filterOut (identicalInstHead ispec) my_insts) + | otherwise = (home_ie, my_insts) + -- If there is a home-package duplicate instance, + -- silently delete it + + (_tvs, cls, tys) = instanceHead ispec + inst_envs = (eps_inst_env eps, home_ie') + (matches, _, _) = lookupInstEnv inst_envs cls tys + dups = filter (identicalInstHead ispec) (map fst matches) -- Check functional dependencies ; case checkFunDeps inst_envs ispec of @@ -447,31 +463,10 @@ addLocalInst home_ie ispec Nothing -> return () -- Check for duplicate instance decls - ; let (matches, unifs, _) = lookupInstEnv inst_envs cls tys - dup_ispecs = [ dup_ispec - | (dup_ispec, _) <- matches - , let dup_tys = is_tys dup_ispec - , isJust (tcMatchTys (mkVarSet tvs) tys dup_tys)] - - -- Find memebers of the match list which ispec itself matches. - -- If the match is 2-way, it's a duplicate - -- If it's a duplicate, but we can overwrite home package dups, then overwrite - ; isGHCi <- getIsGHCi - ; overlapFlag <- getOverlapFlag - ; case isGHCi of - False -> case dup_ispecs of - dup : _ -> dupInstErr ispec dup >> return (extendInstEnv home_ie ispec) - [] -> return (extendInstEnv home_ie ispec) - True -> case (dup_ispecs, home_ie_matches, unifs, overlapFlag) of - (_, _:_, _, _) -> return (overwriteInstEnv home_ie ispec) - (dup:_, [], _, _) -> dupInstErr ispec dup >> return (extendInstEnv home_ie ispec) - ([], _, u:_, NoOverlap _) -> overlappingInstErr ispec u >> return (extendInstEnv home_ie ispec) - _ -> return (extendInstEnv home_ie ispec) - where (homematches, _) = lookupInstEnv' home_ie cls tys - home_ie_matches = [ dup_ispec - | (dup_ispec, _) <- homematches - , let dup_tys = is_tys dup_ispec - , isJust (tcMatchTys (mkVarSet tvs) tys dup_tys)] } + ; unless (null dups) $ + dupInstErr ispec (head dups) + + ; return (extendInstEnv home_ie' ispec, ispec:my_insts') } traceDFuns :: [ClsInst] -> TcRn () traceDFuns ispecs @@ -491,11 +486,6 @@ dupInstErr ispec dup_ispec = addClsInstsErr (ptext (sLit "Duplicate instance declarations:")) [ispec, dup_ispec] -overlappingInstErr :: ClsInst -> ClsInst -> TcRn () -overlappingInstErr ispec dup_ispec - = addClsInstsErr (ptext (sLit "Overlapping instance declarations:")) - [ispec, dup_ispec] - addClsInstsErr :: SDoc -> [ClsInst] -> TcRn () addClsInstsErr herald ispecs = setSrcSpan (getSrcSpan (head sorted)) $ diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index bf9d24be0a..eab8941956 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -6,16 +6,10 @@ Typecheck arrow notation \begin{code} {-# LANGUAGE RankNTypes #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details module TcArrows ( tcProc ) where -import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr ) +import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr ) import HsSyn import TcMatches @@ -78,32 +72,32 @@ Note that %************************************************************************ -%* * - Proc -%* * +%* * + Proc +%* * %************************************************************************ \begin{code} -tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr - -> TcRhoType -- Expected type of whole proc expression +tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr + -> TcRhoType -- Expected type of whole proc expression -> TcM (OutPat TcId, LHsCmdTop TcId, TcCoercion) tcProc pat cmd exp_ty = newArrowScope $ - do { (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty - ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 - ; let cmd_env = CmdEnv { cmd_arr = arr_ty } + do { (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty + ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 + ; let cmd_env = CmdEnv { cmd_arr = arr_ty } ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $ - tcCmdTop cmd_env cmd (unitTy, res_ty) + tcCmdTop cmd_env cmd (unitTy, res_ty) ; let res_co = mkTcTransCo co (mkTcAppCo co1 (mkTcNomReflCo res_ty)) ; return (pat', cmd', res_co) } \end{code} %************************************************************************ -%* * - Commands -%* * +%* * + Commands +%* * %************************************************************************ \begin{code} @@ -113,7 +107,7 @@ type CmdArgType = TcTauType -- carg_type, a nested tuple data CmdEnv = CmdEnv { - cmd_arr :: TcType -- arrow type constructor, of kind *->*->* + cmd_arr :: TcType -- arrow type constructor, of kind *->*->* } mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType @@ -127,27 +121,27 @@ tcCmdTop :: CmdEnv tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_ty@(cmd_stk, res_ty) = setSrcSpan loc $ - do { cmd' <- tcCmd env cmd cmd_ty - ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names - ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') } + do { cmd' <- tcCmd env cmd cmd_ty + ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names + ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') } ---------------------------------------- tcCmd :: CmdEnv -> LHsCmd Name -> CmdType -> TcM (LHsCmd TcId) - -- The main recursive function + -- The main recursive function tcCmd env (L loc cmd) res_ty = setSrcSpan loc $ do - { cmd' <- tc_cmd env cmd res_ty - ; return (L loc cmd') } + { cmd' <- tc_cmd env cmd res_ty + ; return (L loc cmd') } tc_cmd :: CmdEnv -> HsCmd Name -> CmdType -> TcM (HsCmd TcId) tc_cmd env (HsCmdPar cmd) res_ty - = do { cmd' <- tcCmd env cmd res_ty - ; return (HsCmdPar cmd') } + = do { cmd' <- tcCmd env cmd res_ty + ; return (HsCmdPar cmd') } tc_cmd env (HsCmdLet binds (L body_loc body)) res_ty - = do { (binds', body') <- tcLocalBinds binds $ - setSrcSpan body_loc $ - tc_cmd env body res_ty - ; return (HsCmdLet binds' (L body_loc body')) } + = do { (binds', body') <- tcLocalBinds binds $ + setSrcSpan body_loc $ + tc_cmd env body res_ty + ; return (HsCmdLet binds' (L body_loc body')) } tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty) = addErrCtxt (cmdCtxt in_cmd) $ do @@ -167,25 +161,25 @@ tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty -- Ordinary 'if' } tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if - = do { pred_ty <- newFlexiTyVarTy openTypeKind + = do { pred_ty <- newFlexiTyVarTy openTypeKind -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r -- because we're going to apply it to the environment, not -- the return value. ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar] - ; let r_ty = mkTyVarTy r_tv + ; let r_ty = mkTyVarTy r_tv ; let if_ty = mkFunTys [pred_ty, r_ty, r_ty] r_ty ; checkTc (not (r_tv `elemVarSet` tyVarsOfType pred_ty)) (ptext (sLit "Predicate type of `ifThenElse' depends on result type")) - ; fun' <- tcSyntaxOp IfOrigin fun if_ty - ; pred' <- tcMonoExpr pred pred_ty - ; b1' <- tcCmd env b1 res_ty - ; b2' <- tcCmd env b2 res_ty + ; fun' <- tcSyntaxOp IfOrigin fun if_ty + ; pred' <- tcMonoExpr pred pred_ty + ; b1' <- tcCmd env b1 res_ty + ; b2' <- tcCmd env b2 res_ty ; return (HsCmdIf (Just fun') pred' b1' b2') } ------------------------------------------- --- Arrow application --- (f -< a) or (f -<< a) +-- Arrow application +-- (f -< a) or (f -<< a) -- -- D |- fun :: a t1 t2 -- D,G |- arg :: t1 @@ -200,16 +194,16 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if -- (plus -<< requires ArrowApply) tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) - = addErrCtxt (cmdCtxt cmd) $ + = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newFlexiTyVarTy openTypeKind - ; let fun_ty = mkCmdArrTy env arg_ty res_ty - ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty) + ; let fun_ty = mkCmdArrTy env arg_ty res_ty + ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty) -- ToDo: There should be no need for the escapeArrowScope stuff -- See Note [Escaping the arrow scope] in TcRnTypes - ; arg' <- tcMonoExpr arg arg_ty + ; arg' <- tcMonoExpr arg arg_ty - ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) } + ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) } where -- Before type-checking f, use the environment of the enclosing -- proc for the (-<) case. @@ -220,7 +214,7 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) HsFirstOrderApp -> escapeArrowScope tc ------------------------------------------- --- Command application +-- Command application -- -- D,G |- exp : t -- D;G |-a cmd : (t,stk) --> res @@ -228,14 +222,14 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) -- D;G |-a cmd exp : stk --> res tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) - = addErrCtxt (cmdCtxt cmd) $ + = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newFlexiTyVarTy openTypeKind - ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) - ; arg' <- tcMonoExpr arg arg_ty - ; return (HsCmdApp fun' arg') } + ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) + ; arg' <- tcMonoExpr arg arg_ty + ; return (HsCmdApp fun' arg') } ------------------------------------------- --- Lambda +-- Lambda -- -- D;G,x:t |-a cmd : stk --> res -- ------------------------------ @@ -244,60 +238,60 @@ tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty) tc_cmd env (HsCmdLam (MG { mg_alts = [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))], mg_origin = origin })) (cmd_stk, res_ty) - = addErrCtxt (pprMatchInCtxt match_ctxt match) $ - do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk + = addErrCtxt (pprMatchInCtxt match_ctxt match) $ + do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk - -- Check the patterns, and the GRHSs inside - ; (pats', grhss') <- setSrcSpan mtch_loc $ + -- Check the patterns, and the GRHSs inside + ; (pats', grhss') <- setSrcSpan mtch_loc $ tcPats LambdaExpr pats arg_tys $ tc_grhss grhss cmd_stk' res_ty - ; let match' = L mtch_loc (Match pats' Nothing grhss') + ; let match' = L mtch_loc (Match pats' Nothing grhss') arg_tys = map hsLPatType pats' cmd' = HsCmdLam (MG { mg_alts = [match'], mg_arg_tys = arg_tys , mg_res_ty = res_ty, mg_origin = origin }) - ; return (mkHsCmdCast co cmd') } + ; return (mkHsCmdCast co cmd') } where n_pats = length pats - match_ctxt = (LambdaExpr :: HsMatchContext Name) -- Maybe KappaExpr? + match_ctxt = (LambdaExpr :: HsMatchContext Name) -- Maybe KappaExpr? pg_ctxt = PatGuard match_ctxt tc_grhss (GRHSs grhss binds) stk_ty res_ty - = do { (binds', grhss') <- tcLocalBinds binds $ - mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss - ; return (GRHSs grhss' binds') } + = do { (binds', grhss') <- tcLocalBinds binds $ + mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss + ; return (GRHSs grhss' binds') } tc_grhs stk_ty res_ty (GRHS guards body) - = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ - \ res_ty -> tcCmd env body (stk_ty, res_ty) - ; return (GRHS guards' rhs') } + = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ + \ res_ty -> tcCmd env body (stk_ty, res_ty) + ; return (GRHS guards' rhs') } ------------------------------------------- --- Do notation +-- Do notation tc_cmd env (HsCmdDo stmts _) (cmd_stk, res_ty) - = do { co <- unifyType unitTy cmd_stk -- Expecting empty argument stack - ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty - ; return (mkHsCmdCast co (HsCmdDo stmts' res_ty)) } + = do { co <- unifyType unitTy cmd_stk -- Expecting empty argument stack + ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty + ; return (mkHsCmdCast co (HsCmdDo stmts' res_ty)) } ----------------------------------------------------------------- --- Arrow ``forms'' (| e c1 .. cn |) +-- Arrow ``forms'' (| e c1 .. cn |) -- --- D; G |-a1 c1 : stk1 --> r1 --- ... --- D; G |-an cn : stkn --> rn --- D |- e :: forall e. a1 (e, stk1) t1 +-- D; G |-a1 c1 : stk1 --> r1 +-- ... +-- D; G |-an cn : stkn --> rn +-- D |- e :: forall e. a1 (e, stk1) t1 -- ... -- -> an (e, stkn) tn -- -> a (e, stk) t --- e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn) --- ---------------------------------------------- --- D; G |-a (| e c1 ... cn |) : stk --> t +-- e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn) +-- ---------------------------------------------- +-- D; G |-a (| e c1 ... cn |) : stk --> t -tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) - = addErrCtxt (cmdCtxt cmd) $ - do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args +tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) + = addErrCtxt (cmdCtxt cmd) $ + do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args ; let e_ty = mkForAllTy alphaTyVar $ -- We use alphaTyVar for 'w' mkFunTys cmd_tys $ mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty @@ -308,19 +302,19 @@ tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) tc_cmd_arg :: LHsCmdTop Name -> TcM (LHsCmdTop TcId, TcType) tc_cmd_arg cmd = do { arr_ty <- newFlexiTyVarTy arrowTyConKind - ; stk_ty <- newFlexiTyVarTy liftedTypeKind - ; res_ty <- newFlexiTyVarTy liftedTypeKind - ; let env' = env { cmd_arr = arr_ty } - ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty) - ; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } + ; stk_ty <- newFlexiTyVarTy liftedTypeKind + ; res_ty <- newFlexiTyVarTy liftedTypeKind + ; let env' = env { cmd_arr = arr_ty } + ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty) + ; return (cmd', mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } ----------------------------------------------------------------- --- Base case for illegal commands +-- Base case for illegal commands -- This is where expressions that aren't commands get rejected tc_cmd _ cmd _ = failWithTc (vcat [ptext (sLit "The expression"), nest 2 (ppr cmd), - ptext (sLit "was found where an arrow command was expected")]) + ptext (sLit "was found where an arrow command was expected")]) matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercion, [TcType], TcType) @@ -334,34 +328,34 @@ matchExpectedCmdArgs n ty %************************************************************************ -%* * - Stmts -%* * +%* * + Stmts +%* * %************************************************************************ \begin{code} -------------------------------- --- Mdo-notation +-- Mdo-notation -- The distinctive features here are --- (a) RecStmts, and --- (b) no rebindable syntax +-- (a) RecStmts, and +-- (b) no rebindable syntax tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker tcArrDoStmt env _ (LastStmt rhs _) res_ty thing_inside - = do { rhs' <- tcCmd env rhs (unitTy, res_ty) - ; thing <- thing_inside (panic "tcArrDoStmt") - ; return (LastStmt rhs' noSyntaxExpr, thing) } + = do { rhs' <- tcCmd env rhs (unitTy, res_ty) + ; thing <- thing_inside (panic "tcArrDoStmt") + ; return (LastStmt rhs' noSyntaxExpr, thing) } tcArrDoStmt env _ (BodyStmt rhs _ _ _) res_ty thing_inside - = do { (rhs', elt_ty) <- tc_arr_rhs env rhs - ; thing <- thing_inside res_ty - ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) } + = do { (rhs', elt_ty) <- tc_arr_rhs env rhs + ; thing <- thing_inside res_ty + ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) } tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside - = do { (rhs', pat_ty) <- tc_arr_rhs env rhs - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ + = do { (rhs', pat_ty) <- tc_arr_rhs env rhs + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ thing_inside res_ty - ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } + ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names , recS_rec_ids = rec_names }) res_ty thing_inside @@ -370,15 +364,15 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys ; tcExtendIdEnv tup_ids $ do { (stmts', tup_rets) - <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> - -- ToDo: res_ty not really right + <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> + -- ToDo: res_ty not really right zipWithM tcCheckId tup_names tup_elt_tys ; thing <- thing_inside res_ty - -- NB: The rec_ids for the recursive things - -- already scope over this part. This binding may shadow - -- some of them with polymorphic things with the same Name - -- (see note [RecStmt] in HsExpr) + -- NB: The rec_ids for the recursive things + -- already scope over this part. This binding may shadow + -- some of them with polymorphic things with the same Name + -- (see note [RecStmt] in HsExpr) ; let rec_ids = takeList rec_names tup_ids ; later_ids <- tcLookupLocalIds later_names @@ -391,22 +385,22 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names , recS_later_rets = later_rets , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets , recS_ret_ty = res_ty }, thing) - }} + }} tcArrDoStmt _ _ stmt _ _ = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt) tc_arr_rhs :: CmdEnv -> LHsCmd Name -> TcM (LHsCmd TcId, TcType) tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcCmd env rhs (unitTy, ty) - ; return (rhs', ty) } + ; rhs' <- tcCmd env rhs (unitTy, ty) + ; return (rhs', ty) } \end{code} %************************************************************************ -%* * - Helpers -%* * +%* * + Helpers +%* * %************************************************************************ @@ -414,15 +408,15 @@ tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind mkPairTy :: Type -> Type -> Type mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2] -arrowTyConKind :: Kind -- *->*->* +arrowTyConKind :: Kind -- *->*->* arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind \end{code} %************************************************************************ -%* * - Errors -%* * +%* * + Errors +%* * %************************************************************************ \begin{code} diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 887e41c0d5..34db200ab6 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -16,7 +16,7 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcMonoExpr ) -import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl ) +import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynWrapper ) import DynFlags import HsSyn @@ -315,16 +315,21 @@ tcValBinds top_lvl binds sigs thing_inside -- Extend the envt right away with all -- the Ids declared with type signatures -- Use tcExtendIdEnv2 to avoid extending the TcIdBinder stack - ; tcExtendIdEnv2 [(idName id, id) | id <- poly_ids] $ - tcBindGroups top_lvl sig_fn prag_fn - binds thing_inside } + ; tcExtendIdEnv2 [(idName id, id) | id <- poly_ids] $ do + { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do + { thing <- thing_inside + -- See Note [Pattern synonym wrappers don't yield dependencies] + ; patsyn_wrappers <- mapM tcPatSynWrapper patsyns + ; let extra_binds = [ (NonRecursive, wrapper) | wrapper <- patsyn_wrappers ] + ; return (extra_binds, thing) } + ; return (binds' ++ extra_binds', thing) }} where + patsyns + = [psb | (_, lbinds) <- binds, L _ (PatSynBind psb) <- bagToList lbinds] patsyn_placeholder_kinds -- See Note [Placeholder PatSyn kinds] - = [ (name, placeholder_patsyn_tything) - | (_, lbinds) <- binds - , L _ (PatSynBind{ patsyn_id = L _ name }) <- bagToList lbinds ] + = [(name, placeholder_patsyn_tything)| PSB{ psb_id = L _ name } <- patsyns ] placeholder_patsyn_tything - = AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon" + = AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon" ------------------------ tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun @@ -413,9 +418,8 @@ tc_single :: forall thing. TopLevelFlag -> TcSigFun -> PragFun -> LHsBind Name -> TcM thing -> TcM (LHsBinds TcId, thing) -tc_single _top_lvl _sig_fn _prag_fn (L _ ps@PatSynBind{}) thing_inside - = do { (pat_syn, aux_binds) <- - tcPatSynDecl (patsyn_id ps) (patsyn_args ps) (patsyn_def ps) (patsyn_dir ps) +tc_single _top_lvl _sig_fn _prag_fn (L _ (PatSynBind psb)) thing_inside + = do { (pat_syn, aux_binds) <- tcPatSynDecl psb ; let tything = AConLike (PatSynCon pat_syn) implicit_ids = (patSynMatcher pat_syn) : @@ -457,7 +461,7 @@ mkEdges sig_fn binds bindersOfHsBind :: HsBind Name -> [Name] bindersOfHsBind (PatBind { pat_lhs = pat }) = collectPatBinders pat bindersOfHsBind (FunBind { fun_id = L _ f }) = [f] -bindersOfHsBind (PatSynBind { patsyn_id = L _ psyn }) = [psyn] +bindersOfHsBind (PatSynBind PSB{ psb_id = L _ psyn }) = [psyn] bindersOfHsBind (AbsBinds {}) = panic "bindersOfHsBind AbsBinds" bindersOfHsBind (VarBind {}) = panic "bindersOfHsBind VarBind" @@ -835,7 +839,7 @@ tcSpec _ prag = pprPanic "tcSpec" (ppr prag) -------------- tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag] --- SPECIALISE pragamas for imported things +-- SPECIALISE pragmas for imported things tcImpPrags prags = do { this_mod <- getModule ; dflags <- getDynFlags diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 43cbb2c49d..d58d5db40f 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -1186,6 +1186,9 @@ canEqTyVar2 dflags ev swapped tv1 xi2 co2 ; case mb of Nothing -> return () Just new_ev -> emitInsoluble (mkNonCanonical new_ev) + -- If we have a ~ [a], it is not canonical, and in particular + -- we don't want to rewrite existing inerts with it, otherwise + -- we'd risk divergence in the constraint solver ; return Stop } where xi1 = mkTyVarTy tv1 diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 1d7936dcd2..6812ac7387 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -20,7 +20,7 @@ import FamInst import TcErrors( reportAllUnsolved ) import TcValidity( validDerivPred ) import TcEnv -import TcTyClsDecls( tcFamTyPats, tcAddDataFamInstCtxt ) +import TcTyClsDecls( tcFamTyPats, famTyConShape, tcAddDataFamInstCtxt, kcDataDefn ) import TcClassDcl( tcAddDeclCtxt ) -- Small helper import TcGenDeriv -- Deriv stuff import TcGenGenerics @@ -86,13 +86,14 @@ Overall plan \begin{code} -- DerivSpec is purely local to this module data DerivSpec theta = DS { ds_loc :: SrcSpan - , ds_name :: Name + , ds_name :: Name -- DFun name , ds_tvs :: [TyVar] , ds_theta :: theta , ds_cls :: Class , ds_tys :: [Type] , ds_tc :: TyCon , ds_tc_args :: [Type] + , ds_overlap :: Maybe OverlapMode , ds_newtype :: Bool } -- This spec implies a dfun declaration of the form -- df :: forall tvs. theta => C tys @@ -106,7 +107,7 @@ data DerivSpec theta = DS { ds_loc :: SrcSpan -- the theta is either the given and final theta, in standalone deriving, -- or the not-yet-simplified list of constraints together with their origin - -- ds_newtype = True <=> Newtype deriving + -- ds_newtype = True <=> Generalised Newtype Deriving (GND) -- False <=> Vanilla deriving \end{code} @@ -597,28 +598,44 @@ deriveInstDecl (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam ------------------------------------------------------------------ deriveFamInst :: DataFamInstDecl Name -> TcM [EarlyDerivSpec] deriveFamInst decl@(DataFamInstDecl { dfid_tycon = L _ tc_name, dfid_pats = pats - , dfid_defn = HsDataDefn { dd_derivs = Just preds } }) + , dfid_defn = defn@(HsDataDefn { dd_derivs = Just preds }) }) = tcAddDataFamInstCtxt decl $ do { fam_tc <- tcLookupTyCon tc_name - ; tcFamTyPats tc_name (tyConKind fam_tc) pats (\_ -> return ()) $ + ; tcFamTyPats (famTyConShape fam_tc) pats (kcDataDefn defn) $ + -- kcDataDefn defn: see Note [Finding the LHS patterns] \ tvs' pats' _ -> concatMapM (deriveTyData True tvs' fam_tc pats') preds } - -- Tiresomely we must figure out the "lhs", which is awkward for type families - -- E.g. data T a b = .. deriving( Eq ) - -- Here, the lhs is (T a b) - -- data instance TF Int b = ... deriving( Eq ) - -- Here, the lhs is (TF Int b) - -- But if we just look up the tycon_name, we get is the *family* - -- tycon, but not pattern types -- they are in the *rep* tycon. deriveFamInst _ = return [] +\end{code} + +Note [Finding the LHS patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When kind polymorphism is in play, we need to be careful. Here is +Trac #9359: + data Cmp a where + Sup :: Cmp a + V :: a -> Cmp a + + data family CmpInterval (a :: Cmp k) (b :: Cmp k) :: * + data instance CmpInterval (V c) Sup = Starting c deriving( Show ) + +So CmpInterval is kind-polymorphic, but the data instance is not + CmpInterval :: forall k. Cmp k -> Cmp k -> * + data instance CmpInterval * (V (c::*)) Sup = Starting c deriving( Show ) + +Hence, when deriving the type patterns in deriveFamInst, we must kind +check the RHS (the data constructor 'Starting c') as well as the LHS, +so that we correctly see the instantiation to *. + +\begin{code} ------------------------------------------------------------------ deriveStandalone :: LDerivDecl Name -> TcM [EarlyDerivSpec] -- Standalone deriving declarations -- e.g. deriving instance Show a => Show (T a) -- Rather like tcLocalInstDecl -deriveStandalone (L loc (DerivDecl deriv_ty)) +deriveStandalone (L loc (DerivDecl deriv_ty overlap_mode)) = setSrcSpan loc $ addErrCtxt (standaloneCtxt deriv_ty) $ do { traceTc "Standalone deriving decl for" (ppr deriv_ty) @@ -647,7 +664,7 @@ deriveStandalone (L loc (DerivDecl deriv_ty)) ; mkPolyKindedTypeableEqn cls tc } | isAlgTyCon tc -- All other classes - -> do { spec <- mkEqnHelp tvs cls cls_tys tc tc_args (Just theta) + -> do { spec <- mkEqnHelp overlap_mode tvs cls cls_tys tc tc_args (Just theta) ; return [spec] } _ -> -- Complain about functions, primitive types, etc, @@ -769,7 +786,7 @@ deriveTyData is_instance tvs tc tc_args (L loc deriv_pred) -- newtype T a s = ... deriving( ST s ) -- newtype K a a = ... deriving( Monad ) - ; spec <- mkEqnHelp (univ_kvs' ++ univ_tvs') + ; spec <- mkEqnHelp Nothing (univ_kvs' ++ univ_tvs') cls final_cls_tys tc final_tc_args Nothing ; return [spec] } } @@ -851,7 +868,8 @@ and occurrence sites. \begin{code} -mkEqnHelp :: [TyVar] +mkEqnHelp :: Maybe OverlapMode + -> [TyVar] -> Class -> [Type] -> TyCon -> [Type] -> DerivContext -- Just => context supplied (standalone deriving) @@ -862,12 +880,12 @@ mkEqnHelp :: [TyVar] -- where the 'theta' is optional (that's the Maybe part) -- Assumes that this declaration is well-kinded -mkEqnHelp tvs cls cls_tys tycon tc_args mtheta +mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args mtheta | className cls `elem` oldTypeableClassNames = do { dflags <- getDynFlags ; case checkOldTypeableConditions (dflags, tycon, tc_args) of - Just err -> bale_out err - Nothing -> mkOldTypeableEqn tvs cls tycon tc_args mtheta } + NotValid err -> bale_out err + IsValid -> mkOldTypeableEqn tvs cls tycon tc_args mtheta } | otherwise = do { (rep_tc, rep_tc_args) <- lookup_data_fam tycon tc_args @@ -898,10 +916,10 @@ mkEqnHelp tvs cls cls_tys tycon tc_args mtheta ; dflags <- getDynFlags ; if isDataTyCon rep_tc then - mkDataTypeEqn dflags tvs cls cls_tys + mkDataTypeEqn dflags overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta else - mkNewTypeEqn dflags tvs cls cls_tys + mkNewTypeEqn dflags overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta } where bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg) @@ -991,6 +1009,7 @@ See Note [Eta reduction for data family axioms] in TcInstDcls. \begin{code} mkDataTypeEqn :: DynFlags + -> Maybe OverlapMode -> [Var] -- Universally quantified type variables in the instance -> Class -- Class for which we need to derive an instance -> [Type] -- Other parameters to the class except the last @@ -1002,7 +1021,7 @@ mkDataTypeEqn :: DynFlags -> DerivContext -- Context of the instance, for standalone deriving -> TcRn EarlyDerivSpec -- Return 'Nothing' if error -mkDataTypeEqn dflags tvs cls cls_tys +mkDataTypeEqn dflags overlap_mode tvs cls cls_tys tycon tc_args rep_tc rep_tc_args mtheta = case checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args of -- NB: pass the *representation* tycon to checkSideConditions @@ -1010,13 +1029,13 @@ mkDataTypeEqn dflags tvs cls cls_tys NonDerivableClass -> bale_out (nonStdErr cls) DerivableClassError msg -> bale_out msg where - go_for_it = mk_data_eqn tvs cls tycon tc_args rep_tc rep_tc_args mtheta + go_for_it = mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg) -mk_data_eqn :: [TyVar] -> Class +mk_data_eqn :: Maybe OverlapMode -> [TyVar] -> Class -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext -> TcM EarlyDerivSpec -mk_data_eqn tvs cls tycon tc_args rep_tc rep_tc_args mtheta +mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tc rep_tc_args mtheta = do loc <- getSrcSpanM dfun_name <- new_dfun_name cls tycon case mtheta of @@ -1028,6 +1047,7 @@ mk_data_eqn tvs cls tycon tc_args rep_tc rep_tc_args mtheta , ds_cls = cls, ds_tys = inst_tys , ds_tc = rep_tc, ds_tc_args = rep_tc_args , ds_theta = inferred_constraints + , ds_overlap = overlap_mode , ds_newtype = False } Just theta -> do -- Specified context return $ GivenTheta $ DS @@ -1036,6 +1056,7 @@ mk_data_eqn tvs cls tycon tc_args rep_tc rep_tc_args mtheta , ds_cls = cls, ds_tys = inst_tys , ds_tc = rep_tc, ds_tc_args = rep_tc_args , ds_theta = theta + , ds_overlap = overlap_mode , ds_newtype = False } where inst_tys = [mkTyConApp tycon tc_args] @@ -1073,7 +1094,9 @@ mkOldTypeableEqn tvs cls tycon tc_args mtheta DS { ds_loc = loc, ds_name = dfun_name, ds_tvs = [] , ds_cls = cls, ds_tys = [mkTyConApp tycon []] , ds_tc = tycon, ds_tc_args = [] - , ds_theta = mtheta `orElse` [], ds_newtype = False }) } + , ds_theta = mtheta `orElse` [] + , ds_overlap = Nothing -- Or, Just NoOverlap? + , ds_newtype = False }) } mkPolyKindedTypeableEqn :: Class -> TyCon -> TcM [EarlyDerivSpec] -- We can arrive here from a 'deriving' clause @@ -1098,6 +1121,9 @@ mkPolyKindedTypeableEqn cls tc -- so we must instantiate it appropiately , ds_tc = tc, ds_tc_args = tc_args , ds_theta = [] -- Context is empty for polykinded Typeable + , ds_overlap = Nothing + -- Perhaps this should be `Just NoOverlap`? + , ds_newtype = False } } where (kvs,tc_app_kind) = splitForAllTys (tyConKind tc) @@ -1218,10 +1244,10 @@ checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType] checkSideConditions dflags mtheta cls cls_tys rep_tc rep_tc_args | Just cond <- sideConditions mtheta cls = case (cond (dflags, rep_tc, rep_tc_args)) of - Just err -> DerivableClassError err -- Class-specific error - Nothing | null cls_tys -> CanDerive -- All derivable classes are unary, so - -- cls_tys (the type args other than last) - -- should be null + NotValid err -> DerivableClassError err -- Class-specific error + IsValid | null cls_tys -> CanDerive -- All derivable classes are unary, so + -- cls_tys (the type args other than last) + -- should be null | otherwise -> DerivableClassError (classArgsErr cls cls_tys) -- e.g. deriving( Eq s ) | otherwise = NonDerivableClass -- Not a standard class @@ -1269,7 +1295,7 @@ sideConditions mtheta cls cond_vanilla = cond_stdOK mtheta True -- Vanilla data constructors but -- allow no data cons or polytype arguments -type Condition = (DynFlags, TyCon, [Type]) -> Maybe SDoc +type Condition = (DynFlags, TyCon, [Type]) -> Validity -- first Bool is whether or not we are allowed to derive Data and Typeable -- second Bool is whether or not we are allowed to derive Functor -- TyCon is the *representation* tycon if the data type is an indexed one @@ -1278,17 +1304,14 @@ type Condition = (DynFlags, TyCon, [Type]) -> Maybe SDoc orCond :: Condition -> Condition -> Condition orCond c1 c2 tc - = case c1 tc of - Nothing -> Nothing -- c1 succeeds - Just x -> case c2 tc of -- c1 fails - Nothing -> Nothing - Just y -> Just (x $$ ptext (sLit " or") $$ y) - -- Both fail + = case (c1 tc, c2 tc) of + (IsValid, _) -> IsValid -- c1 succeeds + (_, IsValid) -> IsValid -- c21 succeeds + (NotValid x, NotValid y) -> NotValid (x $$ ptext (sLit " or") $$ y) + -- Both fail andCond :: Condition -> Condition -> Condition -andCond c1 c2 tc = case c1 tc of - Nothing -> c2 tc -- c1 succeeds - Just x -> Just x -- c1 fails +andCond c1 c2 tc = c1 tc `andValid` c2 tc cond_stdOK :: DerivContext -- Says whether this is standalone deriving or not; -- if standalone, we just say "yes, go for it" @@ -1296,27 +1319,27 @@ cond_stdOK :: DerivContext -- Says whether this is standalone deriving or not; -- args and no data constructors -> Condition cond_stdOK (Just _) _ _ - = Nothing -- Don't check these conservative conditions for + = IsValid -- Don't check these conservative conditions for -- standalone deriving; just generate the code -- and let the typechecker handle the result cond_stdOK Nothing permissive (_, rep_tc, _) | null data_cons - , not permissive = Just (no_cons_why rep_tc $$ suggestion) - | not (null con_whys) = Just (vcat con_whys $$ suggestion) - | otherwise = Nothing + , not permissive = NotValid (no_cons_why rep_tc $$ suggestion) + | not (null con_whys) = NotValid (vcat con_whys $$ suggestion) + | otherwise = IsValid where suggestion = ptext (sLit "Possible fix: use a standalone deriving declaration instead") data_cons = tyConDataCons rep_tc - con_whys = mapMaybe check_con data_cons + con_whys = getInvalids (map check_con data_cons) - check_con :: DataCon -> Maybe SDoc + check_con :: DataCon -> Validity check_con con | not (isVanillaDataCon con) - = Just (badCon con (ptext (sLit "has existentials or constraints in its type"))) + = NotValid (badCon con (ptext (sLit "has existentials or constraints in its type"))) | not (permissive || all isTauTy (dataConOrigArgTys con)) - = Just (badCon con (ptext (sLit "has a higher-rank type"))) + = NotValid (badCon con (ptext (sLit "has a higher-rank type"))) | otherwise - = Nothing + = IsValid no_cons_why :: TyCon -> SDoc no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> @@ -1337,9 +1360,9 @@ cond_args :: Class -> Condition -- by generating specialised code. For others (eg Data) we don't. cond_args cls (_, tc, _) = case bad_args of - [] -> Nothing - (ty:_) -> Just (hang (ptext (sLit "Don't know how to derive") <+> quotes (ppr cls)) - 2 (ptext (sLit "for type") <+> quotes (ppr ty))) + [] -> IsValid + (ty:_) -> NotValid (hang (ptext (sLit "Don't know how to derive") <+> quotes (ppr cls)) + 2 (ptext (sLit "for type") <+> quotes (ppr ty))) where bad_args = [ arg_ty | con <- tyConDataCons tc , arg_ty <- dataConOrigArgTys con @@ -1359,8 +1382,8 @@ cond_args cls (_, tc, _) cond_isEnumeration :: Condition cond_isEnumeration (_, rep_tc, _) - | isEnumerationTyCon rep_tc = Nothing - | otherwise = Just why + | isEnumerationTyCon rep_tc = IsValid + | otherwise = NotValid why where why = sep [ quotes (pprSourceTyCon rep_tc) <+> ptext (sLit "must be an enumeration type") @@ -1369,8 +1392,8 @@ cond_isEnumeration (_, rep_tc, _) cond_isProduct :: Condition cond_isProduct (_, rep_tc, _) - | isProductTyCon rep_tc = Nothing - | otherwise = Just why + | isProductTyCon rep_tc = IsValid + | otherwise = NotValid why where why = quotes (pprSourceTyCon rep_tc) <+> ptext (sLit "must have precisely one constructor") @@ -1380,10 +1403,10 @@ cond_oldTypeableOK :: Condition -- Currently: (a) args all of kind * -- (b) 7 or fewer args cond_oldTypeableOK (_, tc, _) - | tyConArity tc > 7 = Just too_many + | tyConArity tc > 7 = NotValid too_many | not (all (isSubOpenTypeKind . tyVarKind) (tyConTyVars tc)) - = Just bad_kind - | otherwise = Nothing + = NotValid bad_kind + | otherwise = IsValid where too_many = quotes (pprSourceTyCon tc) <+> ptext (sLit "must have 7 or fewer arguments") @@ -1402,15 +1425,15 @@ cond_functorOK :: Bool -> Condition -- (e) no "stupid context" on data type cond_functorOK allowFunctions (_, rep_tc, _) | null tc_tvs - = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) - <+> ptext (sLit "must have some type parameters")) + = NotValid (ptext (sLit "Data type") <+> quotes (ppr rep_tc) + <+> ptext (sLit "must have some type parameters")) | not (null bad_stupid_theta) - = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) - <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta) + = NotValid (ptext (sLit "Data type") <+> quotes (ppr rep_tc) + <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta) | otherwise - = msum (map check_con data_cons) -- msum picks the first 'Just', if any + = allValid (map check_con data_cons) where tc_tvs = tyConTyVars rep_tc Just (_, last_tv) = snocView tc_tvs @@ -1418,25 +1441,25 @@ cond_functorOK allowFunctions (_, rep_tc, _) is_bad pred = last_tv `elemVarSet` tyVarsOfType pred data_cons = tyConDataCons rep_tc - check_con con = msum (check_universal con : foldDataConArgs (ft_check con) con) + check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con) - check_universal :: DataCon -> Maybe SDoc + check_universal :: DataCon -> Validity check_universal con | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) , tv `elem` dataConUnivTyVars con , not (tv `elemVarSet` tyVarsOfTypes (dataConTheta con)) - = Nothing -- See Note [Check that the type variable is truly universal] + = IsValid -- See Note [Check that the type variable is truly universal] | otherwise - = Just (badCon con existential) - - ft_check :: DataCon -> FFoldType (Maybe SDoc) - ft_check con = FT { ft_triv = Nothing, ft_var = Nothing - , ft_co_var = Just (badCon con covariant) - , ft_fun = \x y -> if allowFunctions then x `mplus` y - else Just (badCon con functions) - , ft_tup = \_ xs -> msum xs + = NotValid (badCon con existential) + + ft_check :: DataCon -> FFoldType Validity + ft_check con = FT { ft_triv = IsValid, ft_var = IsValid + , ft_co_var = NotValid (badCon con covariant) + , ft_fun = \x y -> if allowFunctions then x `andValid` y + else NotValid (badCon con functions) + , ft_tup = \_ xs -> allValid xs , ft_ty_app = \_ x -> x - , ft_bad_app = Just (badCon con wrong_arg) + , ft_bad_app = NotValid (badCon con wrong_arg) , ft_forall = \_ x -> x } existential = ptext (sLit "must be truly polymorphic in the last argument of the data type") @@ -1446,8 +1469,8 @@ cond_functorOK allowFunctions (_, rep_tc, _) checkFlag :: ExtensionFlag -> Condition checkFlag flag (dflags, _, _) - | xopt flag dflags = Nothing - | otherwise = Just why + | xopt flag dflags = IsValid + | otherwise = NotValid why where why = ptext (sLit "You need ") <> text flag_str <+> ptext (sLit "to derive an instance for this class") @@ -1545,11 +1568,11 @@ a context for the Data instances: %************************************************************************ \begin{code} -mkNewTypeEqn :: DynFlags -> [Var] -> Class +mkNewTypeEqn :: DynFlags -> Maybe OverlapMode -> [Var] -> Class -> [Type] -> TyCon -> [Type] -> TyCon -> [Type] -> DerivContext -> TcRn EarlyDerivSpec -mkNewTypeEqn dflags tvs +mkNewTypeEqn dflags overlap_mode tvs cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ... | ASSERT( length cls_tys + 1 == classArity cls ) @@ -1564,6 +1587,7 @@ mkNewTypeEqn dflags tvs , ds_cls = cls, ds_tys = inst_tys , ds_tc = rep_tycon, ds_tc_args = rep_tc_args , ds_theta = theta + , ds_overlap = overlap_mode , ds_newtype = True } Nothing -> return $ InferTheta $ DS { ds_loc = loc @@ -1571,6 +1595,7 @@ mkNewTypeEqn dflags tvs , ds_cls = cls, ds_tys = inst_tys , ds_tc = rep_tycon, ds_tc_args = rep_tc_args , ds_theta = all_preds + , ds_overlap = overlap_mode , ds_newtype = True } | otherwise = case checkSideConditions dflags mtheta cls cls_tys rep_tycon rep_tc_args of @@ -1584,7 +1609,7 @@ mkNewTypeEqn dflags tvs | otherwise -> bale_out non_std where newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags - go_for_it = mk_data_eqn tvs cls tycon tc_args rep_tycon rep_tc_args mtheta + go_for_it = mk_data_eqn overlap_mode tvs cls tycon tc_args rep_tycon rep_tc_args mtheta bale_out msg = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg) non_std = nonStdErr cls @@ -2042,12 +2067,14 @@ the renamer. What a great hack! genInst :: Bool -- True <=> standalone deriving -> OverlapFlag -> CommonAuxiliaries - -> DerivSpec ThetaType -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name) -genInst standalone_deriv oflag comauxs + -> DerivSpec ThetaType + -> TcM (InstInfo RdrName, BagDerivStuff, Maybe Name) +genInst standalone_deriv default_oflag comauxs spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon, ds_tc_args = rep_tc_args , ds_theta = theta, ds_newtype = is_newtype, ds_tys = tys - , ds_name = name, ds_cls = clas, ds_loc = loc }) - | is_newtype + , ds_overlap = overlap_mode + , ds_name = dfun_name, ds_cls = clas, ds_loc = loc }) + | is_newtype -- See Note [Bindings for Generalised Newtype Deriving] = do { inst_spec <- mkInstance oflag theta spec ; traceTc "genInst/is_newtype" (vcat [ppr loc, ppr clas, ppr tvs, ppr tys, ppr rhs_ty]) ; return ( InstInfo @@ -2063,9 +2090,8 @@ genInst standalone_deriv oflag comauxs -- See Note [Newtype deriving and unused constructors] | otherwise - = do { fix_env <- getFixityEnv - ; (meth_binds, deriv_stuff) <- genDerivStuff (getSrcSpan name) - fix_env clas name rep_tycon + = do { (meth_binds, deriv_stuff) <- genDerivStuff loc clas + dfun_name rep_tycon (lookup rep_tycon comauxs) ; inst_spec <- mkInstance oflag theta spec ; let inst_info = InstInfo { iSpec = inst_spec @@ -2076,52 +2102,49 @@ genInst standalone_deriv oflag comauxs , ib_standalone_deriving = standalone_deriv } } ; return ( inst_info, deriv_stuff, Nothing ) } where + oflag = setOverlapModeMaybe default_oflag overlap_mode rhs_ty = newTyConInstRhs rep_tycon rep_tc_args -genDerivStuff :: SrcSpan -> FixityEnv -> Class -> Name -> TyCon +genDerivStuff :: SrcSpan -> Class -> Name -> TyCon -> Maybe CommonAuxiliary -> TcM (LHsBinds RdrName, BagDerivStuff) -genDerivStuff loc fix_env clas name tycon comaux_maybe - | className clas `elem` oldTypeableClassNames - = do dflags <- getDynFlags - return (gen_old_Typeable_binds dflags loc tycon, emptyBag) - - | className clas == typeableClassName - = do dflags <- getDynFlags - return (gen_Typeable_binds dflags loc tycon, emptyBag) - - | ck `elem` [genClassKey, gen1ClassKey] -- Special case because monadic - = let gk = if ck == genClassKey then Gen0 else Gen1 -- TODO NSF: correctly identify when we're building Both instead of One +genDerivStuff loc clas dfun_name tycon comaux_maybe + | let ck = classKey clas + , ck `elem` [genClassKey, gen1ClassKey] -- Special case because monadic + = let gk = if ck == genClassKey then Gen0 else Gen1 + -- TODO NSF: correctly identify when we're building Both instead of One Just metaTyCons = comaux_maybe -- well-guarded by commonAuxiliaries and genInst in do - (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule name) + (binds, faminst) <- gen_Generic_binds gk tycon metaTyCons (nameModule dfun_name) return (binds, DerivFamInst faminst `consBag` emptyBag) | otherwise -- Non-monadic generators = do dflags <- getDynFlags - case assocMaybe (gen_list dflags) (getUnique clas) of - Just gen_fn -> return (gen_fn loc tycon) - Nothing -> pprPanic "genDerivStuff: bad derived class" (ppr clas) - where - ck = classKey clas - - gen_list :: DynFlags - -> [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))] - gen_list dflags - = [(eqClassKey, gen_Eq_binds) - ,(ordClassKey, gen_Ord_binds) - ,(enumClassKey, gen_Enum_binds) - ,(boundedClassKey, gen_Bounded_binds) - ,(ixClassKey, gen_Ix_binds) - ,(showClassKey, gen_Show_binds fix_env) - ,(readClassKey, gen_Read_binds fix_env) - ,(dataClassKey, gen_Data_binds dflags) - ,(functorClassKey, gen_Functor_binds) - ,(foldableClassKey, gen_Foldable_binds) - ,(traversableClassKey, gen_Traversable_binds) - ] + fix_env <- getFixityEnv + return (genDerivedBinds dflags fix_env clas loc tycon) \end{code} +Note [Bindings for Generalised Newtype Deriving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class Eq a => C a where + f :: a -> a + newtype N a = MkN [a] deriving( C ) + instance Eq (N a) where ... + +The 'deriving C' clause generates, in effect + instance (C [a], Eq a) => C (N a) where + f = coerce (f :: [a] -> [a]) + +This generates a cast for each method, but allows the superclasse to +be worked out in the usual way. In this case the superclass (Eq (N +a)) will be solved by the explicit Eq (N a) instance. We do *not* +create the superclasses by casting the superclass dictionaries for the +representation type. + +See the paper "Safe zero-cost coercions for Hsakell". + + %************************************************************************ %* * \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?} diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 6020797449..f4c7c10063 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -18,8 +18,8 @@ module TcEnv( tcExtendGlobalEnv, tcExtendGlobalEnvImplicit, setGlobalTypeEnv, tcExtendGlobalValEnv, tcLookupLocatedGlobal, tcLookupGlobal, - tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon, - tcLookupConLike, + tcLookupField, tcLookupTyCon, tcLookupClass, + tcLookupDataCon, tcLookupPatSyn, tcLookupConLike, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, tcLookupLocatedClass, tcLookupInstance, tcLookupAxiom, @@ -73,7 +73,8 @@ import Var import VarSet import RdrName import InstEnv -import DataCon +import DataCon ( DataCon ) +import PatSyn ( PatSyn ) import ConLike import TyCon import CoAxiom @@ -160,6 +161,13 @@ tcLookupDataCon name = do AConLike (RealDataCon con) -> return con _ -> wrongThingErr "data constructor" (AGlobal thing) name +tcLookupPatSyn :: Name -> TcM PatSyn +tcLookupPatSyn name = do + thing <- tcLookupGlobal name + case thing of + AConLike (PatSynCon ps) -> return ps + _ -> wrongThingErr "pattern synonym" (AGlobal thing) name + tcLookupConLike :: Name -> TcM ConLike tcLookupConLike name = do thing <- tcLookupGlobal name @@ -819,7 +827,7 @@ mkWrapperName what nameBase thisMod <- getModule let -- Note [Generating fresh names for ccall wrapper] wrapperRef = nextWrapperNum dflags - pkg = packageIdString (modulePackageId thisMod) + pkg = packageKeyString (modulePackageKey thisMod) mod = moduleNameString (moduleName thisMod) wrapperNum <- liftIO $ atomicModifyIORef wrapperRef $ \mod_env -> let num = lookupWithDefaultModuleEnv mod_env 0 thisMod diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 8fe97519e1..c8f3d06997 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -903,7 +903,7 @@ sameOccExtra ty1 ty2 , let n1 = tyConName tc1 n2 = tyConName tc2 same_occ = nameOccName n1 == nameOccName n2 - same_pkg = modulePackageId (nameModule n1) == modulePackageId (nameModule n2) + same_pkg = modulePackageKey (nameModule n1) == modulePackageKey (nameModule n2) , n1 /= n2 -- Different Names , same_occ -- but same OccName = ptext (sLit "NB:") <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) @@ -917,10 +917,10 @@ sameOccExtra ty1 ty2 | otherwise -- Imported things have an UnhelpfulSrcSpan = hang (quotes (ppr nm)) 2 (sep [ ptext (sLit "is defined in") <+> quotes (ppr (moduleName mod)) - , ppUnless (same_pkg || pkg == mainPackageId) $ + , ppUnless (same_pkg || pkg == mainPackageKey) $ nest 4 $ ptext (sLit "in package") <+> quotes (ppr pkg) ]) where - pkg = modulePackageId mod + pkg = modulePackageKey mod mod = nameModule nm loc = nameSrcSpan nm \end{code} diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 48c4cbfd87..7e6c495506 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -76,7 +76,7 @@ import qualified Data.Set as Set \begin{code} tcPolyExpr, tcPolyExprNC :: LHsExpr Name -- Expression to type check - -> TcSigmaType -- Expected type (could be a polytpye) + -> TcSigmaType -- Expected type (could be a polytype) -> TcM (LHsExpr TcId) -- Generalised expr with expected type -- tcPolyExpr is a convenient place (frequent but not too frequent) @@ -202,7 +202,7 @@ tcExpr (HsIPVar x) res_ty ; ip_var <- emitWanted origin (mkClassPred ipClass [ip_name, ip_ty]) ; tcWrapResult (fromDict ipClass ip_name ip_ty (HsVar ip_var)) ip_ty res_ty } where - -- Coerces a dictionry for `IP "x" t` into `t`. + -- Coerces a dictionary for `IP "x" t` into `t`. fromDict ipClass x ty = case unwrapNewTyCon_maybe (classTyCon ipClass) of Just (_,_,ax) -> HsWrap $ mkWpCast $ mkTcUnbranchedAxInstCo Representational ax [x,ty] @@ -565,7 +565,7 @@ Note that because MkT3 doesn't contain all the fields being updated, its RHS is simply an error, so it doesn't impose any type constraints. Hence the use of 'relevant_cont'. -Note [Implict type sharing] +Note [Implicit type sharing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ We also take into account any "implicit" non-update fields. For example data T a b where { MkT { f::a } :: T a a; ... } @@ -751,7 +751,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty -- Universally-quantified tyvars that -- appear in any of the *implicit* -- arguments to the constructor are fixed - -- See Note [Implict type sharing] + -- See Note [Implicit type sharing] fixed_tys = [ty | (fld,ty) <- zip flds arg_tys , not (fld `elem` upd_fld_names)] @@ -807,7 +807,7 @@ tcExpr (PArrSeq _ _) _ \begin{code} tcExpr (HsSpliceE is_ty splice) res_ty - = ASSERT( is_ty ) -- Untyped splices are expanced by the renamer + = ASSERT( is_ty ) -- Untyped splices are expanded by the renamer tcSpliceExpr splice res_ty tcExpr (HsBracket brack) res_ty = tcTypedBracket brack res_ty @@ -966,7 +966,7 @@ tcInferFun fun -- Zonk the function type carefully, to expose any polymorphism -- E.g. (( \(x::forall a. a->a). blah ) e) - -- We can see the rank-2 type of the lambda in time to genrealise e + -- We can see the rank-2 type of the lambda in time to generalise e ; fun_ty' <- zonkTcType fun_ty ; (wrap, rho) <- deeplyInstantiate AppOrigin fun_ty' diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 8370e0aa06..303391fcdd 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -250,7 +250,7 @@ tcFImport (L dloc fo@(ForeignImport (L nloc nm) hs_ty _ imp_decl)) -- things are LocalIds. However, it does not need zonking, -- (so TcHsSyn.zonkForeignExports ignores it). - ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl + ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl -- Can't use sig_ty here because sig_ty :: Type and -- we need HsType Id hence the undefined ; let fi_decl = ForeignImport (L nloc id) undefined (mkSymCo norm_co) imp_decl' @@ -261,18 +261,18 @@ tcFImport d = pprPanic "tcFImport" (ppr d) ------------ Checking types for foreign import ---------------------- \begin{code} -tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport +tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport -tcCheckFIType sig_ty arg_tys res_ty (CImport cconv safety mh l@(CLabel _)) +tcCheckFIType arg_tys res_ty (CImport cconv safety mh l@(CLabel _)) -- Foreign import label = do checkCg checkCOrAsmOrLlvmOrInterp -- NB check res_ty not sig_ty! -- In case sig_ty is (forall a. ForeignPtr a) - check (null arg_tys && isFFILabelTy res_ty) (illegalForeignLabelErr sig_ty) + check (isFFILabelTy (mkFunTys arg_tys res_ty)) (illegalForeignTyErr empty) cconv' <- checkCConv cconv return (CImport cconv' safety mh l) -tcCheckFIType sig_ty arg_tys res_ty (CImport cconv safety mh CWrapper) = do +tcCheckFIType arg_tys res_ty (CImport cconv safety mh CWrapper) = do -- Foreign wrapper (former f.e.d.) -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid -- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too. @@ -285,32 +285,32 @@ tcCheckFIType sig_ty arg_tys res_ty (CImport cconv safety mh CWrapper) = do checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty - _ -> addErrTc (illegalForeignTyErr empty sig_ty) + _ -> addErrTc (illegalForeignTyErr empty (ptext (sLit "One argument expected"))) return (CImport cconv' safety mh CWrapper) -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction target)) +tcCheckFIType arg_tys res_ty idecl@(CImport cconv safety mh (CFunction target)) | isDynamicTarget target = do -- Foreign import dynamic checkCg checkCOrAsmOrLlvmOrInterp cconv' <- checkCConv cconv case arg_tys of -- The first arg must be Ptr or FunPtr - [] -> do - check False (illegalForeignTyErr empty sig_ty) + [] -> + addErrTc (illegalForeignTyErr empty (ptext (sLit "At least one argument expected"))) (arg1_ty:arg_tys) -> do dflags <- getDynFlags let curried_res_ty = foldr FunTy res_ty arg_tys check (isFFIDynTy curried_res_ty arg1_ty) - (illegalForeignTyErr argument arg1_ty) + (illegalForeignTyErr argument) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty return $ CImport cconv' safety mh (CFunction target) | cconv == PrimCallConv = do dflags <- getDynFlags - check (xopt Opt_GHCForeignImportPrim dflags) - (text "Use GHCForeignImportPrim to allow `foreign import prim'.") + checkTc (xopt Opt_GHCForeignImportPrim dflags) + (text "Use GHCForeignImportPrim to allow `foreign import prim'.") checkCg checkCOrAsmOrLlvmOrInterp checkCTarget target - check (playSafe safety) - (text "The safe/unsafe annotation should not be used with `foreign import prim'.") + checkTc (playSafe safety) + (text "The safe/unsafe annotation should not be used with `foreign import prim'.") checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys -- prim import result is more liberal, allows (#,,#) checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty @@ -336,7 +336,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction ta checkCTarget :: CCallTarget -> TcM () checkCTarget (StaticTarget str _ _) = do checkCg checkCOrAsmOrLlvmOrInterp - check (isCLabelString str) (badCName str) + checkTc (isCLabelString str) (badCName str) checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" @@ -404,7 +404,7 @@ tcFExport d = pprPanic "tcFExport" (ppr d) tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do checkCg checkCOrAsmOrLlvm - check (isCLabelString str) (badCName str) + checkTc (isCLabelString str) (badCName str) cconv' <- checkCConv cconv checkForeignArgs isFFIExternalTy arg_tys checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty @@ -426,9 +426,10 @@ tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do \begin{code} ------------ Checking argument types for foreign import ---------------------- -checkForeignArgs :: (Type -> Bool) -> [Type] -> TcM () +checkForeignArgs :: (Type -> Validity) -> [Type] -> TcM () checkForeignArgs pred tys = mapM_ go tys - where go ty = check (pred ty) (illegalForeignTyErr argument ty) + where + go ty = check (pred ty) (illegalForeignTyErr argument) ------------ Checking result types for foreign calls ---------------------- -- | Check that the type has the form @@ -439,32 +440,34 @@ checkForeignArgs pred tys = mapM_ go tys -- We also check that the Safe Haskell condition of FFI imports having -- results in the IO monad holds. -- -checkForeignRes :: Bool -> Bool -> (Type -> Bool) -> Type -> TcM () +checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM () checkForeignRes non_io_result_ok check_safe pred_res_ty ty - = case tcSplitIOType_maybe ty of - -- Got an IO result type, that's always fine! - Just (_, res_ty) | pred_res_ty res_ty -> return () - - -- Case for non-IO result type with FFI Import - _ -> do - dflags <- getDynFlags - case (pred_res_ty ty && non_io_result_ok) of - -- handle normal typecheck fail, we want to handle this first and - -- only report safe haskell errors if the normal type check is OK. - False -> addErrTc $ illegalForeignTyErr result ty + | Just (_, res_ty) <- tcSplitIOType_maybe ty + = -- Got an IO result type, that's always fine! + check (pred_res_ty res_ty) (illegalForeignTyErr result) - -- handle safe infer fail - _ | check_safe && safeInferOn dflags - -> recordUnsafeInfer + -- Case for non-IO result type with FFI Import + | not non_io_result_ok + = addErrTc $ illegalForeignTyErr result (ptext (sLit "IO result type expected")) + + | otherwise + = do { dflags <- getDynFlags + ; case pred_res_ty ty of + -- Handle normal typecheck fail, we want to handle this first and + -- only report safe haskell errors if the normal type check is OK. + NotValid msg -> addErrTc $ illegalForeignTyErr result msg - -- handle safe language typecheck fail - _ | check_safe && safeLanguageOn dflags - -> addErrTc $ illegalForeignTyErr result ty $+$ safeHsErr + -- handle safe infer fail + _ | check_safe && safeInferOn dflags + -> recordUnsafeInfer - -- sucess! non-IO return is fine - _ -> return () + -- handle safe language typecheck fail + _ | check_safe && safeLanguageOn dflags + -> addErrTc (illegalForeignTyErr result safeHsErr) - where + -- sucess! non-IO return is fine + _ -> return () } + where safeHsErr = ptext $ sLit "Safe Haskell is on, all FFI imports must be in the IO monad" nonIOok, mustBeIO :: Bool @@ -479,22 +482,22 @@ noCheckSafe = False Checking a supported backend is in use \begin{code} -checkCOrAsmOrLlvm :: HscTarget -> Maybe SDoc -checkCOrAsmOrLlvm HscC = Nothing -checkCOrAsmOrLlvm HscAsm = Nothing -checkCOrAsmOrLlvm HscLlvm = Nothing +checkCOrAsmOrLlvm :: HscTarget -> Validity +checkCOrAsmOrLlvm HscC = IsValid +checkCOrAsmOrLlvm HscAsm = IsValid +checkCOrAsmOrLlvm HscLlvm = IsValid checkCOrAsmOrLlvm _ - = Just (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)") + = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)") -checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc -checkCOrAsmOrLlvmOrInterp HscC = Nothing -checkCOrAsmOrLlvmOrInterp HscAsm = Nothing -checkCOrAsmOrLlvmOrInterp HscLlvm = Nothing -checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing +checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity +checkCOrAsmOrLlvmOrInterp HscC = IsValid +checkCOrAsmOrLlvmOrInterp HscAsm = IsValid +checkCOrAsmOrLlvmOrInterp HscLlvm = IsValid +checkCOrAsmOrLlvmOrInterp HscInterpreted = IsValid checkCOrAsmOrLlvmOrInterp _ - = Just (text "requires interpreted, unregisterised, llvm or native code generation") + = NotValid (text "requires interpreted, unregisterised, llvm or native code generation") -checkCg :: (HscTarget -> Maybe SDoc) -> TcM () +checkCg :: (HscTarget -> Validity) -> TcM () checkCg check = do dflags <- getDynFlags let target = hscTarget dflags @@ -502,8 +505,8 @@ checkCg check = do HscNothing -> return () _ -> case check target of - Nothing -> return () - Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) + IsValid -> return () + NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err) \end{code} Calling conventions @@ -532,20 +535,16 @@ checkCConv JavaScriptCallConv = do dflags <- getDynFlags Warnings \begin{code} -check :: Bool -> MsgDoc -> TcM () -check True _ = return () -check _ the_err = addErrTc the_err - -illegalForeignLabelErr :: Type -> SDoc -illegalForeignLabelErr ty - = vcat [ illegalForeignTyErr empty ty - , ptext (sLit "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)") ] - -illegalForeignTyErr :: SDoc -> Type -> SDoc -illegalForeignTyErr arg_or_res ty - = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res, - ptext (sLit "type in foreign declaration:")]) - 2 (hsep [ppr ty]) +check :: Validity -> (MsgDoc -> MsgDoc) -> TcM () +check IsValid _ = return () +check (NotValid doc) err_fn = addErrTc (err_fn doc) + +illegalForeignTyErr :: SDoc -> SDoc -> SDoc +illegalForeignTyErr arg_or_res extra + = hang msg 2 extra + where + msg = hsep [ ptext (sLit "Unacceptable"), arg_or_res + , ptext (sLit "type in foreign declaration:")] -- Used for 'arg_or_res' argument to illegalForeignTyErr argument, result :: SDoc diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 960e3faaa3..2967630da1 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -16,20 +16,9 @@ This is where we do all the grimy bindings' generation. module TcGenDeriv ( BagDerivStuff, DerivStuff(..), - gen_Bounded_binds, - gen_Enum_binds, - gen_Eq_binds, - gen_Ix_binds, - gen_Ord_binds, - gen_Read_binds, - gen_Show_binds, - gen_Data_binds, - gen_old_Typeable_binds, gen_Typeable_binds, - gen_Functor_binds, + genDerivedBinds, FFoldType(..), functorLikeTraverse, deepSubtypesContaining, foldDataConArgs, - gen_Foldable_binds, - gen_Traversable_binds, mkCoerceClassMethEqn, gen_Newtype_binds, genAuxBinds, @@ -75,6 +64,7 @@ import Bag import Fingerprint import TcEnv (InstInfo) +import ListSetOps( assocMaybe ) import Data.List ( partition, intersperse ) \end{code} @@ -101,6 +91,39 @@ data DerivStuff -- Please add this auxiliary stuff | DerivInst (InstInfo RdrName) -- New, auxiliary instances \end{code} +%************************************************************************ +%* * + Top level function +%* * +%************************************************************************ + +\begin{code} +genDerivedBinds :: DynFlags -> FixityEnv -> Class -> SrcSpan -> TyCon + -> (LHsBinds RdrName, BagDerivStuff) +genDerivedBinds dflags fix_env clas loc tycon + | className clas `elem` oldTypeableClassNames + = gen_old_Typeable_binds dflags loc tycon + + | Just gen_fn <- assocMaybe gen_list (getUnique clas) + = gen_fn loc tycon + + | otherwise + = pprPanic "genDerivStuff: bad derived class" (ppr clas) + where + gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))] + gen_list = [ (eqClassKey, gen_Eq_binds) + , (typeableClassKey, gen_Typeable_binds dflags) + , (ordClassKey, gen_Ord_binds) + , (enumClassKey, gen_Enum_binds) + , (boundedClassKey, gen_Bounded_binds) + , (ixClassKey, gen_Ix_binds) + , (showClassKey, gen_Show_binds fix_env) + , (readClassKey, gen_Read_binds fix_env) + , (dataClassKey, gen_Data_binds dflags) + , (functorClassKey, gen_Functor_binds) + , (foldableClassKey, gen_Foldable_binds) + , (traversableClassKey, gen_Traversable_binds) ] +\end{code} %************************************************************************ %* * @@ -1210,20 +1233,22 @@ we generate We are passed the Typeable2 class as well as T \begin{code} -gen_old_Typeable_binds :: DynFlags -> SrcSpan -> TyCon -> LHsBinds RdrName +gen_old_Typeable_binds :: DynFlags -> SrcSpan -> TyCon + -> (LHsBinds RdrName, BagDerivStuff) gen_old_Typeable_binds dflags loc tycon - = unitBag $ + = ( unitBag $ mk_easy_FunBind loc (old_mk_typeOf_RDR tycon) -- Name of appropriate type0f function [nlWildPat] (nlHsApps oldMkTyConApp_RDR [tycon_rep, nlList []]) + , emptyBag ) where tycon_name = tyConName tycon modl = nameModule tycon_name - pkg = modulePackageId modl + pkg = modulePackageKey modl modl_fs = moduleNameFS (moduleName modl) - pkg_fs = packageIdFS pkg + pkg_fs = packageKeyFS pkg name_fs = occNameFS (nameOccName tycon_name) tycon_rep = nlHsApps oldMkTyCon_RDR @@ -1270,17 +1295,19 @@ we generate We are passed the Typeable2 class as well as T \begin{code} -gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon -> LHsBinds RdrName +gen_Typeable_binds :: DynFlags -> SrcSpan -> TyCon + -> (LHsBinds RdrName, BagDerivStuff) gen_Typeable_binds dflags loc tycon - = unitBag $ mk_easy_FunBind loc typeRep_RDR [nlWildPat] - (nlHsApps mkTyConApp_RDR [tycon_rep, nlList []]) + = ( unitBag $ mk_easy_FunBind loc typeRep_RDR [nlWildPat] + (nlHsApps mkTyConApp_RDR [tycon_rep, nlList []]) + , emptyBag ) where tycon_name = tyConName tycon modl = nameModule tycon_name - pkg = modulePackageId modl + pkg = modulePackageKey modl modl_fs = moduleNameFS (moduleName modl) - pkg_fs = packageIdFS pkg + pkg_fs = packageKeyFS pkg name_fs = occNameFS (nameOccName tycon_name) tycon_rep = nlHsApps mkTyCon_RDR diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index 8b7243048f..f2601beff2 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -37,6 +37,7 @@ import TcEnv import MkId import TcRnMonad import HscTypes +import ErrUtils( Validity(..), andValid ) import BuildTyCl import SrcLoc import Bag @@ -125,11 +126,11 @@ metaTyConsToDerivStuff tc metaDts = fix_env <- getFixityEnv let - safeOverlap = safeLanguageOn dflags (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc mk_inst clas ty dfun_name = mkLocalInstance (mkDictFunId dfun_name [] [] clas tys) - (NoOverlap safeOverlap) + OverlapFlag { overlapMode = NoOverlap + , isSafeOverlap = safeLanguageOn dflags } [] clas tys where tys = [ty] @@ -238,7 +239,7 @@ following constraints are satisfied. -} -canDoGenerics :: TyCon -> [Type] -> Maybe SDoc +canDoGenerics :: TyCon -> [Type] -> Validity -- canDoGenerics rep_tc tc_args determines if Generic/Rep can be derived for a -- type expression (rep_tc tc_arg0 tc_arg1 ... tc_argn). -- @@ -250,17 +251,17 @@ canDoGenerics tc tc_args = mergeErrors ( -- Check (c) from Note [Requirements for deriving Generic and Rep]. (if (not (null (tyConStupidTheta tc))) - then (Just (tc_name <+> text "must not have a datatype context")) - else Nothing) : + then (NotValid (tc_name <+> text "must not have a datatype context")) + else IsValid) : -- Check (a) from Note [Requirements for deriving Generic and Rep]. -- -- Data family indices can be instantiated; the `tc_args` here are -- the representation tycon args (if (all isTyVarTy (filterOut isKind tc_args)) - then Nothing - else Just (tc_name <+> text "must not be instantiated;" <+> - text "try deriving `" <> tc_name <+> tc_tys <> - text "' instead")) + then IsValid + else NotValid (tc_name <+> text "must not be instantiated;" <+> + text "try deriving `" <> tc_name <+> tc_tys <> + text "' instead")) -- See comment below : (map bad_con (tyConDataCons tc))) where @@ -278,28 +279,28 @@ canDoGenerics tc tc_args -- it relies on instantiating *polymorphic* sum and product types -- at the argument types of the constructors bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc)) - then (Just (ppr dc <+> text "must not have unlifted or polymorphic arguments")) + then (NotValid (ppr dc <+> text "must not have unlifted or polymorphic arguments")) else (if (not (isVanillaDataCon dc)) - then (Just (ppr dc <+> text "must be a vanilla data constructor")) - else Nothing) + then (NotValid (ppr dc <+> text "must be a vanilla data constructor")) + else IsValid) -- Nor can we do the job if it's an existential data constructor, -- Nor if the args are polymorphic types (I don't think) bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty) -mergeErrors :: [Maybe SDoc] -> Maybe SDoc -mergeErrors [] = Nothing -mergeErrors ((Just s):t) = case mergeErrors t of - Nothing -> Just s - Just s' -> Just (s <> text ", and" $$ s') -mergeErrors (Nothing :t) = mergeErrors t +mergeErrors :: [Validity] -> Validity +mergeErrors [] = IsValid +mergeErrors (NotValid s:t) = case mergeErrors t of + IsValid -> NotValid s + NotValid s' -> NotValid (s <> text ", and" $$ s') +mergeErrors (IsValid : t) = mergeErrors t -- A datatype used only inside of canDoGenerics1. It's the result of analysing -- a type term. data Check_for_CanDoGenerics1 = CCDG1 { _ccdg1_hasParam :: Bool -- does the parameter of interest occurs in -- this type? - , _ccdg1_errors :: Maybe SDoc -- errors generated by this type + , _ccdg1_errors :: Validity -- errors generated by this type } {- @@ -334,13 +335,13 @@ explicitly, even though foldDataConArgs is also doing this internally. -- are taken care of by the call to canDoGenerics. -- -- It returns Nothing if deriving is possible. It returns (Just reason) if not. -canDoGenerics1 :: TyCon -> [Type] -> Maybe SDoc +canDoGenerics1 :: TyCon -> [Type] -> Validity canDoGenerics1 rep_tc tc_args = - canDoGenerics rep_tc tc_args `mplus` additionalChecks + canDoGenerics rep_tc tc_args `andValid` additionalChecks where additionalChecks -- check (f) from Note [Requirements for deriving Generic and Rep] - | null (tyConTyVars rep_tc) = Just $ + | null (tyConTyVars rep_tc) = NotValid $ ptext (sLit "Data type") <+> quotes (ppr rep_tc) <+> ptext (sLit "must have some type parameters") @@ -348,19 +349,19 @@ canDoGenerics1 rep_tc tc_args = data_cons = tyConDataCons rep_tc check_con con = case check_vanilla con of - j@(Just _) -> [j] - Nothing -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con + j@(NotValid {}) -> [j] + IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con bad :: DataCon -> SDoc -> SDoc bad con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg - check_vanilla :: DataCon -> Maybe SDoc - check_vanilla con | isVanillaDataCon con = Nothing - | otherwise = Just (bad con existential) + check_vanilla :: DataCon -> Validity + check_vanilla con | isVanillaDataCon con = IsValid + | otherwise = NotValid (bad con existential) - bmzero = CCDG1 False Nothing - bmbad con s = CCDG1 True $ Just $ bad con s - bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (mplus m1 m2) + bmzero = CCDG1 False IsValid + bmbad con s = CCDG1 True $ NotValid $ bad con s + bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2) -- check (g) from Note [degenerate use of FFoldType] ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1 @@ -388,7 +389,7 @@ canDoGenerics1 rep_tc tc_args = , ft_forall = \_ body -> body -- polytypes are handled elsewhere } where - caseVar = CCDG1 True Nothing + caseVar = CCDG1 True IsValid existential = text "must not have existential arguments" @@ -653,7 +654,7 @@ tc_mkRepTy gk_ tycon metaDts = -- Meta-information -------------------------------------------------------------------------------- -data MetaTyCons = MetaTyCons { -- One meta datatype per dataype +data MetaTyCons = MetaTyCons { -- One meta datatype per datatype metaD :: Type -- One meta datatype per constructor , metaC :: [Type] diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index f90cfca317..f4d5cf262c 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -468,18 +468,19 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs , abe_mono = zonkIdOcc env mono_id , abe_prags = new_prags }) -zonk_bind env _sig_warn bind@(PatSynBind { patsyn_id = L loc id - , patsyn_args = details - , patsyn_def = lpat - , patsyn_dir = dir }) +zonk_bind env _sig_warn (PatSynBind bind@(PSB { psb_id = L loc id + , psb_args = details + , psb_def = lpat + , psb_dir = dir })) = do { id' <- zonkIdBndr env id ; details' <- zonkPatSynDetails env details ;(env1, lpat') <- zonkPat env lpat ; (_env2, dir') <- zonkPatSynDir env1 dir - ; return (bind { patsyn_id = L loc id' - , patsyn_args = details' - , patsyn_def = lpat' - , patsyn_dir = dir' }) } + ; return $ PatSynBind $ + bind { psb_id = L loc id' + , psb_args = details' + , psb_def = lpat' + , psb_dir = dir' } } zonkPatSynDetails :: ZonkEnv -> HsPatSynDetails (Located TcId) @@ -489,6 +490,9 @@ zonkPatSynDetails env = traverse (wrapLocM $ zonkIdBndr env) zonkPatSynDir :: ZonkEnv -> HsPatSynDir TcId -> TcM (ZonkEnv, HsPatSynDir Id) zonkPatSynDir env Unidirectional = return (env, Unidirectional) zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional) +zonkPatSynDir env (ExplicitBidirectional mg) = do + mg' <- zonkMatchGroup env zonkLExpr mg + return (env, ExplicitBidirectional mg') zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index eb3dd32997..cdeb191489 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -76,7 +76,7 @@ import Util import Data.Maybe( isNothing ) import Control.Monad ( unless, when, zipWithM ) -import PrelNames( ipClassName, funTyConKey ) +import PrelNames( ipClassName, funTyConKey, allNameStrings ) \end{code} @@ -1307,6 +1307,11 @@ tcTyClTyVars tycon (HsQTvs { hsq_kvs = hs_kvs, hsq_tvs = hs_tvs }) thing_inside ; tvs <- zipWithM tc_hs_tv hs_tvs kinds ; tcExtendTyVarEnv tvs (thing_inside (kvs ++ tvs) res) } where + -- In the case of associated types, the renamer has + -- ensured that the names are in commmon + -- e.g. class C a_29 where + -- type T b_30 a_29 :: * + -- Here the a_29 is shared tc_hs_tv (L _ (UserTyVar n)) kind = return (mkTyVar n kind) tc_hs_tv (L _ (KindedTyVar n hs_k)) kind = do { tc_kind <- tcLHsKind hs_k ; checkKind kind tc_kind @@ -1325,7 +1330,7 @@ tcDataKindSig kind ; us <- newUniqueSupply ; rdr_env <- getLocalRdrEnv ; let uniqs = uniqsFromSupply us - occs = [ occ | str <- strs + occs = [ occ | str <- allNameStrings , let occ = mkOccName tvName str , isNothing (lookupLocalRdrOcc rdr_env occ) ] -- Note [Avoid name clashes for associated data types] @@ -1337,9 +1342,6 @@ tcDataKindSig kind mk_tv loc uniq occ kind = mkTyVar (mkInternalName uniq occ loc) kind - strs :: [String] - strs = [ c:cs | cs <- "" : strs, c <- ['a'..'z'] ] - badKindSig :: Kind -> SDoc badKindSig kind = hang (ptext (sLit "Kind signature on data type declaration has non-* return kind")) diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 7fa83cc344..2b123ffab6 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -38,7 +38,7 @@ import TcDeriv import TcEnv import TcHsType import TcUnify -import Coercion ( pprCoAxiom, pprCoAxBranch ) +import Coercion ( pprCoAxiom ) import MkCore ( nO_METHOD_BINDING_ERROR_ID ) import Type import TcEvidence @@ -51,8 +51,8 @@ import VarEnv import VarSet import CoreUnfold ( mkDFunUnfolding ) import CoreSyn ( Expr(Var, Type), CoreExpr, mkTyApps, mkVarApps ) -import PrelNames ( tYPEABLE_INTERNAL, typeableClassName, oldTypeableClassNames ) - +import PrelNames ( tYPEABLE_INTERNAL, typeableClassName, + oldTypeableClassNames, genericClassNames ) import Bag import BasicTypes import DynFlags @@ -70,6 +70,7 @@ import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) import Control.Monad import Maybes ( isNothing, isJust, whenIsJust ) +import Data.List ( mapAccumL ) \end{code} Typechecking instance declarations is done in two passes. The first @@ -414,13 +415,17 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- hand written instances of old Typeable as then unsafe casts could be -- performed. Derived instances are OK. ; dflags <- getDynFlags - ; when (safeLanguageOn dflags) $ - mapM_ (\x -> when (typInstCheck x) - (addErrAt (getSrcSpan $ iSpec x) typInstErr)) - local_infos + ; when (safeLanguageOn dflags) $ forM_ local_infos $ \x -> case x of + _ | typInstCheck x -> addErrAt (getSrcSpan $ iSpec x) (typInstErr x) + _ | genInstCheck x -> addErrAt (getSrcSpan $ iSpec x) (genInstErr x) + _ -> return () + -- As above but for Safe Inference mode. - ; when (safeInferOn dflags) $ - mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_infos + ; when (safeInferOn dflags) $ forM_ local_infos $ \x -> case x of + _ | typInstCheck x -> recordUnsafeInfer + _ | genInstCheck x -> recordUnsafeInfer + _ | overlapCheck x -> recordUnsafeInfer + _ -> return () ; return ( gbl_env , bagToList deriv_inst_info ++ local_infos @@ -441,8 +446,18 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls else (typeableInsts, i:otherInsts) typInstCheck ty = is_cls_nm (iSpec ty) `elem` oldTypeableClassNames - typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe" - ++ " Haskell! Can only derive them" + typInstErr i = hang (ptext (sLit $ "Typeable instances can only be " + ++ "derived in Safe Haskell.") $+$ + ptext (sLit "Replace the following instance:")) + 2 (pprInstanceHdr (iSpec i)) + + overlapCheck ty = overlapMode (is_flag $ iSpec ty) `elem` + [Overlappable, Overlapping, Overlaps] + genInstCheck ty = is_cls_nm (iSpec ty) `elem` genericClassNames + genInstErr i = hang (ptext (sLit $ "Generic instances can only be " + ++ "derived in Safe Haskell.") $+$ + ptext (sLit "Replace the following instance:")) + 2 (pprInstanceHdr (iSpec i)) instMsg i = hang (ptext (sLit $ "Typeable instances can only be derived; replace " ++ "the following instance:")) @@ -506,6 +521,7 @@ tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) tcClsInstDecl :: LClsInstDecl Name -> TcM ([InstInfo Name], [FamInst]) tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds , cid_sigs = uprags, cid_tyfam_insts = ats + , cid_overlap_mode = overlap_mode , cid_datafam_insts = adts })) = setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ @@ -527,47 +543,20 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds -- Check for missing associated types and build them -- from their defaults (if available) - ; let defined_ats = mkNameSet $ map (tyFamInstDeclName . unLoc) ats - defined_adts = mkNameSet $ map (unLoc . dfid_tycon . unLoc) adts - - mk_deflt_at_instances :: ClassATItem -> TcM [FamInst] - mk_deflt_at_instances (fam_tc, defs) - -- User supplied instances ==> everything is OK - | tyConName fam_tc `elemNameSet` defined_ats - || tyConName fam_tc `elemNameSet` defined_adts - = return [] - - -- No defaults ==> generate a warning - | null defs - = do { warnMissingMethodOrAT "associated type" (tyConName fam_tc) - ; return [] } - - -- No user instance, have defaults ==> instatiate them - -- Example: class C a where { type F a b :: *; type F a b = () } - -- instance C [x] - -- Then we want to generate the decl: type F [x] b = () - | otherwise - = forM defs $ \br@(CoAxBranch { cab_lhs = pat_tys, cab_rhs = rhs }) -> - do { let pat_tys' = substTys mini_subst pat_tys - rhs' = substTy mini_subst rhs - tv_set' = tyVarsOfTypes pat_tys' - tvs' = varSetElemsKvsFirst tv_set' - ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys' - ; let axiom = mkSingleCoAxiom rep_tc_name tvs' fam_tc pat_tys' rhs' - ; traceTc "mk_deflt_at_instance" (vcat [ ppr (tyvars, theta, clas, inst_tys) - , pprCoAxBranch fam_tc br - , pprCoAxiom axiom ]) - ; ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) - newFamInst SynFamilyInst axiom } - - ; tyfam_insts1 <- mapM mk_deflt_at_instances (classATItems clas) + ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats) + `unionNameSets` + mkNameSet (map (unLoc . dfid_tycon . unLoc) adts) + ; tyfam_insts1 <- mapM (tcATDefault mini_subst defined_ats) + (classATItems clas) -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty) -- Dfun location is that of instance *header* - ; overlap_flag <- getOverlapFlag + ; overlap_flag <- + do defaultOverlapFlag <- getOverlapFlag + return $ setOverlapModeMaybe defaultOverlapFlag overlap_mode ; (subst, tyvars') <- tcInstSkolTyVars tyvars ; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys ispec = mkLocalInstance dfun overlap_flag tyvars' clas (substTys subst inst_tys) @@ -582,6 +571,48 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts) } + +tcATDefault :: TvSubst -> NameSet -> ClassATItem -> TcM [FamInst] +-- ^ Construct default instances for any associated types that +-- aren't given a user definition +-- Returns [] or singleton +tcATDefault inst_subst defined_ats (ATI fam_tc defs) + -- User supplied instances ==> everything is OK + | tyConName fam_tc `elemNameSet` defined_ats + = return [] + + -- No user instance, have defaults ==> instatiate them + -- Example: class C a where { type F a b :: *; type F a b = () } + -- instance C [x] + -- Then we want to generate the decl: type F [x] b = () + | Just rhs_ty <- defs + = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst + (tyConTyVars fam_tc) + rhs' = substTy subst' rhs_ty + tv_set' = tyVarsOfTypes pat_tys' + tvs' = varSetElemsKvsFirst tv_set' + ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys' + ; let axiom = mkSingleCoAxiom rep_tc_name tvs' fam_tc pat_tys' rhs' + ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty + , pprCoAxiom axiom ]) + ; fam_inst <- ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) + newFamInst SynFamilyInst axiom + ; return [fam_inst] } + + -- No defaults ==> generate a warning + | otherwise -- defs = Nothing + = do { warnMissingMethodOrAT "associated type" (tyConName fam_tc) + ; return [] } + where + subst_tv subst tc_tv + | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv + = (subst, ty) + | otherwise + = (extendTvSubst subst tc_tv ty', ty') + where + ty' = mkTyVarTy (updateTyVarKind (substTy subst) tc_tv) + + -------------- tcAssocTyDecl :: Class -- Class of associated type -> VarEnv Type -- Instantiation of class TyVars @@ -630,7 +661,7 @@ tcTyFamInstDecl :: Maybe (Class, VarEnv Type) -- the class & mini_env if applica tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) = setSrcSpan loc $ tcAddTyFamInstCtxt decl $ - do { let fam_lname = tfie_tycon (unLoc eqn) + do { let fam_lname = tfe_tycon (unLoc eqn) ; fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_lname -- (0) Check it's an open type family @@ -639,14 +670,13 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) ; checkTc (isOpenSynFamilyTyCon fam_tc) (notOpenFamily fam_tc) -- (1) do the work of verifying the synonym group - ; co_ax_branch <- tcSynFamInstDecl fam_tc decl + ; co_ax_branch <- tcTyFamInstEqn (famTyConShape fam_tc) eqn -- (2) check for validity ; checkValidTyFamInst mb_clsinfo fam_tc co_ax_branch -- (3) construct coercion axiom - ; rep_tc_name <- newFamInstAxiomName loc - (tyFamInstDeclName decl) + ; rep_tc_name <- newFamInstAxiomName loc (unLoc fam_lname) [co_ax_branch] ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch ; newFamInst SynFamilyInst axiom } @@ -669,7 +699,7 @@ tcDataFamInstDecl mb_clsinfo ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc) -- Kind check type patterns - ; tcFamTyPats (unLoc fam_tc_name) (tyConKind fam_tc) pats + ; tcFamTyPats (famTyConShape fam_tc) pats (kcDataDefn defn) $ \tvs' pats' res_kind -> do diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 42e04650c1..33249f4b04 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -753,12 +753,16 @@ kickOutRewritable :: CtEvidence -- Flavour of the equality that is -> InertCans -> TcS (Int, InertCans) kickOutRewritable new_ev new_tv - (IC { inert_eqs = tv_eqs - , inert_dicts = dictmap - , inert_funeqs = funeqmap - , inert_irreds = irreds - , inert_insols = insols - , inert_no_eqs = no_eqs }) + inert_cans@(IC { inert_eqs = tv_eqs + , inert_dicts = dictmap + , inert_funeqs = funeqmap + , inert_irreds = irreds + , inert_insols = insols + , inert_no_eqs = no_eqs }) + | new_tv `elemVarEnv` tv_eqs -- Fast path: there is at least one equality for tv + -- so kick-out will do nothing + = return (0, inert_cans) + | otherwise = do { traceTcS "kickOutRewritable" $ vcat [ text "tv = " <+> ppr new_tv , ptext (sLit "Kicked out =") <+> ppr kicked_out] @@ -1948,7 +1952,7 @@ getCoercibleInst loc ty1 ty2 = do ev_term <- deferTcSForAllEq Representational loc (tvs1,body1) (tvs2,body2) return $ GenInst [] ev_term - -- Coercible NT a (see case 4 in [Coercible Instances]) + -- Coercible NT a (see case 3 in [Coercible Instances]) | Just (tc,tyArgs) <- splitTyConApp_maybe ty1, Just (concTy, ntCo) <- instNewTyConTF_maybe famenv tc tyArgs, dataConsInScope rdr_env tc -- Do not look at all tyConsOfTyCon @@ -1960,7 +1964,19 @@ getCoercibleInst loc ty1 ty2 = do coercionToTcCoercion ntCo `mkTcTransCo` mkTcCoVarCo local_var return $ GenInst (freshGoals [ct_ev]) (EvCoercion tcCo) - -- Coercible (D ty1 ty2) (D ty1' ty2') (see case 2 in [Coercible Instances]) + -- Coercible a NT (see case 3 in [Coercible Instances]) + | Just (tc,tyArgs) <- splitTyConApp_maybe ty2, + Just (concTy, ntCo) <- instNewTyConTF_maybe famenv tc tyArgs, + dataConsInScope rdr_env tc -- Do not look at all tyConsOfTyCon + = do markDataConsAsUsed rdr_env tc + ct_ev <- requestCoercible loc ty1 concTy + local_var <- mkSysLocalM (fsLit "coev") $ mkCoerciblePred ty1 concTy + let binds = EvBinds (unitBag (EvBind local_var (getEvTerm ct_ev))) + tcCo = TcLetCo binds $ + mkTcCoVarCo local_var `mkTcTransCo` mkTcSymCo (coercionToTcCoercion ntCo) + return $ GenInst (freshGoals [ct_ev]) (EvCoercion tcCo) + + -- Coercible (D ty1 ty2) (D ty1' ty2') (see case 4 in [Coercible Instances]) | Just (tc1,tyArgs1) <- splitTyConApp_maybe ty1, Just (tc2,tyArgs2) <- splitTyConApp_maybe ty2, tc1 == tc2, @@ -1991,18 +2007,6 @@ getCoercibleInst loc ty1 ty2 = do tcCo = TcLetCo binds (mkTcTyConAppCo Representational tc1 arg_cos) return $ GenInst (catMaybes arg_new) (EvCoercion tcCo) - -- Coercible a NT (see case 3 in [Coercible Instances]) - | Just (tc,tyArgs) <- splitTyConApp_maybe ty2, - Just (concTy, ntCo) <- instNewTyConTF_maybe famenv tc tyArgs, - dataConsInScope rdr_env tc -- Do not look at all tyConsOfTyCon - = do markDataConsAsUsed rdr_env tc - ct_ev <- requestCoercible loc ty1 concTy - local_var <- mkSysLocalM (fsLit "coev") $ mkCoerciblePred ty1 concTy - let binds = EvBinds (unitBag (EvBind local_var (getEvTerm ct_ev))) - tcCo = TcLetCo binds $ - mkTcCoVarCo local_var `mkTcTransCo` mkTcSymCo (coercionToTcCoercion ntCo) - return $ GenInst (freshGoals [ct_ev]) (EvCoercion tcCo) - -- Cannot solve this one | otherwise = return NoInstance diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs index 82fa999f34..b5fbc295f5 100644 --- a/compiler/typecheck/TcPatSyn.lhs +++ b/compiler/typecheck/TcPatSyn.lhs @@ -7,7 +7,7 @@ \begin{code} {-# LANGUAGE CPP #-} -module TcPatSyn (tcPatSynDecl) where +module TcPatSyn (tcPatSynDecl, tcPatSynWrapper) where import HsSyn import TcPat @@ -40,12 +40,10 @@ import TypeRep \end{code} \begin{code} -tcPatSynDecl :: Located Name - -> HsPatSynDetails (Located Name) - -> LPat Name - -> HsPatSynDir Name +tcPatSynDecl :: PatSynBind Name Name -> TcM (PatSyn, LHsBinds Id) -tcPatSynDecl lname@(L _ name) details lpat dir +tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, + psb_def = lpat, psb_dir = dir } = do { traceTc "tcPatSynDecl {" $ ppr name $$ ppr lpat ; tcCheckPatSynPat lpat ; pat_ty <- newFlexiTyVarTy openTypeKind @@ -95,9 +93,10 @@ tcPatSynDecl lname@(L _ name) details lpat dir prov_dicts req_dicts prov_theta req_theta pat_ty - ; m_wrapper <- tcPatSynWrapper lname lpat dir args - univ_tvs ex_tvs theta pat_ty - ; let binds = matcher_bind `unionBags` maybe emptyBag snd m_wrapper + + ; wrapper_id <- if isBidirectional dir + then fmap Just $ mkPatSynWrapperId lname args univ_tvs ex_tvs theta pat_ty + else return Nothing ; traceTc "tcPatSynDecl }" $ ppr name ; let patSyn = mkPatSyn name is_infix @@ -105,8 +104,8 @@ tcPatSynDecl lname@(L _ name) details lpat dir univ_tvs ex_tvs prov_theta req_theta pat_ty - matcher_id (fmap fst m_wrapper) - ; return (patSyn, binds) } + matcher_id wrapper_id + ; return (patSyn, matcher_bind) } \end{code} @@ -188,33 +187,51 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d name <- newName . mkVarOccFS . fsLit $ s return $ mkLocalId name ty -tcPatSynWrapper :: Located Name - -> LPat Name - -> HsPatSynDir Name - -> [Var] - -> [TyVar] -> [TyVar] - -> ThetaType - -> TcType - -> TcM (Maybe (Id, LHsBinds Id)) +isBidirectional :: HsPatSynDir a -> Bool +isBidirectional Unidirectional = False +isBidirectional ImplicitBidirectional = True +isBidirectional ExplicitBidirectional{} = True + +tcPatSynWrapper :: PatSynBind Name Name + -> TcM (LHsBinds Id) -- See Note [Matchers and wrappers for pattern synonyms] in PatSyn -tcPatSynWrapper lname lpat dir args univ_tvs ex_tvs theta pat_ty - = do { let argNames = mkNameSet (map Var.varName args) - ; case (dir, tcPatToExpr argNames lpat) of - (Unidirectional, _) -> - return Nothing - (ImplicitBidirectional, Nothing) -> - cannotInvertPatSynErr lpat - (ImplicitBidirectional, Just lexpr) -> - fmap Just $ tc_pat_syn_wrapper_from_expr lname lexpr args univ_tvs ex_tvs theta pat_ty } - -tc_pat_syn_wrapper_from_expr :: Located Name - -> LHsExpr Name - -> [Var] - -> [TyVar] -> [TyVar] - -> ThetaType - -> Type - -> TcM (Id, LHsBinds Id) -tc_pat_syn_wrapper_from_expr (L loc name) lexpr args univ_tvs ex_tvs theta pat_ty +tcPatSynWrapper PSB{ psb_id = L loc name, psb_def = lpat, psb_dir = dir, psb_args = details } + = case dir of + Unidirectional -> return emptyBag + ImplicitBidirectional -> + do { wrapper_id <- tcLookupPatSynWrapper name + ; lexpr <- case tcPatToExpr (mkNameSet args) lpat of + Nothing -> cannotInvertPatSynErr lpat + Just lexpr -> return lexpr + ; let wrapper_args = map (noLoc . VarPat) args + wrapper_lname = L (getLoc lpat) (idName wrapper_id) + wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds + wrapper_bind = mkTopFunBind Generated wrapper_lname [wrapper_match] + ; mkPatSynWrapper wrapper_id wrapper_bind } + ExplicitBidirectional mg -> + do { wrapper_id <- tcLookupPatSynWrapper name + ; mkPatSynWrapper wrapper_id $ + FunBind{ fun_id = L loc (idName wrapper_id) + , fun_infix = False + , fun_matches = mg + , fun_co_fn = idHsWrapper + , bind_fvs = placeHolderNames + , fun_tick = Nothing }} + where + args = map unLoc $ case details of + PrefixPatSyn args -> args + InfixPatSyn arg1 arg2 -> [arg1, arg2] + + tcLookupPatSynWrapper name + = do { patsyn <- tcLookupPatSyn name + ; case patSynWrapper patsyn of + Nothing -> panic "tcLookupPatSynWrapper" + Just wrapper_id -> return wrapper_id } + +mkPatSynWrapperId :: Located Name + -> [Var] -> [TyVar] -> [TyVar] -> ThetaType -> Type + -> TcM Id +mkPatSynWrapperId (L _ name) args univ_tvs ex_tvs theta pat_ty = do { let qtvs = univ_tvs ++ ex_tvs ; (subst, wrapper_tvs) <- tcInstSkolTyVars qtvs ; let wrapper_theta = substTheta subst theta @@ -224,23 +241,24 @@ tc_pat_syn_wrapper_from_expr (L loc name) lexpr args univ_tvs ex_tvs theta pat_t wrapper_sigma = mkSigmaTy wrapper_tvs wrapper_theta wrapper_tau ; wrapper_name <- newImplicitBinder name mkDataConWrapperOcc - ; let wrapper_lname = L loc wrapper_name - wrapper_id = mkExportedLocalId VanillaId wrapper_name wrapper_sigma - - ; let wrapper_args = map (noLoc . VarPat . Var.varName) args' - wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds - bind = mkTopFunBind Generated wrapper_lname [wrapper_match] - lbind = noLoc bind - ; let sig = TcSigInfo{ sig_id = wrapper_id - , sig_tvs = map (\tv -> (Nothing, tv)) wrapper_tvs - , sig_theta = wrapper_theta - , sig_tau = wrapper_tau - , sig_loc = loc - } - ; (wrapper_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig lbind + ; return $ mkExportedLocalId VanillaId wrapper_name wrapper_sigma } + +mkPatSynWrapper :: Id + -> HsBind Name + -> TcM (LHsBinds Id) +mkPatSynWrapper wrapper_id bind + = do { (wrapper_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind) ; traceTc "tcPatSynDecl wrapper" $ ppr wrapper_binds ; traceTc "tcPatSynDecl wrapper type" $ ppr (varType wrapper_id) - ; return (wrapper_id, wrapper_binds) } + ; return wrapper_binds } + where + sig = TcSigInfo{ sig_id = wrapper_id + , sig_tvs = map (\tv -> (Nothing, tv)) wrapper_tvs + , sig_theta = wrapper_theta + , sig_tau = wrapper_tau + , sig_loc = noSrcSpan + } + (wrapper_tvs, wrapper_theta, wrapper_tau) = tcSplitSigmaTy (idType wrapper_id) \end{code} diff --git a/compiler/typecheck/TcPatSyn.lhs-boot b/compiler/typecheck/TcPatSyn.lhs-boot index d0420c0c31..700137c16c 100644 --- a/compiler/typecheck/TcPatSyn.lhs-boot +++ b/compiler/typecheck/TcPatSyn.lhs-boot @@ -3,14 +3,13 @@ module TcPatSyn where import Name ( Name ) import Id ( Id ) -import HsSyn ( LPat, HsPatSynDetails, HsPatSynDir, LHsBinds ) +import HsSyn ( PatSynBind, LHsBinds ) import TcRnTypes ( TcM ) -import SrcLoc ( Located ) import PatSyn ( PatSyn ) -tcPatSynDecl :: Located Name - -> HsPatSynDetails (Located Name) - -> LPat Name - -> HsPatSynDir Name +tcPatSynDecl :: PatSynBind Name Name -> TcM (PatSyn, LHsBinds Id) + +tcPatSynWrapper :: PatSynBind Name Name + -> TcM (LHsBinds Id) \end{code} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 67fa39e0e7..cd27e9d044 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -545,12 +545,35 @@ checkHiBootIface tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds, tcg_insts = local_insts, tcg_type_env = local_type_env, tcg_exports = local_exports }) - (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts, - md_types = boot_type_env, md_exports = boot_exports }) + boot_details | isHsBoot hs_src -- Current module is already a hs-boot file! = return tcg_env | otherwise + = do { mb_dfun_prs <- checkHiBootIface' local_insts local_type_env + local_exports boot_details + ; let dfun_prs = catMaybes mb_dfun_prs + boot_dfuns = map fst dfun_prs + dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) + | (boot_dfun, dfun) <- dfun_prs ] + type_env' = extendTypeEnvWithIds local_type_env boot_dfuns + tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds } + + ; setGlobalTypeEnv tcg_env' type_env' } + -- Update the global type env *including* the knot-tied one + -- so that if the source module reads in an interface unfolding + -- mentioning one of the dfuns from the boot module, then it + -- can "see" that boot dfun. See Trac #4003 + +checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo] + -> ModDetails -> TcM [Maybe (Id, Id)] +-- Variant which doesn't require a full TcGblEnv; you could get the +-- local components from another ModDetails. + +checkHiBootIface' + local_insts local_type_env local_exports + (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts, + md_types = boot_type_env, md_exports = boot_exports }) = do { traceTc "checkHiBootIface" $ vcat [ ppr boot_type_env, ppr boot_insts, ppr boot_exports] @@ -567,19 +590,11 @@ checkHiBootIface -- Check instance declarations ; mb_dfun_prs <- mapM check_inst boot_insts - ; let dfun_prs = catMaybes mb_dfun_prs - boot_dfuns = map fst dfun_prs - dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) - | (boot_dfun, dfun) <- dfun_prs ] - type_env' = extendTypeEnvWithIds local_type_env boot_dfuns - tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds } ; failIfErrsM - ; setGlobalTypeEnv tcg_env' type_env' } - -- Update the global type env *including* the knot-tied one - -- so that if the source module reads in an interface unfolding - -- mentioning one of the dfuns from the boot module, then it - -- can "see" that boot dfun. See Trac #4003 + + ; return mb_dfun_prs } + where check_export boot_avail -- boot_avail is exported by the boot iface | name `elem` dfun_names = return () @@ -681,17 +696,14 @@ checkBootTyCon tc1 tc2 (_, rho_ty2) = splitForAllTys (idType id2) op_ty2 = funResultTy rho_ty2 - eqAT (tc1, def_ats1) (tc2, def_ats2) + eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2) = checkBootTyCon tc1 tc2 && - eqListBy eqATDef def_ats1 def_ats2 + eqATDef def_ats1 def_ats2 -- Ignore the location of the defaults - eqATDef (CoAxBranch { cab_tvs = tvs1, cab_lhs = ty_pats1, cab_rhs = ty1 }) - (CoAxBranch { cab_tvs = tvs2, cab_lhs = ty_pats2, cab_rhs = ty2 }) - | Just env <- eqTyVarBndrs emptyRnEnv2 tvs1 tvs2 - = eqListBy (eqTypeX env) ty_pats1 ty_pats2 && - eqTypeX env ty1 ty2 - | otherwise = False + eqATDef Nothing Nothing = True + eqATDef (Just ty1) (Just ty2) = eqTypeX env ty1 ty2 + eqATDef _ _ = False eqFD (as1,bs1) (as2,bs2) = eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && @@ -1726,7 +1738,7 @@ loadUnqualIfaces hsc_env ictxt , let name = gre_name gre , not (isInternalName name) , let mod = nameModule name - , not (modulePackageId mod == this_pkg || isInteractiveModule mod) + , not (modulePackageKey mod == this_pkg || isInteractiveModule mod) -- Don't attempt to load an interface for stuff -- from the command line, or from the home package , isTcOcc (nameOccName name) -- Types and classes only @@ -1779,7 +1791,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , ptext (sLit "Dependent modules:") <+> ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) , ptext (sLit "Dependent packages:") <+> - ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)] + ppr (sortBy stablePackageKeyCmp $ imp_dep_pkgs imports)] where -- The two uses of sortBy are just to reduce unnecessary -- wobbling in testsuite output cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2) diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 17700e77ce..9dbc4206a5 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -1205,9 +1205,10 @@ recordUnsafeInfer = getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) False finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode finalSafeMode dflags tcg_env = do safeInf <- readIORef (tcg_safeInfer tcg_env) - return $ if safeInferOn dflags && not safeInf - then Sf_None - else safeHaskell dflags + return $ case safeHaskell dflags of + Sf_None | safeInferOn dflags && safeInf -> Sf_Safe + | otherwise -> Sf_None + s -> s \end{code} diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index d054bc21df..f46bdfd2d9 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -325,6 +325,9 @@ data TcGblEnv #endif /* GHCI */ tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings + + -- Things defined in this module, or (in GHCi) in the interactive package + -- For the latter, see Note [The interactive package] in HscTypes tcg_binds :: LHsBinds Id, -- Value bindings in this module tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids @@ -806,17 +809,17 @@ data ImportAvails -- compiling M might not need to consult X.hi, but X -- is still listed in M's dependencies. - imp_dep_pkgs :: [PackageId], + imp_dep_pkgs :: [PackageKey], -- ^ Packages needed by the module being compiled, whether directly, -- or via other modules in this package, or via modules imported -- from other packages. - imp_trust_pkgs :: [PackageId], + imp_trust_pkgs :: [PackageKey], -- ^ This is strictly a subset of imp_dep_pkgs and records the -- packages the current module needs to trust for Safe Haskell -- compilation to succeed. A package is required to be trusted if -- we are dependent on a trustworthy module in that package. - -- While perhaps making imp_dep_pkgs a tuple of (PackageId, Bool) + -- While perhaps making imp_dep_pkgs a tuple of (PackageKey, Bool) -- where True for the bool indicates the package is required to be -- trusted is the more logical design, doing so complicates a lot -- of code not concerned with Safe Haskell. @@ -1852,8 +1855,7 @@ pprO TupleOrigin = ptext (sLit "a tuple") pprO NegateOrigin = ptext (sLit "a use of syntactic negation") pprO ScOrigin = ptext (sLit "the superclasses of an instance declaration") pprO DerivOrigin = ptext (sLit "the 'deriving' clause of a data type declaration") -pprO (DerivOriginDC dc n) = pprTrace "dco" (ppr dc <+> ppr n) $ - hsep [ ptext (sLit "the"), speakNth n, +pprO (DerivOriginDC dc n) = hsep [ ptext (sLit "the"), speakNth n, ptext (sLit "field of"), quotes (ppr dc), parens (ptext (sLit "type") <+> quotes (ppr ty)) ] where ty = dataConOrigArgTys dc !! (n-1) diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index e01b2fe5a4..9891f77795 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -1147,8 +1147,8 @@ nestImplicTcS ref inner_untch inerts (TcS thing_inside) , tcs_ty_binds = ty_binds , tcs_count = count , tcs_inerts = new_inert_var - , tcs_worklist = panic "nextImplicTcS: worklist" - , tcs_implics = panic "nextImplicTcS: implics" + , tcs_worklist = panic "nestImplicTcS: worklist" + , tcs_implics = panic "nestImplicTcS: implics" -- NB: Both these are initialised by withWorkList } ; res <- TcM.setUntouchables inner_untch $ @@ -1176,8 +1176,8 @@ nestTcS (TcS thing_inside) do { inerts <- TcM.readTcRef inerts_var ; new_inert_var <- TcM.newTcRef inerts ; let nest_env = env { tcs_inerts = new_inert_var - , tcs_worklist = panic "nextImplicTcS: worklist" - , tcs_implics = panic "nextImplicTcS: implics" } + , tcs_worklist = panic "nestTcS: worklist" + , tcs_implics = panic "nestTcS: implics" } ; thing_inside nest_env } tryTcS :: TcS a -> TcS a @@ -1195,8 +1195,8 @@ tryTcS (TcS thing_inside) ; let nest_env = env { tcs_ev_binds = ev_binds_var , tcs_ty_binds = ty_binds_var , tcs_inerts = is_var - , tcs_worklist = panic "nextImplicTcS: worklist" - , tcs_implics = panic "nextImplicTcS: implics" } + , tcs_worklist = panic "tryTcS: worklist" + , tcs_implics = panic "tryTcS: implics" } ; thing_inside nest_env } -- Getters and setters of TcEnv fields @@ -1281,8 +1281,7 @@ getUntouchables = wrapTcS TcM.getUntouchables getGivenInfo :: TcS a -> TcS (Bool, [TcTyVar], a) -- See Note [inert_fsks and inert_no_eqs] getGivenInfo thing_inside - = do { - ; updInertTcS reset_vars -- Set inert_fsks and inert_no_eqs to initial values + = do { updInertTcS reset_vars -- Set inert_fsks and inert_no_eqs to initial values ; res <- thing_inside -- Run thing_inside ; is <- getTcSInerts -- Get new values of inert_fsks and inert_no_eqs ; return (inert_no_eqs (inert_cans is), inert_fsks is, res) } @@ -1559,6 +1558,8 @@ data XEvTerm = XEvTerm { ev_preds :: [PredType] -- New predicate types , ev_comp :: [EvTerm] -> EvTerm -- How to compose evidence , ev_decomp :: EvTerm -> [EvTerm] -- How to decompose evidence + -- In both ev_comp and ev_decomp, the [EvTerm] is 1-1 with ev_preds + -- and each EvTerm has type of the corresponding EvPred } data MaybeNew = Fresh CtEvidence | Cached EvTerm @@ -1645,16 +1646,16 @@ Note [xCFlavor] ~~~~~~~~~~~~~~~ A call might look like this: - xCtFlavor ev subgoal-preds evidence-transformer + xCtEvidence ev evidence-transformer - ev is Given => use ev_decomp to create new Givens for subgoal-preds, + ev is Given => use ev_decomp to create new Givens for ev_preds, and return them - ev is Wanted => create new wanteds for subgoal-preds, + ev is Wanted => create new wanteds for ev_preds, use ev_comp to bind ev, return fresh wanteds (ie ones not cached in inert_cans or solved) - ev is Derived => create new deriveds for subgoal-preds + ev is Derived => create new deriveds for ev_preds (unless cached in inert_cans or solved) Note: The [CtEvidence] returned is a subset of the subgoal-preds passed in @@ -1714,7 +1715,7 @@ as an Irreducible (see Note [Equalities with incompatible kinds] in TcCanonical), and will do no harm. \begin{code} -xCtEvidence :: CtEvidence -- Original flavor +xCtEvidence :: CtEvidence -- Original evidence -> XEvTerm -- Instructions about how to manipulate evidence -> TcS [CtEvidence] diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 843e0507dc..dde5902ccc 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -843,39 +843,6 @@ Consider floated_eqs (all wanted or derived): simpl_loop. So we iterate if there any of these \begin{code} -floatEqualities :: [TcTyVar] -> Bool -> WantedConstraints - -> TcS (Cts, WantedConstraints) --- Post: The returned floated constraints (Cts) are only Wanted or Derived --- and come from the input wanted ev vars or deriveds --- Also performs some unifications, adding to monadically-carried ty_binds --- These will be used when processing floated_eqs later -floatEqualities skols no_given_eqs wanteds@(WC { wc_flat = flats }) - | not no_given_eqs -- There are some given equalities, so don't float - = return (emptyBag, wanteds) -- Note [Float Equalities out of Implications] - | otherwise - = do { let (float_eqs, remaining_flats) = partitionBag is_floatable flats - ; untch <- TcS.getUntouchables - ; mapM_ (promoteTyVar untch) (varSetElems (tyVarsOfCts float_eqs)) - -- See Note [Promoting unification variables] - ; ty_binds <- getTcSTyBindsMap - ; traceTcS "floatEqualities" (vcat [ text "Flats =" <+> ppr flats - , text "Floated eqs =" <+> ppr float_eqs - , text "Ty binds =" <+> ppr ty_binds]) - ; return (float_eqs, wanteds { wc_flat = remaining_flats }) } - where - -- See Note [Float equalities from under a skolem binding] - skol_set = fixVarSet mk_next (mkVarSet skols) - mk_next tvs = foldrBag grow_one tvs flats - grow_one (CFunEqCan { cc_tyargs = xis, cc_rhs = rhs }) tvs - | intersectsVarSet tvs (tyVarsOfTypes xis) - = tvs `unionVarSet` tyVarsOfType rhs - grow_one _ tvs = tvs - - is_floatable :: Ct -> Bool - is_floatable ct = isEqPred pred && skol_set `disjointVarSet` tyVarsOfType pred - where - pred = ctPred ct - promoteTyVar :: Untouchables -> TcTyVar -> TcS () -- When we float a constraint out of an implication we must restore -- invariant (MetaTvInv) in Note [Untouchable type variables] in TcType @@ -1036,6 +1003,80 @@ should! If we don't solve the constraint, we'll stupidly quantify over (b:*) instead of (a:OpenKind), which can lead to disaster; see Trac #7332. Trac #7641 is a simpler example. +Note [Promoting unification variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we float an equality out of an implication we must "promote" free +unification variables of the equality, in order to maintain Invariant +(MetaTvInv) from Note [Untouchable type variables] in TcType. for the +leftover implication. + +This is absolutely necessary. Consider the following example. We start +with two implications and a class with a functional dependency. + + class C x y | x -> y + instance C [a] [a] + + (I1) [untch=beta]forall b. 0 => F Int ~ [beta] + (I2) [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c] + +We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2. +They may react to yield that (beta := [alpha]) which can then be pushed inwards +the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that +(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable +beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs: + + class C x y | x -> y where + op :: x -> y -> () + + instance C [a] [a] + + type family F a :: * + + h :: F Int -> () + h = undefined + + data TEx where + TEx :: a -> TEx + + + f (x::beta) = + let g1 :: forall b. b -> () + g1 _ = h [x] + g2 z = case z of TEx y -> (h [[undefined]], op x [y]) + in (g1 '3', g2 undefined) + + + +Note [Solving Family Equations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After we are done with simplification we may be left with constraints of the form: + [Wanted] F xis ~ beta +If 'beta' is a touchable unification variable not already bound in the TyBinds +then we'd like to create a binding for it, effectively "defaulting" it to be 'F xis'. + +When is it ok to do so? + 1) 'beta' must not already be defaulted to something. Example: + + [Wanted] F Int ~ beta <~ Will default [beta := F Int] + [Wanted] F Char ~ beta <~ Already defaulted, can't default again. We + have to report this as unsolved. + + 2) However, we must still do an occurs check when defaulting (F xis ~ beta), to + set [beta := F xis] only if beta is not among the free variables of xis. + + 3) Notice that 'beta' can't be bound in ty binds already because we rewrite RHS + of type family equations. See Inert Set invariants in TcInteract. + +This solving is now happening during zonking, see Note [Unflattening while zonking] +in TcMType. + + +********************************************************************************* +* * +* Floating equalities * +* * +********************************************************************************* + Note [Float Equalities out of Implications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For ordinary pattern matches (including existentials) we float @@ -1081,8 +1122,59 @@ Consequence: classes with functional dependencies don't matter (since there is no evidence for a fundep equality), but equality superclasses do matter (since they carry evidence). +\begin{code} +floatEqualities :: [TcTyVar] -> Bool -> WantedConstraints + -> TcS (Cts, WantedConstraints) +-- Main idea: see Note [Float Equalities out of Implications] +-- +-- Post: The returned floated constraints (Cts) are only Wanted or Derived +-- and come from the input wanted ev vars or deriveds +-- Also performs some unifications (via promoteTyVar), adding to +-- monadically-carried ty_binds. These will be used when processing +-- floated_eqs later +-- +-- Subtleties: Note [Float equalities from under a skolem binding] +-- Note [Skolem escape] +floatEqualities skols no_given_eqs wanteds@(WC { wc_flat = flats }) + | not no_given_eqs -- There are some given equalities, so don't float + = return (emptyBag, wanteds) -- Note [Float Equalities out of Implications] + | otherwise + = do { let (float_eqs, remaining_flats) = partitionBag is_floatable flats + ; untch <- TcS.getUntouchables + ; mapM_ (promoteTyVar untch) (varSetElems (tyVarsOfCts float_eqs)) + -- See Note [Promoting unification variables] + ; ty_binds <- getTcSTyBindsMap + ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols + , text "Flats =" <+> ppr flats + , text "Skol set =" <+> ppr skol_set + , text "Floated eqs =" <+> ppr float_eqs + , text "Ty binds =" <+> ppr ty_binds]) + ; return (float_eqs, wanteds { wc_flat = remaining_flats }) } + where + is_floatable :: Ct -> Bool + is_floatable ct + = case classifyPredType (ctPred ct) of + EqPred ty1 ty2 -> skol_set `disjointVarSet` tyVarsOfType ty1 + && skol_set `disjointVarSet` tyVarsOfType ty2 + _ -> False + + skol_set = fixVarSet mk_next (mkVarSet skols) + mk_next tvs = foldr grow_one tvs flat_eqs + flat_eqs :: [(TcTyVarSet, TcTyVarSet)] + flat_eqs = [ (tyVarsOfType ty1, tyVarsOfType ty2) + | EqPred ty1 ty2 <- map (classifyPredType . ctPred) (bagToList flats)] + grow_one (tvs1,tvs2) tvs + | intersectsVarSet tvs tvs1 = tvs `unionVarSet` tvs2 + | intersectsVarSet tvs tvs2 = tvs `unionVarSet` tvs2 + | otherwise = tvs +\end{code} + Note [When does an implication have given equalities?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + NB: This note is mainly referred to from TcSMonad + but it relates to floating equalities, so I've + left it here + Consider an implication beta => alpha ~ Int where beta is a unification variable that has already been unified @@ -1126,116 +1218,95 @@ This seems like the Right Thing, but it's more code, and more work at runtime, so we are using the FlatSkolOrigin idea intead. It's less obvious that it works, but I think it does, and it's simple and efficient. - Note [Float equalities from under a skolem binding] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might worry about skolem escape with all this floating. -For example, consider - [2] forall a. (a ~ F beta[2] delta, - Maybe beta[2] ~ gamma[1]) - -The (Maybe beta ~ gamma) doesn't mention 'a', so we float it, and -solve with gamma := beta. But what if later delta:=Int, and - F b Int = b. -Then we'd get a ~ beta[2], and solve to get beta:=a, and now the -skolem has escaped! - -But it's ok: when we float (Maybe beta[2] ~ gamma[1]), we promote beta[2] -to beta[1], and that means the (a ~ beta[1]) will be stuck, as it should be. - -Previously we tried to "grow" the skol_set with the constraints, to get -all the tyvars that could *conceivably* unify with the skolems, but that -was far too conservative (Trac #7804). Example: this should be fine: - f :: (forall a. a -> Proxy x -> Proxy (F x)) -> Int - f = error "Urk" :: (forall a. a -> Proxy x -> Proxy (F x)) -> Int - -BUT (sigh) we have to be careful. Here are some edge cases: +Which of the flat equalities can we float out? Obviously, only +ones that don't mention the skolem-bound variables. But that is +over-eager. Consider + [2] forall a. F a beta[1] ~ gamma[2], G beta[1] gamma[2] ~ Int +The second constraint doesn't mention 'a'. But if we float it +we'll promote gamma to gamma'[1]. Now suppose that we learn that +beta := Bool, and F a Bool = a, and G Bool _ = Int. Then we'll +we left with the constraint + [2] forall a. a ~ gamma'[1] +which is insoluble because gamma became untouchable. + +Solution: only promote a constraint if its free variables cannot +possibly be connected with the skolems. Procedurally, start with +the skolems and "grow" that set as follows: + * For each flat equality F ts ~ s, or tv ~ s, + if the current set intersects with the LHS of the equality, + add the free vars of the RHS, and vice versa +That gives us a grown skolem set. Now float an equality if its free +vars don't intersect the grown skolem set. + +This seems very ad hoc (sigh). But here are some tricky edge cases: a) [2]forall a. (F a delta[1] ~ beta[2], delta[1] ~ Maybe beta[2]) -b) [2]forall a. (F b ty ~ beta[2], G beta[2] ~ gamma[2]) +b1) [2]forall a. (F a ty ~ beta[2], G beta[2] ~ gamma[2]) +b2) [2]forall a. (a ~ beta[2], G beta[2] ~ gamma[2]) c) [2]forall a. (F a ty ~ beta[2], delta[1] ~ Maybe beta[2]) +d) [2]forall a. (gamma[1] ~ Tree beta[2], F ty ~ beta[2]) In (a) we *must* float out the second equality, else we can't solve at all (Trac #7804). -In (b) we *must not* float out the second equality. - It will ultimately be solved (by flattening) in situ, but if we - float it we'll promote beta,gamma, and render the first equality insoluble. +In (b1, b2) we *must not* float out the second equality. + It will ultimately be solved (by flattening) in situ, but if we float + it we'll promote beta,gamma, and render the first equality insoluble. + + Trac #9316 was an example of (b2). You may wonder why (a ~ beta[2]) isn't + solved; in #9316 it wasn't solved because (a:*) and (beta:kappa[1]), so the + equality was kind-mismatched, and hence was a CIrredEvCan. There was + another equality alongside, (kappa[1] ~ *). We must first float *that* + one out and *then* we can solve (a ~ beta). In (c) it would be OK to float the second equality but better not to. If we flatten we see (delta[1] ~ Maybe (F a ty)), which is a - skolem-escape problem. If we float the secodn equality we'll + skolem-escape problem. If we float the second equality we'll end up with (F a ty ~ beta'[1]), which is a less explicable error. -Hence we start with the skolems, grow them by the CFunEqCans, and -float ones that don't mention the grown variables. Seems very ad hoc. - -Note [Promoting unification variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we float an equality out of an implication we must "promote" free -unification variables of the equality, in order to maintain Invariant -(MetaTvInv) from Note [Untouchable type variables] in TcType. for the -leftover implication. - -This is absolutely necessary. Consider the following example. We start -with two implications and a class with a functional dependency. - - class C x y | x -> y - instance C [a] [a] - - (I1) [untch=beta]forall b. 0 => F Int ~ [beta] - (I2) [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c] - -We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2. -They may react to yield that (beta := [alpha]) which can then be pushed inwards -the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that -(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable -beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs: - - class C x y | x -> y where - op :: x -> y -> () - - instance C [a] [a] - - type family F a :: * - - h :: F Int -> () - h = undefined - - data TEx where - TEx :: a -> TEx +In (d) we must float the first equality, so that we can unify gamma. + But that promotes beta, so we must float the second equality too, + Trac #7196 exhibits this case +Some notes - f (x::beta) = - let g1 :: forall b. b -> () - g1 _ = h [x] - g2 z = case z of TEx y -> (h [[undefined]], op x [y]) - in (g1 '3', g2 undefined) +* When "growing", do not simply take the free vars of the predicate! + Example [2]forall a. (a:* ~ beta[2]:kappa[1]), (kappa[1] ~ *) + We must float the second, and we must not float the first. + But the first actually looks like ((~) kappa a beta), so if we just + look at its free variables we'll see {a,kappa,beta), and that might + make us think kappa should be in the grown skol set. + (In any case, the kind argument for a kind-mis-matched equality like + this one doesn't really make sense anyway.) + That's why we use classifyPred when growing. -Note [Solving Family Equations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -After we are done with simplification we may be left with constraints of the form: - [Wanted] F xis ~ beta -If 'beta' is a touchable unification variable not already bound in the TyBinds -then we'd like to create a binding for it, effectively "defaulting" it to be 'F xis'. - -When is it ok to do so? - 1) 'beta' must not already be defaulted to something. Example: +* Previously we tried to "grow" the skol_set with *all* the + constraints (not just equalities), to get all the tyvars that could + *conceivably* unify with the skolems, but that was far too + conservative (Trac #7804). Example: this should be fine: + f :: (forall a. a -> Proxy x -> Proxy (F x)) -> Int + f = error "Urk" :: (forall a. a -> Proxy x -> Proxy (F x)) -> Int - [Wanted] F Int ~ beta <~ Will default [beta := F Int] - [Wanted] F Char ~ beta <~ Already defaulted, can't default again. We - have to report this as unsolved. - 2) However, we must still do an occurs check when defaulting (F xis ~ beta), to - set [beta := F xis] only if beta is not among the free variables of xis. +Note [Skolem escape] +~~~~~~~~~~~~~~~~~~~~ +You might worry about skolem escape with all this floating. +For example, consider + [2] forall a. (a ~ F beta[2] delta, + Maybe beta[2] ~ gamma[1]) - 3) Notice that 'beta' can't be bound in ty binds already because we rewrite RHS - of type family equations. See Inert Set invariants in TcInteract. +The (Maybe beta ~ gamma) doesn't mention 'a', so we float it, and +solve with gamma := beta. But what if later delta:=Int, and + F b Int = b. +Then we'd get a ~ beta[2], and solve to get beta:=a, and now the +skolem has escaped! -This solving is now happening during zonking, see Note [Unflattening while zonking] -in TcMType. +But it's ok: when we float (Maybe beta[2] ~ gamma[1]), we promote beta[2] +to beta[1], and that means the (a ~ beta[1]) will be stuck, as it should be. ********************************************************************************* diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index de3fbdbe89..bb6af8cb95 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -895,7 +895,7 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where RealSrcSpan s -> return s ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) , TH.loc_module = moduleNameString (moduleName m) - , TH.loc_package = packageIdString (modulePackageId m) + , TH.loc_package = packageKeyString (modulePackageKey m) , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } @@ -1472,7 +1472,7 @@ reifyName thing where name = getName thing mod = ASSERT( isExternalName name ) nameModule name - pkg_str = packageIdString (modulePackageId mod) + pkg_str = packageKeyString (modulePackageKey mod) mod_str = moduleNameString (moduleName mod) occ_str = occNameString occ occ = nameOccName name @@ -1505,7 +1505,7 @@ lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm) lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn)) = return $ ModuleTarget $ - mkModule (stringToPackageId $ TH.pkgString pn) (mkModuleName $ TH.modString mn) + mkModule (stringToPackageKey $ TH.pkgString pn) (mkModuleName $ TH.modString mn) reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a] reifyAnnotations th_name @@ -1519,13 +1519,13 @@ reifyAnnotations th_name ------------------------------ modToTHMod :: Module -> TH.Module -modToTHMod m = TH.Module (TH.PkgName $ packageIdString $ modulePackageId m) +modToTHMod m = TH.Module (TH.PkgName $ packageKeyString $ modulePackageKey m) (TH.ModName $ moduleNameString $ moduleName m) reifyModule :: TH.Module -> TcM TH.ModuleInfo reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do this_mod <- getModule - let reifMod = mkModule (stringToPackageId pkgString) (mkModuleName mString) + let reifMod = mkModule (stringToPackageKey pkgString) (mkModuleName mString) if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod where reifyThisModule = do @@ -1535,10 +1535,10 @@ reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do reifyFromIface reifMod = do iface <- loadInterfaceForModule (ptext (sLit "reifying module from TH for") <+> ppr reifMod) reifMod let usages = [modToTHMod m | usage <- mi_usages iface, - Just m <- [usageToModule (modulePackageId reifMod) usage] ] + Just m <- [usageToModule (modulePackageKey reifMod) usage] ] return $ TH.ModuleInfo usages - usageToModule :: PackageId -> Usage -> Maybe Module + usageToModule :: PackageKey -> Usage -> Maybe Module usageToModule _ (UsageFile {}) = Nothing usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot index ea3848db18..fd19dee7da 100644 --- a/compiler/typecheck/TcSplice.lhs-boot +++ b/compiler/typecheck/TcSplice.lhs-boot @@ -5,7 +5,6 @@ module TcSplice where import HsSyn ( HsSplice, HsBracket, HsQuasiQuote, HsExpr, LHsType, LHsExpr, LPat, LHsDecl ) import HsExpr ( PendingRnSplice ) -import Id ( Id ) import Name ( Name ) import RdrName ( RdrName ) import TcRnTypes( TcM, TcId ) @@ -13,6 +12,7 @@ import TcType ( TcRhoType ) import Annotations ( Annotation, CoreAnnTarget ) #ifdef GHCI +import Id ( Id ) import qualified Language.Haskell.TH as TH #endif @@ -28,20 +28,20 @@ tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId) -tcTopSpliceExpr :: Bool -> TcM (LHsExpr Id) -> TcM (LHsExpr Id) - runQuasiQuoteDecl :: HsQuasiQuote RdrName -> TcM [LHsDecl RdrName] runQuasiQuoteExpr :: HsQuasiQuote RdrName -> TcM (LHsExpr RdrName) runQuasiQuoteType :: HsQuasiQuote RdrName -> TcM (LHsType RdrName) runQuasiQuotePat :: HsQuasiQuote RdrName -> TcM (LPat RdrName) runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation +#ifdef GHCI +tcTopSpliceExpr :: Bool -> TcM (LHsExpr Id) -> TcM (LHsExpr Id) + runMetaE :: LHsExpr Id -> TcM (LHsExpr RdrName) runMetaP :: LHsExpr Id -> TcM (LPat RdrName) runMetaT :: LHsExpr Id -> TcM (LHsType RdrName) runMetaD :: LHsExpr Id -> TcM [LHsDecl RdrName] -#ifdef GHCI lookupThName_maybe :: TH.Name -> TcM (Maybe Name) runQuasi :: TH.Q a -> TcM a #endif diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index c21631f1eb..f09bef8081 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -14,7 +14,7 @@ module TcTyClsDecls ( -- Functions used by TcInstDcls to check -- data/type family instance declarations kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon, - tcSynFamInstDecl, tcFamTyPats, + tcFamTyPats, tcTyFamInstEqn, famTyConShape, tcAddTyFamInstCtxt, tcAddDataFamInstCtxt, wrongKindOfFamily, dataConCtxt, badDataConTyCon ) where @@ -502,10 +502,12 @@ kcTyClDecl (ForeignType {}) = return () -- closed type families look at their equations, but other families don't -- do anything here -kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name - , fdInfo = ClosedTypeFamily eqns })) - = do { k <- kcLookupKind fam_tc_name - ; mapM_ (kcTyFamInstEqn fam_tc_name k) eqns } +kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name + , fdTyVars = hs_tvs + , fdInfo = ClosedTypeFamily eqns })) + = do { tc_kind <- kcLookupKind fam_tc_name + ; let fam_tc_shape = ( fam_tc_name, length (hsQTvBndrs hs_tvs), tc_kind) + ; mapM_ (kcTyFamInstEqn fam_tc_shape) eqns } kcTyClDecl (FamDecl {}) = return () ------------------- @@ -699,14 +701,11 @@ tcFamDecl1 parent ; checkFamFlag tc_name -- make sure we have -XTypeFamilies - -- check to make sure all the names used in the equations are - -- consistent - ; let names = map (tfie_tycon . unLoc) eqns - ; tcSynFamInstNames lname names - - -- process the equations, creating CoAxBranches - ; tycon_kind <- kcLookupKind tc_name - ; branches <- mapM (tcTyFamInstEqn tc_name tycon_kind) eqns + -- Process the equations, creating CoAxBranches + ; tc_kind <- kcLookupKind tc_name + ; let fam_tc_shape = (tc_name, length (hsQTvBndrs tvs), tc_kind) + + ; branches <- mapM (tcTyFamInstEqn fam_tc_shape) eqns -- we need the tycon that we will be creating, but it's in scope. -- just look it up. @@ -836,76 +835,90 @@ Note that: - We can get default definitions only for type families, not data families \begin{code} -tcClassATs :: Name -- The class name (not knot-tied) - -> TyConParent -- The class parent of this associated type - -> [LFamilyDecl Name] -- Associated types. - -> [LTyFamInstDecl Name] -- Associated type defaults. +tcClassATs :: Name -- The class name (not knot-tied) + -> TyConParent -- The class parent of this associated type + -> [LFamilyDecl Name] -- Associated types. + -> [LTyFamDefltEqn Name] -- Associated type defaults. -> TcM [ClassATItem] tcClassATs class_name parent ats at_defs = do { -- Complain about associated type defaults for non associated-types sequence_ [ failWithTc (badATErr class_name n) - | n <- map (tyFamInstDeclName . unLoc) at_defs + | n <- map at_def_tycon at_defs , not (n `elemNameSet` at_names) ] ; mapM tc_at ats } where - at_names = mkNameSet (map (unLoc . fdLName . unLoc) ats) + at_def_tycon :: LTyFamDefltEqn Name -> Name + at_def_tycon (L _ eqn) = unLoc (tfe_tycon eqn) + + at_fam_name :: LFamilyDecl Name -> Name + at_fam_name (L _ decl) = unLoc (fdLName decl) + + at_names = mkNameSet (map at_fam_name ats) - at_defs_map :: NameEnv [LTyFamInstDecl Name] + at_defs_map :: NameEnv [LTyFamDefltEqn Name] -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv - (tyFamInstDeclName (unLoc at_def)) [at_def]) + (at_def_tycon at_def) [at_def]) emptyNameEnv at_defs tc_at at = do { [ATyCon fam_tc] <- addLocM (tcFamDecl1 parent) at - ; let at_defs = lookupNameEnv at_defs_map (unLoc $ fdLName $ unLoc at) - `orElse` [] - ; atd <- mapM (tcDefaultAssocDecl fam_tc) at_defs - ; return (fam_tc, atd) } + ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) + `orElse` [] + ; atd <- tcDefaultAssocDecl fam_tc at_defs + ; return (ATI fam_tc atd) } ------------------------- -tcDefaultAssocDecl :: TyCon -- ^ Family TyCon - -> LTyFamInstDecl Name -- ^ RHS - -> TcM CoAxBranch -- ^ Type checked RHS and free TyVars -tcDefaultAssocDecl fam_tc (L loc decl) +tcDefaultAssocDecl :: TyCon -- ^ Family TyCon + -> [LTyFamDefltEqn Name] -- ^ Defaults + -> TcM (Maybe Type) -- ^ Type checked RHS +tcDefaultAssocDecl _ [] + = return Nothing -- No default declaration + +tcDefaultAssocDecl _ (d1:_:_) + = failWithTc (ptext (sLit "More than one default declaration for") + <+> ppr (tfe_tycon (unLoc d1))) + +tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name + , tfe_pats = hs_tvs + , tfe_rhs = rhs })] = setSrcSpan loc $ - tcAddTyFamInstCtxt decl $ - do { traceTc "tcDefaultAssocDecl" (ppr decl) - ; tcSynFamInstDecl fam_tc decl } + tcAddFamInstCtxt (ptext (sLit "default type instance")) tc_name $ + tcTyClTyVars tc_name hs_tvs $ \ tvs rhs_kind -> + do { traceTc "tcDefaultAssocDecl" (ppr tc_name) + ; checkTc (isSynFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; let (fam_name, fam_pat_arity, _) = famTyConShape fam_tc + ; ASSERT( fam_name == tc_name ) + checkTc (length (hsQTvBndrs hs_tvs) == fam_pat_arity) + (wrongNumberOfParmsErr fam_pat_arity) + ; rhs_ty <- tcCheckLHsType rhs rhs_kind + ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty + ; let fam_tc_tvs = tyConTyVars fam_tc + subst = zipTopTvSubst tvs (mkTyVarTys fam_tc_tvs) + ; return ( ASSERT( equalLength fam_tc_tvs tvs ) + Just (substTy subst rhs_ty) ) } -- We check for well-formedness and validity later, in checkValidClass ------------------------- -tcSynFamInstDecl :: TyCon -> TyFamInstDecl Name -> TcM CoAxBranch --- Placed here because type family instances appear as --- default decls in class declarations -tcSynFamInstDecl fam_tc (TyFamInstDecl { tfid_eqn = eqn }) - = do { checkTc (isSynFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; tcTyFamInstEqn (tyConName fam_tc) (tyConKind fam_tc) eqn } - --- Checks to make sure that all the names in an instance group are the same -tcSynFamInstNames :: Located Name -> [Located Name] -> TcM () -tcSynFamInstNames (L _ first) names - = do { let badNames = filter ((/= first) . unLoc) names - ; mapM_ (failLocated (wrongNamesInInstGroup first)) badNames } - where - failLocated :: (Name -> SDoc) -> Located Name -> TcM () - failLocated msg_fun (L loc name) - = setSrcSpan loc $ - failWithTc (msg_fun name) - -kcTyFamInstEqn :: Name -> Kind -> LTyFamInstEqn Name -> TcM () -kcTyFamInstEqn fam_tc_name kind - (L loc (TyFamInstEqn { tfie_pats = pats, tfie_rhs = hs_ty })) +kcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn Name -> TcM () +kcTyFamInstEqn fam_tc_shape + (L loc (TyFamEqn { tfe_pats = pats, tfe_rhs = hs_ty })) = setSrcSpan loc $ discardResult $ - tc_fam_ty_pats fam_tc_name kind pats (discardResult . (tcCheckLHsType hs_ty)) - -tcTyFamInstEqn :: Name -> Kind -> LTyFamInstEqn Name -> TcM CoAxBranch -tcTyFamInstEqn fam_tc_name kind - (L loc (TyFamInstEqn { tfie_pats = pats, tfie_rhs = hs_ty })) + tc_fam_ty_pats fam_tc_shape pats (discardResult . (tcCheckLHsType hs_ty)) + +tcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn Name -> TcM CoAxBranch +-- Needs to be here, not in TcInstDcls, because closed families +-- (typechecked here) have TyFamInstEqns +tcTyFamInstEqn fam_tc_shape@(fam_tc_name,_,_) + (L loc (TyFamEqn { tfe_tycon = L _ eqn_tc_name + , tfe_pats = pats + , tfe_rhs = hs_ty })) = setSrcSpan loc $ - tcFamTyPats fam_tc_name kind pats (discardResult . (tcCheckLHsType hs_ty)) $ + tcFamTyPats fam_tc_shape pats (discardResult . (tcCheckLHsType hs_ty)) $ \tvs' pats' res_kind -> - do { rhs_ty <- tcCheckLHsType hs_ty res_kind + do { checkTc (fam_tc_name == eqn_tc_name) + (wrongTyFamName fam_tc_name eqn_tc_name) + ; rhs_ty <- tcCheckLHsType hs_ty res_kind ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty ; traceTc "tcTyFamInstEqn" (ppr fam_tc_name <+> ppr tvs') -- don't print out the pats here, as they might be zonked inside the knot @@ -947,6 +960,19 @@ type families. tcFamTyPats type checks the patterns, zonks, and then calls thing_inside to generate a desugaring. It is used during type-checking (not kind-checking). +Note [Type-checking type patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking the patterns of a family instance declaration, we can't +rely on using the family TyCon, because this is sometimes called +from within a type-checking knot. (Specifically for closed type families.) +The type FamTyConShape gives just enough information to do the job. + +The "arity" field of FamTyConShape is the *visible* arity of the family +type constructor, i.e. what the users sees and writes, not including kind +arguments. + +See also Note [tc_fam_ty_pats vs tcFamTyPats] + Note [Failing early in kcDataDefn] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We need to use checkNoErrs when calling kcConDecl. This is because kcConDecl @@ -961,15 +987,18 @@ two bad things could happen: \begin{code} ----------------- --- Note that we can't use the family TyCon, because this is sometimes called --- from within a type-checking knot. So, we ask our callers to do a little more --- work. --- See Note [tc_fam_ty_pats vs tcFamTyPats] -tc_fam_ty_pats :: Name -- of the family TyCon - -> Kind -- of the family TyCon +type FamTyConShape = (Name, Arity, Kind) -- See Note [Type-checking type patterns] + +famTyConShape :: TyCon -> FamTyConShape +famTyConShape fam_tc + = ( tyConName fam_tc + , length (filterOut isKindVar (tyConTyVars fam_tc)) + , tyConKind fam_tc ) + +tc_fam_ty_pats :: FamTyConShape -> HsWithBndrs [LHsType Name] -- Patterns - -> (TcKind -> TcM ()) -- Kind checker for RHS - -- result is ignored + -> (TcKind -> TcM ()) -- Kind checker for RHS + -- result is ignored -> TcM ([Kind], [Type], Kind) -- Check the type patterns of a type or data family instance -- type instance F <pat1> <pat2> = <type> @@ -982,7 +1011,7 @@ tc_fam_ty_pats :: Name -- of the family TyCon -- In that case, the type variable 'a' will *already be in scope* -- (and, if C is poly-kinded, so will its kind parameter). -tc_fam_ty_pats fam_tc_name kind +tc_fam_ty_pats (name, arity, kind) (HsWB { hswb_cts = arg_pats, hswb_kvs = kvars, hswb_tvs = tvars }) kind_checker = do { let (fam_kvs, fam_body) = splitForAllTys kind @@ -994,9 +1023,8 @@ tc_fam_ty_pats fam_tc_name kind -- Note that we don't have enough information at hand to do a full check, -- as that requires the full declared arity of the family, which isn't -- nearby. - ; let max_args = length (fst $ splitKindFunTys fam_body) - ; checkTc (length arg_pats <= max_args) $ - wrongNumberOfParmsErrTooMany max_args + ; checkTc (length arg_pats == arity) $ + wrongNumberOfParmsErr arity -- Instantiate with meta kind vars ; fam_arg_kinds <- mapM (const newMetaKindVar) fam_kvs @@ -1011,22 +1039,21 @@ tc_fam_ty_pats fam_tc_name kind -- See Note [Quantifying over family patterns] ; typats <- tcHsTyVarBndrs hs_tvs $ \ _ -> do { kind_checker res_kind - ; tcHsArgTys (quotes (ppr fam_tc_name)) arg_pats arg_kinds } + ; tcHsArgTys (quotes (ppr name)) arg_pats arg_kinds } ; return (fam_arg_kinds, typats, res_kind) } -- See Note [tc_fam_ty_pats vs tcFamTyPats] -tcFamTyPats :: Name -- of the family ToCon - -> Kind -- of the family TyCon +tcFamTyPats :: FamTyConShape -> HsWithBndrs [LHsType Name] -- patterns -> (TcKind -> TcM ()) -- kind-checker for RHS -> ([TKVar] -- Kind and type variables -> [TcType] -- Kind and type arguments -> Kind -> TcM a) -> TcM a -tcFamTyPats fam_tc_name kind pats kind_checker thing_inside +tcFamTyPats fam_shape@(name,_,_) pats kind_checker thing_inside = do { (fam_arg_kinds, typats, res_kind) - <- tc_fam_ty_pats fam_tc_name kind pats kind_checker + <- tc_fam_ty_pats fam_shape pats kind_checker ; let all_args = fam_arg_kinds ++ typats -- Find free variables (after zonking) and turn @@ -1040,7 +1067,7 @@ tcFamTyPats fam_tc_name kind pats kind_checker thing_inside ; all_args' <- zonkTcTypeToTypes ze all_args ; res_kind' <- zonkTcTypeToType ze res_kind - ; traceTc "tcFamTyPats" (ppr fam_tc_name) + ; traceTc "tcFamTyPats" (ppr name) -- don't print out too much, as we might be in the knot ; tcExtendTyVarEnv qtkvs' $ thing_inside qtkvs' all_args' res_kind' } @@ -1484,16 +1511,19 @@ checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () checkValidDataCon dflags existential_ok tc con = setSrcSpan (srcLocSpan (getSrcLoc con)) $ addErrCtxt (dataConCtxt con) $ - do { traceTc "checkValidDataCon" (ppr con $$ ppr tc) - - -- Check that the return type of the data constructor + do { -- Check that the return type of the data constructor -- matches the type constructor; eg reject this: -- data T a where { MkT :: Bogus a } -- c.f. Note [Check role annotations in a second pass] -- and Note [Checking GADT return types] - ; let tc_tvs = tyConTyVars tc + let tc_tvs = tyConTyVars tc res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) orig_res_ty = dataConOrigResTy con + ; traceTc "checkValidDataCon" (vcat + [ ppr con, ppr tc, ppr tc_tvs + , ppr res_ty_tmpl <+> dcolon <+> ppr (typeKind res_ty_tmpl) + , ppr orig_res_ty <+> dcolon <+> ppr (typeKind orig_res_ty)]) + ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs) res_ty_tmpl orig_res_ty)) @@ -1578,11 +1608,14 @@ checkValidClass :: Class -> TcM () checkValidClass cls = do { constrained_class_methods <- xoptM Opt_ConstrainedClassMethods ; multi_param_type_classes <- xoptM Opt_MultiParamTypeClasses + ; nullary_type_classes <- xoptM Opt_NullaryTypeClasses ; fundep_classes <- xoptM Opt_FunctionalDependencies -- Check that the class is unary, unless multiparameter type classes - -- are enabled (which allows nullary type classes) - ; checkTc (multi_param_type_classes || arity == 1) + -- are enabled; also recognize deprecated nullary type classes + -- extension (subsumed by multiparameter type classes, Trac #8993) + ; checkTc (multi_param_type_classes || arity == 1 || + (nullary_type_classes && arity == 0)) (classArityErr arity cls) ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls) @@ -1642,15 +1675,10 @@ checkValidClass cls -- in the context of a for-all must mention at least one quantified -- type variable. What a mess! - check_at_defs (fam_tc, defs) + check_at_defs (ATI fam_tc _) = do { traceTc "check-at" (ppr fam_tc $$ ppr (tyConTyVars fam_tc) $$ ppr tyvars) ; checkTc (any (`elem` tyvars) (tyConTyVars fam_tc)) - (noClassTyVarErr cls (ptext (sLit "associated type") <+> quotes (ppr fam_tc))) - - ; tcAddDefaultAssocDeclCtxt (tyConName fam_tc) $ - mapM_ (checkValidTyFamInst mb_clsinfo fam_tc) defs } - - mb_clsinfo = Just (cls, mkVarEnv [ (tv, mkTyVarTy tv) | tv <- tyvars ]) + (noClassTyVarErr cls (ptext (sLit "associated type") <+> quotes (ppr fam_tc))) } checkFamFlag :: Name -> TcM () -- Check that we don't use families without -XTypeFamilies @@ -2007,13 +2035,6 @@ gotten by appying the eq_spec to the univ_tvs of the data con. %************************************************************************ \begin{code} -tcAddDefaultAssocDeclCtxt :: Name -> TcM a -> TcM a -tcAddDefaultAssocDeclCtxt name thing_inside - = addErrCtxt ctxt thing_inside - where - ctxt = hsep [ptext (sLit "In the type synonym instance default declaration for"), - quotes (ppr name)] - tcAddTyFamInstCtxt :: TyFamInstDecl Name -> TcM a -> TcM a tcAddTyFamInstCtxt decl = tcAddFamInstCtxt (ptext (sLit "type instance")) (tyFamInstDeclName decl) @@ -2154,16 +2175,16 @@ wrongKindOfFamily family | isAlgTyCon family = ptext (sLit "data type") | otherwise = pprPanic "wrongKindOfFamily" (ppr family) -wrongNumberOfParmsErrTooMany :: Arity -> SDoc -wrongNumberOfParmsErrTooMany max_args - = ptext (sLit "Number of parameters must match family declaration; expected no more than") +wrongNumberOfParmsErr :: Arity -> SDoc +wrongNumberOfParmsErr max_args + = ptext (sLit "Number of parameters must match family declaration; expected") <+> ppr max_args -wrongNamesInInstGroup :: Name -> Name -> SDoc -wrongNamesInInstGroup first cur - = ptext (sLit "Mismatched type names in closed type family declaration.") $$ - ptext (sLit "First name was") <+> - (ppr first) <> (ptext (sLit "; this one is")) <+> (ppr cur) +wrongTyFamName :: Name -> Name -> SDoc +wrongTyFamName fam_tc_name eqn_tc_name + = hang (ptext (sLit "Mismatched type name in type family instance.")) + 2 (vcat [ ptext (sLit "Expected:") <+> ppr fam_tc_name + , ptext (sLit " Actual:") <+> ppr eqn_tc_name ]) inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc inaccessibleCoAxBranch tc fi diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index 31d522fdeb..262aa519b3 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -121,7 +121,7 @@ synTyConsOfType ty mkSynEdges :: [LTyClDecl Name] -> [(LTyClDecl Name, Name, [Name])] mkSynEdges syn_decls = [ (ldecl, name, nameSetToList fvs) | ldecl@(L _ (SynDecl { tcdLName = L _ name - , tcdFVs = fvs })) <- syn_decls ] + , tcdFVs = fvs })) <- syn_decls ] calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)] calcSynCycles = stronglyConnCompFromEdgedVertices . mkSynEdges @@ -264,7 +264,7 @@ this for all newtypes, we'd get infinite types. So we figure out for each newtype whether it is "recursive", and add a coercion if so. In effect, we are trying to "cut the loops" by identifying a loop-breaker. -2. Avoid infinite unboxing. This is nothing to do with newtypes. +2. Avoid infinite unboxing. This has nothing to do with newtypes. Suppose we have data T = MkT Int T f (MkT x t) = f t diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index a952ce702e..f12ec9d6d5 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -95,8 +95,6 @@ module TcType ( isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool isFFILabelTy, -- :: Type -> Bool - isFFIDotnetTy, -- :: DynFlags -> Type -> Bool - isFFIDotnetObjTy, -- :: Type -> Bool isFFITy, -- :: Type -> Bool isFunPtrTy, -- :: Type -> Bool tcSplitIOType_maybe, -- :: Type -> Maybe Type @@ -175,6 +173,7 @@ import Maybes import ListSetOps import Outputable import FastString +import ErrUtils( Validity(..), isValid ) import Data.IORef import Control.Monad (liftM, ap) @@ -1420,25 +1419,25 @@ tcSplitIOType_maybe ty isFFITy :: Type -> Bool -- True for any TyCon that can possibly be an arg or result of an FFI call -isFFITy ty = checkRepTyCon legalFFITyCon ty +isFFITy ty = isValid (checkRepTyCon legalFFITyCon ty empty) -isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool +isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity -- Checks for valid argument type for a 'foreign import' isFFIArgumentTy dflags safety ty - = checkRepTyCon (legalOutgoingTyCon dflags safety) ty + = checkRepTyCon (legalOutgoingTyCon dflags safety) ty empty -isFFIExternalTy :: Type -> Bool +isFFIExternalTy :: Type -> Validity -- Types that are allowed as arguments of a 'foreign export' -isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty +isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty empty -isFFIImportResultTy :: DynFlags -> Type -> Bool +isFFIImportResultTy :: DynFlags -> Type -> Validity isFFIImportResultTy dflags ty - = checkRepTyCon (legalFIResultTyCon dflags) ty + = checkRepTyCon (legalFIResultTyCon dflags) ty empty -isFFIExportResultTy :: Type -> Bool -isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty +isFFIExportResultTy :: Type -> Validity +isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty empty -isFFIDynTy :: Type -> Type -> Bool +isFFIDynTy :: Type -> Type -> Validity -- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of -- either, and the wrapped function type must be equal to the given type. -- We assume that all types have been run through normalizeFfiType, so we don't @@ -1450,60 +1449,54 @@ isFFIDynTy expected ty | Just (tc, [ty']) <- splitTyConApp_maybe ty , tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey] , eqType ty' expected - = True + = IsValid | otherwise - = False + = NotValid (vcat [ ptext (sLit "Expected: Ptr/FunPtr") <+> pprParendType expected <> comma + , ptext (sLit " Actual:") <+> ppr ty ]) -isFFILabelTy :: Type -> Bool +isFFILabelTy :: Type -> Validity -- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. -isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey] +isFFILabelTy ty = checkRepTyCon ok ty extra + where + ok tc = tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey + extra = ptext (sLit "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)") -isFFIPrimArgumentTy :: DynFlags -> Type -> Bool +isFFIPrimArgumentTy :: DynFlags -> Type -> Validity -- Checks for valid argument type for a 'foreign import prim' -- Currently they must all be simple unlifted types, or the well-known type -- Any, which can be used to pass the address to a Haskell object on the heap to -- the foreign function. isFFIPrimArgumentTy dflags ty - = isAnyTy ty || checkRepTyCon (legalFIPrimArgTyCon dflags) ty + | isAnyTy ty = IsValid + | otherwise = checkRepTyCon (legalFIPrimArgTyCon dflags) ty empty -isFFIPrimResultTy :: DynFlags -> Type -> Bool +isFFIPrimResultTy :: DynFlags -> Type -> Validity -- Checks for valid result type for a 'foreign import prim' -- Currently it must be an unlifted type, including unboxed tuples. isFFIPrimResultTy dflags ty - = checkRepTyCon (legalFIPrimResultTyCon dflags) ty - -isFFIDotnetTy :: DynFlags -> Type -> Bool -isFFIDotnetTy dflags ty - = checkRepTyCon (\ tc -> (legalFIResultTyCon dflags tc || - isFFIDotnetObjTy ty || isStringTy ty)) ty - -- NB: isStringTy used to look through newtypes, but - -- it no longer does so. May need to adjust isFFIDotNetTy - -- if we do want to look through newtypes. - -isFFIDotnetObjTy :: Type -> Bool -isFFIDotnetObjTy ty - = checkRepTyCon check_tc t_ty - where - (_, t_ty) = tcSplitForAllTys ty - check_tc tc = getName tc == objectTyConName + = checkRepTyCon (legalFIPrimResultTyCon dflags) ty empty isFunPtrTy :: Type -> Bool -isFunPtrTy = checkRepTyConKey [funPtrTyConKey] +isFunPtrTy ty = isValid (checkRepTyCon (`hasKey` funPtrTyConKey) ty empty) -- normaliseFfiType gets run before checkRepTyCon, so we don't -- need to worry about looking through newtypes or type functions -- here; that's already been taken care of. -checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool -checkRepTyCon check_tc ty - | Just (tc, _) <- splitTyConApp_maybe ty - = check_tc tc - | otherwise - = False - -checkRepTyConKey :: [Unique] -> Type -> Bool --- Like checkRepTyCon, but just looks at the TyCon key -checkRepTyConKey keys - = checkRepTyCon (\tc -> tyConUnique tc `elem` keys) +checkRepTyCon :: (TyCon -> Bool) -> Type -> SDoc -> Validity +checkRepTyCon check_tc ty extra + = case splitTyConApp_maybe ty of + Just (tc, tys) + | isNewTyCon tc -> NotValid (hang msg 2 (mk_nt_reason tc tys $$ nt_fix)) + | check_tc tc -> IsValid + | otherwise -> NotValid (msg $$ extra) + Nothing -> NotValid (quotes (ppr ty) <+> ptext (sLit "is not a data type") $$ extra) + where + msg = quotes (ppr ty) <+> ptext (sLit "cannot be marshalled in a foreign call") + mk_nt_reason tc tys + | null tys = ptext (sLit "because its data construtor is not in scope") + | otherwise = ptext (sLit "because the data construtor for") + <+> quotes (ppr tc) <+> ptext (sLit "is not in scope") + nt_fix = ptext (sLit "Possible fix: import the data constructor to bring it into scope") \end{code} Note [Foreign import dynamic] @@ -1550,21 +1543,25 @@ legalOutgoingTyCon dflags _ tc legalFFITyCon :: TyCon -> Bool -- True for any TyCon that can possibly be an arg or result of an FFI call legalFFITyCon tc - = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon + | isUnLiftedTyCon tc = True + | tc == unitTyCon = True + | otherwise = boxedMarshalableTyCon tc marshalableTyCon :: DynFlags -> TyCon -> Bool marshalableTyCon dflags tc - = (xopt Opt_UnliftedFFITypes dflags + | (xopt Opt_UnliftedFFITypes dflags && isUnLiftedTyCon tc && not (isUnboxedTupleTyCon tc) && case tyConPrimRep tc of -- Note [Marshalling VoidRep] VoidRep -> False _ -> True) - || boxedMarshalableTyCon tc + = True + | otherwise + = boxedMarshalableTyCon tc boxedMarshalableTyCon :: TyCon -> Bool boxedMarshalableTyCon tc - = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey + | getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey , int32TyConKey, int64TyConKey , wordTyConKey, word8TyConKey, word16TyConKey , word32TyConKey, word64TyConKey @@ -1574,26 +1571,35 @@ boxedMarshalableTyCon tc , stablePtrTyConKey , boolTyConKey ] + = True + + | otherwise = False legalFIPrimArgTyCon :: DynFlags -> TyCon -> Bool -- Check args of 'foreign import prim', only allow simple unlifted types. -- Strictly speaking it is unnecessary to ban unboxed tuples here since -- currently they're of the wrong kind to use in function args anyway. legalFIPrimArgTyCon dflags tc - = xopt Opt_UnliftedFFITypes dflags + | xopt Opt_UnliftedFFITypes dflags && isUnLiftedTyCon tc && not (isUnboxedTupleTyCon tc) + = True + | otherwise + = False legalFIPrimResultTyCon :: DynFlags -> TyCon -> Bool -- Check result type of 'foreign import prim'. Allow simple unlifted -- types and also unboxed tuple result types '... -> (# , , #)' legalFIPrimResultTyCon dflags tc - = xopt Opt_UnliftedFFITypes dflags + | xopt Opt_UnliftedFFITypes dflags && isUnLiftedTyCon tc && (isUnboxedTupleTyCon tc || case tyConPrimRep tc of -- Note [Marshalling VoidRep] VoidRep -> False _ -> True) + = True + | otherwise + = False \end{code} Note [Marshalling VoidRep] diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs index 8f6a773804..f8357825a7 100644 --- a/compiler/typecheck/TcValidity.lhs +++ b/compiler/typecheck/TcValidity.lhs @@ -46,7 +46,6 @@ import ListSetOps import SrcLoc import Outputable import FastString -import BasicTypes ( Arity ) import Control.Monad import Data.Maybe @@ -776,7 +775,9 @@ checkValidInstHead ctxt clas cls_args all tcInstHeadTyAppAllTyVars ty_args) (instTypeErr clas cls_args head_type_args_tyvars_msg) ; checkTc (xopt Opt_MultiParamTypeClasses dflags || - length ty_args == 1) -- Only count type arguments + length ty_args == 1 || -- Only count type arguments + (xopt Opt_NullaryTypeClasses dflags && + null ty_args)) (instTypeErr clas cls_args head_one_type_msg) } -- May not contain type family applications @@ -878,8 +879,8 @@ checkValidInstance ctxt hs_type ty else checkInstTermination inst_tys theta ; case (checkInstCoverage undecidable_ok clas theta inst_tys) of - Nothing -> return () -- Check succeeded - Just msg -> addErrTc (instTypeErr clas inst_tys msg) + IsValid -> return () -- Check succeeded + NotValid msg -> addErrTc (instTypeErr clas inst_tys msg) ; return (tvs, theta, clas, inst_tys) } @@ -1113,7 +1114,14 @@ checkValidTyFamInst mb_clsinfo fam_tc = setSrcSpan loc $ do { checkValidFamPats fam_tc tvs typats - -- The right-hand side is a tau type + -- The argument patterns, and RHS, are all boxed tau types + -- E.g Reject type family F (a :: k1) :: k2 + -- type instance F (forall a. a->a) = ... + -- type instance F Int# = ... + -- type instance F Int = forall a. a->a + -- type instance F Int = Int# + -- See Trac #9357 + ; mapM_ checkValidMonoType typats ; checkValidMonoType rhs -- We have a decidable instance unless otherwise permitted @@ -1163,26 +1171,18 @@ checkValidFamPats :: TyCon -> [TyVar] -> [Type] -> TcM () -- type instance F (T a) = a -- c) Have the right number of patterns checkValidFamPats fam_tc tvs ty_pats - = do { -- A family instance must have exactly the same number of type - -- parameters as the family declaration. You can't write - -- type family F a :: * -> * - -- type instance F Int y = y - -- because then the type (F Int) would be like (\y.y) - checkTc (length ty_pats == fam_arity) $ - wrongNumberOfParmsErr (fam_arity - length fam_kvs) -- report only types - ; mapM_ checkTyFamFreeness ty_pats + = ASSERT( length ty_pats == tyConArity fam_tc ) + -- A family instance must have exactly the same number of type + -- parameters as the family declaration. You can't write + -- type family F a :: * -> * + -- type instance F Int y = y + -- because then the type (F Int) would be like (\y.y) + -- But this is checked at the time the axiom is created + do { mapM_ checkTyFamFreeness ty_pats ; let unbound_tvs = filterOut (`elemVarSet` exactTyVarsOfTypes ty_pats) tvs ; checkTc (null unbound_tvs) (famPatErr fam_tc unbound_tvs ty_pats) } - where fam_arity = tyConArity fam_tc - (fam_kvs, _) = splitForAllTys (tyConKind fam_tc) - -wrongNumberOfParmsErr :: Arity -> SDoc -wrongNumberOfParmsErr exp_arity - = ptext (sLit "Number of parameters must match family declaration; expected") - <+> ppr exp_arity -- Ensure that no type family instances occur in a type. --- checkTyFamFreeness :: Type -> TcM () checkTyFamFreeness ty = checkTc (isTyFamFree ty) $ diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs index 29df06572b..9863b8d98f 100644 --- a/compiler/types/Class.lhs +++ b/compiler/types/Class.lhs @@ -17,7 +17,7 @@ The @Class@ datatype module Class ( Class, ClassOpItem, DefMeth (..), - ClassATItem, + ClassATItem(..), ClassMinimalDef, defMethSpecOfDefMeth, @@ -32,8 +32,7 @@ module Class ( #include "HsVersions.h" import {-# SOURCE #-} TyCon ( TyCon, tyConName, tyConUnique ) -import {-# SOURCE #-} TypeRep ( PredType ) -import CoAxiom +import {-# SOURCE #-} TypeRep ( Type, PredType ) import Var import Name import BasicTypes @@ -100,10 +99,10 @@ data DefMeth = NoDefMeth -- No default method | GenDefMeth Name -- A generic default method deriving Eq -type ClassATItem = (TyCon, -- See Note [Associated type tyvar names] - [CoAxBranch]) -- Default associated types from these templates - -- We can have more than one default per type; see - -- Note [Associated type defaults] in TcTyClsDecls +data ClassATItem + = ATI TyCon -- See Note [Associated type tyvar names] + (Maybe Type) -- Default associated type (if any) from this template + -- Note [Associated type defaults] type ClassMinimalDef = BooleanFormula Name -- Required methods @@ -115,9 +114,39 @@ defMethSpecOfDefMeth meth NoDefMeth -> NoDM DefMeth _ -> VanillaDM GenDefMeth _ -> GenericDM - \end{code} +Note [Associated type defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The following is an example of associated type defaults: + class C a where + data D a r + + type F x a b :: * + type F p q r = (p,q)->r -- Default + +Note that + + * The TyCons for the associated types *share type variables* with the + class, so that we can tell which argument positions should be + instantiated in an instance decl. (The first for 'D', the second + for 'F'.) + + * We can have default definitions only for *type* families, + not data families + + * In the default decl, the "patterns" should all be type variables, + but (in the source language) they don't need to be the same as in + the 'type' decl signature or the class. It's more like a + free-standing 'type instance' declaration. + + * HOWEVER, in the internal ClassATItem we rename the RHS to match the + tyConTyVars of the family TyCon. So in the example above we'd get + a ClassATItem of + ATI F ((x,a) -> b) + So the tyConTyVars of the family TyCon bind the free vars of + the default Type rhs + The @mkClass@ function fills in the indirect superclasses. \begin{code} @@ -198,7 +227,7 @@ classOpItems = classOpStuff classATs :: Class -> [TyCon] classATs (Class { classATStuff = at_stuff }) - = [tc | (tc, _) <- at_stuff] + = [tc | ATI tc _ <- at_stuff] classATItems :: Class -> [ClassATItem] classATItems = classATStuff diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index b33eae9e02..38f38ed50b 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -18,7 +18,7 @@ module Coercion ( -- ** Functions over coercions coVarKind, coVarRole, coercionType, coercionKind, coercionKinds, isReflCo, - isReflCo_maybe, coercionRole, + isReflCo_maybe, coercionRole, coercionKindRole, mkCoercionType, -- ** Constructing coercions @@ -104,8 +104,10 @@ import PrelNames ( funTyConKey, eqPrimTyConKey, eqReprPrimTyConKey ) import Control.Applicative import Data.Traversable (traverse, sequenceA) import FastString +import ListSetOps import qualified Data.Data as Data hiding ( TyCon ) +import Control.Arrow ( first ) \end{code} %************************************************************************ @@ -1792,10 +1794,23 @@ seqCos (co:cos) = seqCo co `seq` seqCos cos %* * %************************************************************************ +Note [Computing a coercion kind and role] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To compute a coercion's kind is straightforward: see coercionKind. +But to compute a coercion's role, in the case for NthCo we need +its kind as well. So if we have two separate functions (one for kinds +and one for roles) we can get exponentially bad behaviour, since each +NthCo node makes a separate call to coercionKind, which traverses the +sub-tree again. This was part of the problem in Trac #9233. + +Solution: compute both together; hence coercionKindRole. We keep a +separate coercionKind function because it's a bit more efficient if +the kind is all you want. + \begin{code} coercionType :: Coercion -> Type -coercionType co = case coercionKind co of - Pair ty1 ty2 -> mkCoercionType (coercionRole co) ty1 ty2 +coercionType co = case coercionKindRole co of + (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2 ------------------ -- | If it is the case that @@ -1827,11 +1842,10 @@ coercionKind co = go co go (InstCo aco ty) = go_app aco [ty] go (SubCo co) = go co go (AxiomRuleCo ax tys cos) = - case coaxrProves ax tys (map coercionKind cos) of + case coaxrProves ax tys (map go cos) of Just res -> res Nothing -> panic "coercionKind: Malformed coercion" - go_app :: Coercion -> [Type] -> Pair Type -- Collect up all the arguments and apply all at once -- See Note [Nested InstCos] @@ -1842,25 +1856,54 @@ coercionKind co = go co coercionKinds :: [Coercion] -> Pair [Type] coercionKinds tys = sequenceA $ map coercionKind tys -coercionRole :: Coercion -> Role -coercionRole = go +-- | Get a coercion's kind and role. +-- Why both at once? See Note [Computing a coercion kind and role] +coercionKindRole :: Coercion -> (Pair Type, Role) +coercionKindRole = go where - go (Refl r _) = r - go (TyConAppCo r _ _) = r - go (AppCo co _) = go co - go (ForAllCo _ co) = go co - go (CoVarCo cv) = coVarRole cv - go (AxiomInstCo ax _ _) = coAxiomRole ax - go (UnivCo r _ _) = r - go (SymCo co) = go co - go (TransCo co1 _) = go co1 -- same as go co2 - go (NthCo n co) = let Pair ty1 _ = coercionKind co - (tc, _) = splitTyConApp ty1 - in nthRole (coercionRole co) tc n - go (LRCo _ _) = Nominal - go (InstCo co _) = go co - go (SubCo _) = Representational - go (AxiomRuleCo c _ _) = coaxrRole c + go (Refl r ty) = (Pair ty ty, r) + go (TyConAppCo r tc cos) + = (mkTyConApp tc <$> (sequenceA $ map coercionKind cos), r) + go (AppCo co1 co2) + = let (tys1, r1) = go co1 in + (mkAppTy <$> tys1 <*> coercionKind co2, r1) + go (ForAllCo tv co) + = let (tys, r) = go co in + (mkForAllTy tv <$> tys, r) + go (CoVarCo cv) = (toPair $ coVarKind cv, coVarRole cv) + go co@(AxiomInstCo ax _ _) = (coercionKind co, coAxiomRole ax) + go (UnivCo r ty1 ty2) = (Pair ty1 ty2, r) + go (SymCo co) = first swap $ go co + go (TransCo co1 co2) + = let (tys1, r) = go co1 in + (Pair (pFst tys1) (pSnd $ coercionKind co2), r) + go (NthCo d co) + = let (Pair t1 t2, r) = go co + (tc1, args1) = splitTyConApp t1 + (_tc2, args2) = splitTyConApp t2 + in + ASSERT( tc1 == _tc2 ) + ((`getNth` d) <$> Pair args1 args2, nthRole r tc1 d) + go co@(LRCo {}) = (coercionKind co, Nominal) + go (InstCo co ty) = go_app co [ty] + go (SubCo co) = (coercionKind co, Representational) + go co@(AxiomRuleCo ax _ _) = (coercionKind co, coaxrRole ax) + + go_app :: Coercion -> [Type] -> (Pair Type, Role) + -- Collect up all the arguments and apply all at once + -- See Note [Nested InstCos] + go_app (InstCo co ty) tys = go_app co (ty:tys) + go_app co tys + = let (pair, r) = go co in + ((`applyTys` tys) <$> pair, r) + +-- | Retrieve the role from a coercion. +coercionRole :: Coercion -> Role +coercionRole = snd . coercionKindRole + -- There's not a better way to do this, because NthCo needs the *kind* + -- and role of its argument. Luckily, laziness should generally avoid + -- the need for computing kinds in other cases. + \end{code} Note [Nested InstCos] diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index fcf7cb443f..1308984f4f 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -46,7 +46,6 @@ import Coercion import CoAxiom import VarSet import VarEnv -import Module( isInteractiveModule ) import Name import UniqFM import Outputable @@ -381,23 +380,21 @@ identicalFamInst :: FamInst -> FamInst -> Bool -- Same LHS, *and* both instances are on the interactive command line -- Used for overriding in GHCi identicalFamInst (FamInst { fi_axiom = ax1 }) (FamInst { fi_axiom = ax2 }) - = isInteractiveModule (nameModule (coAxiomName ax1)) - && isInteractiveModule (nameModule (coAxiomName ax2)) - && coAxiomTyCon ax1 == coAxiomTyCon ax2 + = coAxiomTyCon ax1 == coAxiomTyCon ax2 && brListLength brs1 == brListLength brs2 - && and (brListZipWith identical_ax_branch brs1 brs2) - where brs1 = coAxiomBranches ax1 - brs2 = coAxiomBranches ax2 - identical_ax_branch br1 br2 - = length tvs1 == length tvs2 - && length lhs1 == length lhs2 - && and (zipWith (eqTypeX rn_env) lhs1 lhs2) - where - tvs1 = coAxBranchTyVars br1 - tvs2 = coAxBranchTyVars br2 - lhs1 = coAxBranchLHS br1 - lhs2 = coAxBranchLHS br2 - rn_env = rnBndrs2 (mkRnEnv2 emptyInScopeSet) tvs1 tvs2 + && and (brListZipWith identical_branch brs1 brs2) + where + brs1 = coAxiomBranches ax1 + brs2 = coAxiomBranches ax2 + + identical_branch br1 br2 + = isJust (tcMatchTys tvs1 lhs1 lhs2) + && isJust (tcMatchTys tvs2 lhs2 lhs1) + where + tvs1 = mkVarSet (coAxBranchTyVars br1) + tvs2 = mkVarSet (coAxBranchTyVars br2) + lhs1 = coAxBranchLHS br1 + lhs2 = coAxBranchLHS br2 \end{code} %************************************************************************ @@ -644,7 +641,7 @@ lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom }) (ppr tpl_tvs <+> ppr tpl_tys) ) -- Unification will break badly if the variables overlap -- They shouldn't because we allocate separate uniques for them - if compatibleBranches (coAxiomSingleBranch old_axiom) (new_branch) + if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch then Nothing else Just noSubst -- Note [Family instance overlap conflicts] @@ -672,7 +669,7 @@ Note [Family instance overlap conflicts] -- Might be a one-way match or a unifier type MatchFun = FamInst -- The FamInst template -> TyVarSet -> [Type] -- fi_tvs, fi_tys of that FamInst - -> [Type] -- Target to match against + -> [Type] -- Target to match against -> Maybe TvSubst lookup_fam_inst_env' -- The worker, local to this module @@ -732,9 +729,9 @@ lookup_fam_inst_env -- The worker, local to this module -- Precondition: the tycon is saturated (or over-saturated) -lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys = - lookup_fam_inst_env' match_fun home_ie fam tys ++ - lookup_fam_inst_env' match_fun pkg_ie fam tys +lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys + = lookup_fam_inst_env' match_fun home_ie fam tys + ++ lookup_fam_inst_env' match_fun pkg_ie fam tys \end{code} @@ -750,16 +747,18 @@ which you can't do in Haskell!): Then looking up (F (Int,Bool) Char) will return a FamInstMatch (FPair, [Int,Bool,Char]) - The "extra" type argument [Char] just stays on the end. -Because of eta-reduction of data family instances (see -Note [Eta reduction for data family axioms] in TcInstDecls), we must -handle data families and type families separately here. All instances -of a type family must have the same arity, so we can precompute the split -between the match_tys and the overflow tys. This is done in pre_rough_split_tys. -For data instances, though, we need to re-split for each instance, because -the breakdown might be different. +We handle data families and type families separately here: + + * For type families, all instances of a type family must have the + same arity, so we can precompute the split between the match_tys + and the overflow tys. This is done in pre_rough_split_tys. + + * For data family instances, though, we need to re-split for each + instance, because the breakdown might be different for each + instance. Why? Because of eta reduction; see Note [Eta reduction + for data family axioms] \begin{code} diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 176f189922..708fef1cfe 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -10,12 +10,13 @@ The bits common to TcInstDcls and TcDeriv. {-# LANGUAGE CPP, DeriveDataTypeable #-} module InstEnv ( - DFunId, OverlapFlag(..), InstMatch, ClsInstLookupResult, - ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, + DFunId, InstMatch, ClsInstLookupResult, + OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, + ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, instanceHead, instanceSig, mkLocalInstance, mkImportedInstance, instanceDFunId, tidyClsInstDFun, instanceRoughTcs, - InstEnv, emptyInstEnv, extendInstEnv, overwriteInstEnv, + InstEnv, emptyInstEnv, extendInstEnv, deleteFromInstEnv, identicalInstHead, extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv', lookupInstEnv, instEnvElts, classInstances, orphNamesOfClsInst, instanceBindFun, instanceCantMatch, roughMatchTcs @@ -159,7 +160,8 @@ pprInstance :: ClsInst -> SDoc -- Prints the ClsInst as an instance declaration pprInstance ispec = hang (pprInstanceHdr ispec) - 2 (ptext (sLit "--") <+> pprDefinedAt (getName ispec)) + 2 (vcat [ ptext (sLit "--") <+> pprDefinedAt (getName ispec) + , ifPprDebug (ppr (is_dfun ispec)) ]) -- * pprInstanceHdr is used in VStudio to populate the ClassView tree pprInstanceHdr :: ClsInst -> SDoc @@ -419,26 +421,22 @@ extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) where add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts) -overwriteInstEnv :: InstEnv -> ClsInst -> InstEnv -overwriteInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm, is_tys = tys }) - = addToUFM_C add inst_env cls_nm (ClsIE [ins_item]) +deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv +deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) + = adjustUFM adjust inst_env cls_nm where - add (ClsIE cur_insts) _ = ClsIE (replaceInst cur_insts) - - rough_tcs = roughMatchTcs tys - replaceInst [] = [ins_item] - replaceInst (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs - , is_tys = tpl_tys }) : rest) - -- Fast check for no match, uses the "rough match" fields - | instanceCantMatch rough_tcs mb_tcs - = item : replaceInst rest - - | let tpl_tv_set = mkVarSet tpl_tvs - , Just _ <- tcMatchTys tpl_tv_set tpl_tys tys - = ins_item : rest - - | otherwise - = item : replaceInst rest + adjust (ClsIE items) = ClsIE (filterOut (identicalInstHead ins_item) items) + +identicalInstHead :: ClsInst -> ClsInst -> Bool +-- ^ True when when the instance heads are the same +-- e.g. both are Eq [(a,b)] +-- Obviously should be insenstive to alpha-renaming +identicalInstHead (ClsInst { is_cls_nm = cls_nm1, is_tcs = rough1, is_tvs = tvs1, is_tys = tys1 }) + (ClsInst { is_cls_nm = cls_nm2, is_tcs = rough2, is_tvs = tvs2, is_tys = tys2 }) + = cls_nm1 == cls_nm2 + && not (instanceCantMatch rough1 rough2) -- Fast check for no match, uses the "rough match" fields + && isJust (tcMatchTys (mkVarSet tvs1) tys1 tys2) + && isJust (tcMatchTys (mkVarSet tvs2) tys2 tys1) \end{code} @@ -452,6 +450,54 @@ overwriteInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm, is_tys = tys } the env is kept ordered, the first match must be the only one. The thing we are looking up can have an arbitrary "flexi" part. +Note [Rules for instance lookup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These functions implement the carefully-written rules in the user +manual section on "overlapping instances". At risk of duplication, +here are the rules. If the rules change, change this text and the +user manual simultaneously. The link may be this: +http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-overlap + +The willingness to be overlapped or incoherent is a property of the +instance declaration itself, controlled as follows: + + * An instance is "incoherent" + if it has an INCOHERENT pragma, or + if it appears in a module compiled with -XIncoherentInstances. + + * An instance is "overlappable" + if it has an OVERLAPPABLE or OVERLAPS pragma, or + if it appears in a module compiled with -XOverlappingInstances, or + if the instance is incoherent. + + * An instance is "overlapping" + if it has an OVERLAPPING or OVERLAPS pragma, or + if it appears in a module compiled with -XOverlappingInstances, or + if the instance is incoherent. + compiled with -XOverlappingInstances. + +Now suppose that, in some client module, we are searching for an instance +of the target constraint (C ty1 .. tyn). The search works like this. + + * Find all instances I that match the target constraint; that is, the + target constraint is a substitution instance of I. These instance + declarations are the candidates. + + * Find all non-candidate instances that unify with the target + constraint. Such non-candidates instances might match when the + target constraint is further instantiated. If all of them are + incoherent, proceed; if not, the search fails. + + * Eliminate any candidate IX for which both of the following hold: + * There is another candidate IY that is strictly more specific; + that is, IY is a substitution instance of IX but not vice versa. + + * Either IX is overlappable or IY is overlapping. + + * If only one candidate remains, pick it. Otherwise if all remaining + candidates are incoherent, pick an arbitrary candidate. Otherwise fail. + + \begin{code} type DFunInstType = Maybe Type -- Just ty => Instantiate with this type @@ -535,8 +581,8 @@ lookupInstEnv' ie cls tys = find ((item, map (lookup_tv subst) tpl_tvs) : ms) us rest -- Does not match, so next check whether the things unify - -- See Note [Overlapping instances] and Note [Incoherent Instances] - | Incoherent _ <- oflag + -- See Note [Overlapping instances] and Note [Incoherent instances] + | Incoherent <- overlapMode oflag = find ms us rest | otherwise @@ -565,23 +611,30 @@ lookupInstEnv' ie cls tys lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env -> Class -> [Type] -- What we are looking for -> ClsInstLookupResult - +-- ^ See Note [Rules for instance lookup] lookupInstEnv (pkg_ie, home_ie) cls tys - = (safe_matches, all_unifs, safe_fail) + = (final_matches, final_unifs, safe_fail) where (home_matches, home_unifs) = lookupInstEnv' home_ie cls tys (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie cls tys all_matches = home_matches ++ pkg_matches all_unifs = home_unifs ++ pkg_unifs pruned_matches = foldr insert_overlapping [] all_matches - (safe_matches, safe_fail) = if length pruned_matches == 1 - then check_safe (head pruned_matches) all_matches - else (pruned_matches, False) -- Even if the unifs is non-empty (an error situation) -- we still prune the matches, so that the error message isn't -- misleading (complaining of multiple matches when some should be -- overlapped away) + (final_matches, safe_fail) + = case pruned_matches of + [match] -> check_safe match all_matches + _ -> (pruned_matches, False) + + -- If the selected match is incoherent, discard all unifiers + final_unifs = case final_matches of + (m:_) | is_incoherent m -> [] + _ -> all_unifs + -- NOTE [Safe Haskell isSafeOverlap] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- We restrict code compiled in 'Safe' mode from overriding code @@ -605,7 +658,7 @@ lookupInstEnv (pkg_ie, home_ie) cls tys if inSameMod x then go bad unchecked else go (i:bad) unchecked - + inSameMod b = let na = getName $ getName inst la = isInternalName na @@ -614,64 +667,72 @@ lookupInstEnv (pkg_ie, home_ie) cls tys in (la && lb) || (nameModule na == nameModule nb) --------------- +is_incoherent :: InstMatch -> Bool +is_incoherent (inst, _) = overlapMode (is_flag inst) == Incoherent + --------------- insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch] --- Add a new solution, knocking out strictly less specific ones +-- ^ Add a new solution, knocking out strictly less specific ones +-- See Note [Rules for instance lookup] insert_overlapping new_item [] = [new_item] -insert_overlapping new_item (item:items) - | new_beats_old && old_beats_new = item : insert_overlapping new_item items - -- Duplicate => keep both for error report - | new_beats_old = insert_overlapping new_item items - -- Keep new one - | old_beats_new = item : items - -- Keep old one - | incoherent new_item = item : items -- note [Incoherent instances] - -- Keep old one - | incoherent item = new_item : items - -- Keep new one - | otherwise = item : insert_overlapping new_item items - -- Keep both +insert_overlapping new_item (old_item : old_items) + | new_beats_old -- New strictly overrides old + , not old_beats_new + , new_item `can_override` old_item + = insert_overlapping new_item old_items + + | old_beats_new -- Old strictly overrides new + , not new_beats_old + , old_item `can_override` new_item + = old_item : old_items + + -- Discard incoherent instances; see Note [Incoherent instances] + | is_incoherent old_item -- Old is incoherent; discard it + = insert_overlapping new_item old_items + | is_incoherent new_item -- New is incoherent; discard it + = old_item : old_items + + -- Equal or incomparable, and neither is incoherent; keep both + | otherwise + = old_item : insert_overlapping new_item old_items where - new_beats_old = new_item `beats` item - old_beats_new = item `beats` new_item - - incoherent (inst, _) = case is_flag inst of Incoherent _ -> True - _ -> False - - (instA, _) `beats` (instB, _) - = overlap_ok && - isJust (tcMatchTys (mkVarSet (is_tvs instB)) (is_tys instB) (is_tys instA)) - -- A beats B if A is more specific than B, - -- (ie. if B can be instantiated to match A) - -- and overlap is permitted - where - -- Overlap permitted if *either* instance permits overlap - -- This is a change (Trac #3877, Dec 10). It used to - -- require that instB (the less specific one) permitted overlap. - overlap_ok = case (is_flag instA, is_flag instB) of - (NoOverlap _, NoOverlap _) -> False - _ -> True + + new_beats_old = new_item `more_specific_than` old_item + old_beats_new = old_item `more_specific_than` new_item + + -- `instB` can be instantiated to match `instA` + -- or the two are equal + (instA,_) `more_specific_than` (instB,_) + = isJust (tcMatchTys (mkVarSet (is_tvs instB)) + (is_tys instB) (is_tys instA)) + + (instA, _) `can_override` (instB, _) + = hasOverlappingFlag (overlapMode (is_flag instA)) + || hasOverlappableFlag (overlapMode (is_flag instB)) + -- Overlap permitted if either the more specific instance + -- is marked as overlapping, or the more general one is + -- marked as overlappable. + -- Latest change described in: Trac #9242. + -- Previous change: Trac #3877, Dec 10. \end{code} Note [Incoherent instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -For some classes, the choise of a particular instance does not matter, any one +For some classes, the choice of a particular instance does not matter, any one is good. E.g. consider class D a b where { opD :: a -> b -> String } instance D Int b where ... instance D a Int where ... - g (x::Int) = opD x x + g (x::Int) = opD x x -- Wanted: D Int Int For such classes this should work (without having to add an "instance D Int Int", and using -XOverlappingInstances, which would then work). This is what -XIncoherentInstances is for: Telling GHC "I don't care which instance you use; if you can use one, use it." - -Should this logic only work when all candidates have the incoherent flag, or +Should this logic only work when *all* candidates have the incoherent flag, or even when all but one have it? The right choice is the latter, which can be justified by comparing the behaviour with how -XIncoherentInstances worked when it was only about the unify-check (note [Overlapping instances]): @@ -682,7 +743,7 @@ Example: instance [incoherent] [Int] b c instance [incoherent] C a Int c Thanks to the incoherent flags, - foo :: ([a],b,Int) + [Wanted] C [a] b Int works: Only instance one matches, the others just unify, but are marked incoherent. diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index ed68aeab2f..5e51e08967 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -4,19 +4,12 @@ \begin{code} {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Kind ( -- * Main data type SuperKind, Kind, typeKind, - -- Kinds - anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, + -- Kinds + anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind, constraintKind, mkArrowKind, mkArrowKinds, -- Kind constructors... @@ -24,9 +17,9 @@ module Kind ( unliftedTypeKindTyCon, constraintKindTyCon, -- Super Kinds - superKind, superKindTyCon, - - pprKind, pprParendKind, + superKind, superKindTyCon, + + pprKind, pprParendKind, -- ** Deconstructing Kinds kindAppResult, synTyConResKind, @@ -42,7 +35,7 @@ module Kind ( okArrowArgKind, okArrowResultKind, isSubOpenTypeKind, isSubOpenTypeKindKey, - isSubKind, isSubKindCon, + isSubKind, isSubKindCon, tcIsSubKind, tcIsSubKindCon, defaultKind, defaultKind_maybe, @@ -67,33 +60,33 @@ import FastString \end{code} %************************************************************************ -%* * - Functions over Kinds -%* * +%* * + Functions over Kinds +%* * %************************************************************************ Note [Kind Constraint and kind *] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The kind Constraint is the kind of classes and other type constraints. -The special thing about types of kind Constraint is that +The special thing about types of kind Constraint is that * They are displayed with double arrow: f :: Ord a => a -> a * They are implicitly instantiated at call sites; so the type inference engine inserts an extra argument of type (Ord a) at every call site to f. -However, once type inference is over, there is *no* distinction between +However, once type inference is over, there is *no* distinction between Constraint and *. Indeed we can have coercions between the two. Consider class C a where op :: a -> a -For this single-method class we may generate a newtype, which in turn +For this single-method class we may generate a newtype, which in turn generates an axiom witnessing Ord a ~ (a -> a) so on the left we have Constraint, and on the right we have *. See Trac #7451. Bottom line: although '*' and 'Constraint' are distinct TyCons, with -distinct uniques, they are treated as equal at all times except +distinct uniques, they are treated as equal at all times except during type inference. Hence cmpTc treats them as equal. \begin{code} @@ -129,9 +122,9 @@ splitKindFunTysN n (FunTy a r) = case splitKindFunTysN (n-1) r of (as, k) -> (a:as, k) splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k) --- | Find the result 'Kind' of a type synonym, +-- | Find the result 'Kind' of a type synonym, -- after applying it to its 'arity' number of type variables --- Actually this function works fine on data types too, +-- Actually this function works fine on data types too, -- but they'd always return '*', so we never need to ask synTyConResKind :: TyCon -> Kind synTyConResKind tycon = kindAppResult (ptext (sLit "synTyConResKind") <+> ppr tycon) @@ -212,7 +205,7 @@ isSubOpenTypeKindKey uniq || uniq == constraintKindTyConKey -- Needed for error (Num a) "blah" -- and so that (Ord a -> Eq a) is well-kinded -- and so that (# Eq a, Ord b #) is well-kinded - -- See Note [Kind Constraint and kind *] + -- See Note [Kind Constraint and kind *] -- | Is this a kind (i.e. a type-of-types)? isKind :: Kind -> Bool @@ -243,7 +236,7 @@ isSubKindCon :: TyCon -> TyCon -> Bool -- See Note [GHC Formalism] in coreSyn/CoreLint.lhs isSubKindCon kc1 kc2 | kc1 == kc2 = True - | isOpenTypeKindCon kc2 = isSubOpenTypeKindCon kc1 + | isOpenTypeKindCon kc2 = isSubOpenTypeKindCon kc1 | isConstraintKindCon kc1 = isLiftedTypeKindCon kc2 | isLiftedTypeKindCon kc1 = isConstraintKindCon kc2 -- See Note [Kind Constraint and kind *] @@ -287,11 +280,11 @@ defaultKind_maybe :: Kind -> Maybe Kind -- simple (* or *->* etc). So generic type variables (other than -- built-in constants like 'error') always have simple kinds. This is important; -- consider --- f x = True +-- f x = True -- We want f to get type --- f :: forall (a::*). a -> Bool --- Not --- f :: forall (a::ArgKind). a -> Bool +-- f :: forall (a::*). a -> Bool +-- Not +-- f :: forall (a::ArgKind). a -> Bool -- because that would allow a call like (f 3#) as well as (f True), -- and the calling conventions differ. -- This defaulting is done in TcMType.zonkTcTyVarBndr. diff --git a/compiler/types/OptCoercion.lhs b/compiler/types/OptCoercion.lhs index dc7ab781ff..6eccf42588 100644 --- a/compiler/types/OptCoercion.lhs +++ b/compiler/types/OptCoercion.lhs @@ -27,7 +27,6 @@ import VarEnv import StaticFlags ( opt_NoOptCoercion ) import Outputable import Pair -import Maybes import FastString import Util import Unify @@ -59,13 +58,29 @@ because now the co_B1 (which is really free) has been captured, and subsequent substitutions will go wrong. That's why we can't use mkCoPredTy in the ForAll case, where this note appears. +Note [Optimising coercion optimisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Looking up a coercion's role or kind is linear in the size of the +coercion. Thus, doing this repeatedly during the recursive descent +of coercion optimisation is disastrous. We must be careful to avoid +doing this if at all possible. + +Because it is generally easy to know a coercion's components' roles +from the role of the outer coercion, we pass down the known role of +the input in the algorithm below. We also keep functions opt_co2 +and opt_co3 separate from opt_co4, so that the former two do Phantom +checks that opt_co4 can avoid. This is a big win because Phantom coercions +rarely appear within non-phantom coercions -- only in some TyConAppCos +and some AxiomInstCos. We handle these cases specially by calling +opt_co2. + \begin{code} optCoercion :: CvSubst -> Coercion -> NormalCo -- ^ optCoercion applies a substitution to a coercion, -- *and* optimises it to reduce its size optCoercion env co | opt_NoOptCoercion = substCo env co - | otherwise = opt_co env False Nothing co + | otherwise = opt_co1 env False co type NormalCo = Coercion -- Invariants: @@ -76,13 +91,17 @@ type NormalCo = Coercion type NormalNonIdCo = NormalCo -- Extra invariant: not the identity -opt_co, opt_co' :: CvSubst - -> Bool -- True <=> return (sym co) - -> Maybe Role -- Nothing <=> don't change; otherwise, change - -- INVARIANT: the change is always a *downgrade* - -> Coercion - -> NormalCo -opt_co = opt_co' +-- | Do we apply a @sym@ to the result? +type SymFlag = Bool + +-- | Do we force the result to be representational? +type ReprFlag = Bool + +-- | Optimize a coercion, making no assumptions. +opt_co1 :: CvSubst + -> SymFlag + -> Coercion -> NormalCo +opt_co1 env sym co = opt_co2 env sym (coercionRole co) co {- opt_co env sym co = pprTrace "opt_co {" (ppr sym <+> ppr co $$ ppr env) $ @@ -108,111 +127,123 @@ opt_co env sym co | otherwise = substCo env co -} -opt_co' env _ mrole (Refl r ty) = Refl (mrole `orElse` r) (substTy env ty) -opt_co' env sym mrole co - | mrole == Just Phantom - || coercionRole co == Phantom - , Pair ty1 ty2 <- coercionKind co - = if sym - then opt_univ env Phantom ty2 ty1 - else opt_univ env Phantom ty1 ty2 - -opt_co' env sym mrole (SymCo co) = opt_co env (not sym) mrole co -opt_co' env sym mrole (TyConAppCo r tc cos) - = case mrole of - Nothing -> mkTyConAppCo r tc (map (opt_co env sym Nothing) cos) - Just r' -> mkTyConAppCo r' tc (zipWith (opt_co env sym) - (map Just (tyConRolesX r' tc)) cos) -opt_co' env sym mrole (AppCo co1 co2) = mkAppCo (opt_co env sym mrole co1) - (opt_co env sym Nothing co2) -opt_co' env sym mrole (ForAllCo tv co) +-- See Note [Optimising coercion optimisation] +-- | Optimize a coercion, knowing the coercion's role. No other assumptions. +opt_co2 :: CvSubst + -> SymFlag + -> Role -- ^ The role of the input coercion + -> Coercion -> NormalCo +opt_co2 env sym Phantom co = opt_phantom env sym co +opt_co2 env sym r co = opt_co3 env sym Nothing r co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a coercion, knowing the coercion's non-Phantom role. +opt_co3 :: CvSubst -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo +opt_co3 env sym (Just Phantom) _ co = opt_phantom env sym co +opt_co3 env sym (Just Representational) r co = opt_co4 env sym True r co + -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore +opt_co3 env sym _ r co = opt_co4 env sym False r co + + +-- See Note [Optimising coercion optimisation] +-- | Optimize a non-phantom coercion. +opt_co4 :: CvSubst -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo + +opt_co4 env _ rep r (Refl _r ty) + = ASSERT( r == _r ) + Refl (chooseRole rep r) (substTy env ty) + +opt_co4 env sym rep r (SymCo co) = opt_co4 env (not sym) rep r co + +opt_co4 env sym rep r g@(TyConAppCo _r tc cos) + = ASSERT( r == _r ) + case (rep, r) of + (True, Nominal) -> + mkTyConAppCo Representational tc + (zipWith3 (opt_co3 env sym) + (map Just (tyConRolesX Representational tc)) + (repeat Nominal) + cos) + (False, Nominal) -> + mkTyConAppCo Nominal tc (map (opt_co4 env sym False Nominal) cos) + (_, Representational) -> + -- must use opt_co2 here, because some roles may be P + -- See Note [Optimising coercion optimisation] + mkTyConAppCo r tc (zipWith (opt_co2 env sym) + (tyConRolesX r tc) -- the current roles + cos) + (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) + +opt_co4 env sym rep r (AppCo co1 co2) = mkAppCo (opt_co4 env sym rep r co1) + (opt_co4 env sym False Nominal co2) +opt_co4 env sym rep r (ForAllCo tv co) = case substTyVarBndr env tv of - (env', tv') -> mkForAllCo tv' (opt_co env' sym mrole co) + (env', tv') -> mkForAllCo tv' (opt_co4 env' sym rep r co) -- Use the "mk" functions to check for nested Refls -opt_co' env sym mrole (CoVarCo cv) +opt_co4 env sym rep r (CoVarCo cv) | Just co <- lookupCoVar env cv - = opt_co (zapCvSubstEnv env) sym mrole co + = opt_co4 (zapCvSubstEnv env) sym rep r co | Just cv1 <- lookupInScope (getCvInScope env) cv - = ASSERT( isCoVar cv1 ) wrapRole mrole cv_role $ wrapSym sym (CoVarCo cv1) + = ASSERT( isCoVar cv1 ) wrapRole rep r $ wrapSym sym (CoVarCo cv1) -- cv1 might have a substituted kind! | otherwise = WARN( True, ptext (sLit "opt_co: not in scope:") <+> ppr cv $$ ppr env) ASSERT( isCoVar cv ) - wrapRole mrole cv_role $ wrapSym sym (CoVarCo cv) - where cv_role = coVarRole cv + wrapRole rep r $ wrapSym sym (CoVarCo cv) -opt_co' env sym mrole (AxiomInstCo con ind cos) +opt_co4 env sym rep r (AxiomInstCo con ind cos) -- Do *not* push sym inside top-level axioms -- e.g. if g is a top-level axiom -- g a : f a ~ a -- then (sym (g ty)) /= g (sym ty) !! - = wrapRole mrole (coAxiomRole con) $ + = ASSERT( r == coAxiomRole con ) + wrapRole rep (coAxiomRole con) $ wrapSym sym $ - AxiomInstCo con ind (map (opt_co env False Nothing) cos) + -- some sub-cos might be P: use opt_co2 + -- See Note [Optimising coercion optimisation] + AxiomInstCo con ind (zipWith (opt_co2 env False) + (coAxBranchRoles (coAxiomNthBranch con ind)) + cos) -- Note that the_co does *not* have sym pushed into it -opt_co' env sym mrole (UnivCo r oty1 oty2) - = opt_univ env role a b +opt_co4 env sym rep r (UnivCo _r oty1 oty2) + = ASSERT( r == _r ) + opt_univ env (chooseRole rep r) a b where (a,b) = if sym then (oty2,oty1) else (oty1,oty2) - role = mrole `orElse` r -opt_co' env sym mrole (TransCo co1 co2) - | sym = opt_trans in_scope opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g - | otherwise = opt_trans in_scope opt_co1 opt_co2 +opt_co4 env sym rep r (TransCo co1 co2) + -- sym (g `o` h) = sym h `o` sym g + | sym = opt_trans in_scope co2' co1' + | otherwise = opt_trans in_scope co1' co2' where - opt_co1 = opt_co env sym mrole co1 - opt_co2 = opt_co env sym mrole co2 + co1' = opt_co4 env sym rep r co1 + co2' = opt_co4 env sym rep r co2 in_scope = getCvInScope env --- NthCo roles are fiddly! -opt_co' env sym mrole (NthCo n (TyConAppCo _ _ cos)) - = opt_co env sym mrole (getNth cos n) -opt_co' env sym mrole (NthCo n co) - | TyConAppCo _ _tc cos <- co' - , isDecomposableTyCon tc -- Not synonym families - = ASSERT( n < length cos ) - ASSERT( _tc == tc ) - let resultCo = cos !! n - resultRole = coercionRole resultCo in - case (mrole, resultRole) of - -- if we just need an R coercion, try to propagate the SubCo again: - (Just Representational, Nominal) -> opt_co (zapCvSubstEnv env) False mrole resultCo - _ -> resultCo - - | otherwise - = wrap_role $ NthCo n co' - - where - wrap_role wrapped = wrapRole mrole (coercionRole wrapped) wrapped - - tc = tyConAppTyCon $ pFst $ coercionKind co - co' = opt_co env sym mrole' co - mrole' = case mrole of - Just Representational - | Representational <- nthRole Representational tc n - -> Just Representational - _ -> Nothing +opt_co4 env sym rep r co@(NthCo {}) = opt_nth_co env sym rep r co -opt_co' env sym mrole (LRCo lr co) +opt_co4 env sym rep r (LRCo lr co) | Just pr_co <- splitAppCo_maybe co - = opt_co env sym mrole (pickLR lr pr_co) + = ASSERT( r == Nominal ) + opt_co4 env sym rep Nominal (pickLR lr pr_co) | Just pr_co <- splitAppCo_maybe co' - = if mrole == Just Representational - then opt_co (zapCvSubstEnv env) False mrole (pickLR lr pr_co) + = ASSERT( r == Nominal ) + if rep + then opt_co4 (zapCvSubstEnv env) False True Nominal (pickLR lr pr_co) else pickLR lr pr_co | otherwise - = wrapRole mrole Nominal $ LRCo lr co' + = wrapRole rep Nominal $ LRCo lr co' where - co' = opt_co env sym Nothing co + co' = opt_co4 env sym False Nominal co -opt_co' env sym mrole (InstCo co ty) +opt_co4 env sym rep r (InstCo co ty) -- See if the first arg is already a forall -- ...then we can just extend the current substitution | Just (tv, co_body) <- splitForAllCo_maybe co - = opt_co (extendTvSubst env tv ty') sym mrole co_body + = opt_co4 (extendTvSubst env tv ty') sym rep r co_body -- See if it is a forall after optimization -- If so, do an inefficient one-variable substitution @@ -221,22 +252,34 @@ opt_co' env sym mrole (InstCo co ty) | otherwise = InstCo co' ty' where - co' = opt_co env sym mrole co + co' = opt_co4 env sym rep r co ty' = substTy env ty -opt_co' env sym _ (SubCo co) = opt_co env sym (Just Representational) co +opt_co4 env sym _ r (SubCo co) + = ASSERT( r == Representational ) + opt_co4 env sym True Nominal co -- XXX: We could add another field to CoAxiomRule that -- would allow us to do custom simplifications. -opt_co' env sym mrole (AxiomRuleCo co ts cs) = - wrapRole mrole (coaxrRole co) $ +opt_co4 env sym rep r (AxiomRuleCo co ts cs) + = ASSERT( r == coaxrRole co ) + wrapRole rep r $ wrapSym sym $ AxiomRuleCo co (map (substTy env) ts) - (zipWith (opt_co env False) (map Just (coaxrAsmpRoles co)) cs) - + (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs) ------------- +-- | Optimize a phantom coercion. The input coercion may not necessarily +-- be a phantom, but the output sure will be. +opt_phantom :: CvSubst -> SymFlag -> Coercion -> NormalCo +opt_phantom env sym co + = if sym + then opt_univ env Phantom ty2 ty1 + else opt_univ env Phantom ty1 ty2 + where + Pair ty1 ty2 = coercionKind co + opt_univ :: CvSubst -> Role -> Type -> Type -> Coercion opt_univ env role oty1 oty2 | Just (tc1, tys1) <- splitTyConApp_maybe oty1 @@ -263,6 +306,45 @@ opt_univ env role oty1 oty2 = mkUnivCo role (substTy env oty1) (substTy env oty2) ------------- +-- NthCo must be handled separately, because it's the one case where we can't +-- tell quickly what the component coercion's role is from the containing +-- coercion. To avoid repeated coercionRole calls as opt_co1 calls opt_co2, +-- we just look for nested NthCo's, which can happen in practice. +opt_nth_co :: CvSubst -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo +opt_nth_co env sym rep r = go [] + where + go ns (NthCo n co) = go (n:ns) co + -- previous versions checked if the tycon is decomposable. This + -- is redundant, because a non-decomposable tycon under an NthCo + -- is entirely bogus. See docs/core-spec/core-spec.pdf. + go ns co + = opt_nths ns co + + -- input coercion is *not* yet sym'd or opt'd + opt_nths [] co = opt_co4 env sym rep r co + opt_nths (n:ns) (TyConAppCo _ _ cos) = opt_nths ns (cos `getNth` n) + + -- here, the co isn't a TyConAppCo, so we opt it, hoping to get + -- a TyConAppCo as output. We don't know the role, so we use + -- opt_co1. This is slightly annoying, because opt_co1 will call + -- coercionRole, but as long as we don't have a long chain of + -- NthCo's interspersed with some other coercion former, we should + -- be OK. + opt_nths ns co = opt_nths' ns (opt_co1 env sym co) + + -- input coercion *is* sym'd and opt'd + opt_nths' [] co + = if rep && (r == Nominal) + -- propagate the SubCo: + then opt_co4 (zapCvSubstEnv env) False True r co + else co + opt_nths' (n:ns) (TyConAppCo _ _ cos) = opt_nths' ns (cos `getNth` n) + opt_nths' ns co = wrapRole rep r (mk_nths ns co) + + mk_nths [] co = co + mk_nths (n:ns) co = mk_nths ns (mkNthCo n co) + +------------- opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] opt_transList is = zipWith (opt_trans is) @@ -427,11 +509,11 @@ opt_trans_rule is co1 co2 role = coercionRole co1 -- should be the same as coercionRole co2! opt_trans_rule _ co1 co2 -- Identity rule - | Pair ty1 _ <- coercionKind co1 + | (Pair ty1 _, r) <- coercionKindRole co1 , Pair _ ty2 <- coercionKind co2 , ty1 `eqType` ty2 = fireTransRule "RedTypeDirRefl" co1 co2 $ - Refl (coercionRole co1) ty2 + Refl r ty2 opt_trans_rule _ _ _ = Nothing @@ -494,16 +576,24 @@ checkAxInstCo (AxiomInstCo ax ind cos) checkAxInstCo _ = Nothing ----------- -wrapSym :: Bool -> Coercion -> Coercion +wrapSym :: SymFlag -> Coercion -> Coercion wrapSym sym co | sym = SymCo co | otherwise = co -wrapRole :: Maybe Role -- desired - -> Role -- current +-- | Conditionally set a role to be representational +wrapRole :: ReprFlag + -> Role -- ^ current role -> Coercion -> Coercion -wrapRole Nothing _ = id -wrapRole (Just desired) current = downgradeRole desired current - +wrapRole False _ = id +wrapRole True current = downgradeRole Representational current + +-- | If we require a representational role, return that. Otherwise, +-- return the "default" role provided. +chooseRole :: ReprFlag + -> Role -- ^ "default" role + -> Role +chooseRole True _ = Representational +chooseRole _ r = r ----------- -- takes two tyvars and builds env'ts to map them to the same tyvar substTyVarBndr2 :: CvSubst -> TyVar -> TyVar @@ -570,8 +660,7 @@ etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion) etaAppCo_maybe co | Just (co1,co2) <- splitAppCo_maybe co = Just (co1,co2) - | Nominal <- coercionRole co - , Pair ty1 ty2 <- coercionKind co + | (Pair ty1 ty2, Nominal) <- coercionKindRole co , Just (_,t1) <- splitAppTy_maybe ty1 , Just (_,t2) <- splitAppTy_maybe ty2 , typeKind t1 `eqType` typeKind t2 -- Note [Eta for AppCo] diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index d57ce12e26..65b5645d74 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -183,6 +183,9 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs It has an AlgTyConParent of FamInstTyCon T [Int] ax_ti +* The axiom ax_ti may be eta-reduced; see + Note [Eta reduction for data family axioms] in TcInstDcls + * The data contructor T2 has a wrapper (which is what the source-level "T2" invokes): @@ -576,11 +579,14 @@ data TyConParent -- 3) A 'CoTyCon' identifying the representation -- type with the type instance family | FamInstTyCon -- See Note [Data type families] - (CoAxiom Unbranched) -- The coercion constructor, - -- always of kind T ty1 ty2 ~ R:T a b c - -- where T is the family TyCon, - -- and R:T is the representation TyCon (ie this one) - -- and a,b,c are the tyConTyVars of this TyCon + (CoAxiom Unbranched) -- The coercion axiom. + -- Generally of kind T ty1 ty2 ~ R:T a b c + -- where T is the family TyCon, + -- and R:T is the representation TyCon (ie this one) + -- and a,b,c are the tyConTyVars of this TyCon + -- + -- BUT may be eta-reduced; see TcInstDcls + -- Note [Eta reduction for data family axioms] -- Cached fields of the CoAxiom, but adjusted to -- use the tyConTyVars of this TyCon @@ -722,7 +728,7 @@ which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s]) Note [Newtype eta] ~~~~~~~~~~~~~~~~~~ Consider - newtype Parser a = MkParser (IO a) derriving( Monad ) + newtype Parser a = MkParser (IO a) deriving Monad Are these two types equal (to Core)? Monad Parser Monad IO @@ -1210,7 +1216,7 @@ isDecomposableTyCon :: TyCon -> Bool -- Ultimately we may have injective associated types -- in which case this test will become more interesting -- --- It'd be unusual to call isInjectiveTyCon on a regular H98 +-- It'd be unusual to call isDecomposableTyCon on a regular H98 -- type synonym, because you should probably have expanded it first -- But regardless, it's not decomposable isDecomposableTyCon (SynTyCon {}) = False diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs index 94fdb9c3f2..f44e260c57 100644 --- a/compiler/types/Unify.lhs +++ b/compiler/types/Unify.lhs @@ -39,10 +39,8 @@ import Type import TyCon import TypeRep import Util -import PrelNames(typeNatKindConNameKey, typeSymbolKindConNameKey) -import Unique(hasKey) -import Control.Monad (liftM, ap, unless, guard) +import Control.Monad (liftM, ap) import Control.Applicative (Applicative(..)) \end{code} @@ -175,8 +173,6 @@ match menv subst (TyVarTy tv1) ty2 then Nothing -- Occurs check else do { subst1 <- match_kind menv subst (tyVarKind tv1) (typeKind ty2) -- Note [Matching kinds] - ; guard (validKindShape (tyVarKind tv1) ty2) - -- Note [Kinds Containing Only Literals] ; return (extendVarEnv subst1 tv1' ty2) } | otherwise -- tv1 is not a template tyvar @@ -210,35 +206,6 @@ match _ _ _ _ = Nothing -{- Note [Kinds Containing Only Literals] - -The kinds `Nat` and `Symbol` contain only literal types (e.g., 17, "Hi", etc.). -As such, they can only ever match and unify with a type variable or a literal -type. We check for this during matching and unification, and reject -binding variables to types that have an unacceptable shape. - -This helps us avoid "overlapping instance" errors in the presence of -very general instances. The main motivating example for this is the -implementation of `Typeable`, which contains the instances: - -... => Typeable (f a) where ... -... => Typeable (a :: Nat) where ... - -Without the explicit check these look like they overlap, and are rejected. -The two do not overlap, however, because nothing of kind `Nat` can be -of the form `f a`. --} - -validKindShape :: Kind -> Type -> Bool -validKindShape k ty - | Just (tc,[]) <- splitTyConApp_maybe k - , tc `hasKey` typeNatKindConNameKey || - tc `hasKey` typeSymbolKindConNameKey = case ty of - TyVarTy _ -> True - LitTy _ -> True - _ -> False -validKindShape _ _ = True - -------------- match_kind :: MatchEnv -> TvSubstEnv -> Kind -> Kind -> Maybe TvSubstEnv @@ -689,9 +656,6 @@ uUnrefined subst tv1 ty2 ty2' -- ty2 is not a type variable | otherwise = do { subst' <- unify subst k1 k2 -- Note [Kinds Containing Only Literals] - ; let ki = substTy (mkOpenTvSubst subst') k1 - ; unless (validKindShape ki ty2') - surelyApart ; bindTv subst' tv1 ty2 } -- Bind tyvar to the synonym if poss where k1 = tyVarKind tv1 diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 166a94850b..0aa8c648b8 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -833,18 +833,30 @@ instance Binary RecFlag where 0 -> do return Recursive _ -> do return NonRecursive -instance Binary OverlapFlag where - put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b - put_ bh (OverlapOk b) = putByte bh 1 >> put_ bh b - put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b +instance Binary OverlapMode where + put_ bh NoOverlap = putByte bh 0 + put_ bh Overlaps = putByte bh 1 + put_ bh Incoherent = putByte bh 2 + put_ bh Overlapping = putByte bh 3 + put_ bh Overlappable = putByte bh 4 get bh = do h <- getByte bh - b <- get bh case h of - 0 -> return $ NoOverlap b - 1 -> return $ OverlapOk b - 2 -> return $ Incoherent b - _ -> panic ("get OverlapFlag " ++ show h) + 0 -> return NoOverlap + 1 -> return Overlaps + 2 -> return Incoherent + 3 -> return Overlapping + 4 -> return Overlappable + _ -> panic ("get OverlapMode" ++ show h) + + +instance Binary OverlapFlag where + put_ bh flag = do put_ bh (overlapMode flag) + put_ bh (isSafeOverlap flag) + get bh = do + h <- get bh + b <- get bh + return OverlapFlag { overlapMode = h, isSafeOverlap = b } instance Binary FixityDirection where put_ bh InfixL = do diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index d22380ff6e..35782bac6e 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -4,13 +4,6 @@ \begin{code} {-# LANGUAGE CPP, ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module Digraph( Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices, @@ -24,7 +17,7 @@ module Digraph( componentsG, findCycle, - + -- For backwards compatability with the simpler version of Digraph stronglyConnCompFromEdgedVertices, stronglyConnCompFromEdgedVerticesR, @@ -77,14 +70,14 @@ Note [Nodes, keys, vertices] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * A 'node' is a big blob of client-stuff - * Each 'node' has a unique (client) 'key', but the latter - is in Ord and has fast comparison + * Each 'node' has a unique (client) 'key', but the latter + is in Ord and has fast comparison * Digraph then maps each 'key' to a Vertex (Int) which is - arranged densely in 0.n + arranged densely in 0.n \begin{code} -data Graph node = Graph { +data Graph node = Graph { gr_int_graph :: IntGraph, gr_vertex_to_node :: Vertex -> node, gr_node_to_vertex :: node -> Maybe Vertex @@ -92,12 +85,12 @@ data Graph node = Graph { data Edge node = Edge node node -type Node key payload = (payload, key, [key]) +type Node key payload = (payload, key, [key]) -- The payload is user data, just carried around in this module -- The keys are ordered - -- The [key] are the dependencies of the node; + -- The [key] are the dependencies of the node; -- it's ok to have extra keys in the dependencies that - -- are not the key of any Node in the graph + -- are not the key of any Node in the graph emptyGraph :: Graph a emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) @@ -105,7 +98,7 @@ emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) graphFromVerticesAndAdjacency :: Ord key => [(node, key)] - -> [(key, key)] -- First component is source vertex key, + -> [(key, key)] -- First component is source vertex key, -- second is target vertex key (thing depended on) -- Unlike the other interface I insist they correspond to -- actual vertices because the alternative hides bugs. I can't @@ -115,7 +108,7 @@ graphFromVerticesAndAdjacency [] _ = emptyGraph graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vertex . key_extractor) where key_extractor = snd (bounds, vertex_node, key_vertex, _) = reduceNodesIntoVertices vertices key_extractor - key_vertex_pair (a, b) = (expectJust "graphFromVerticesAndAdjacency" $ key_vertex a, + key_vertex_pair (a, b) = (expectJust "graphFromVerticesAndAdjacency" $ key_vertex a, expectJust "graphFromVerticesAndAdjacency" $ key_vertex b) reduced_edges = map key_vertex_pair edges graph = buildG bounds reduced_edges @@ -132,10 +125,10 @@ graphFromEdgedVertices edged_vertices = Graph graph vertex_fn (key_vertex . key_ (bounds, vertex_fn, key_vertex, numbered_nodes) = reduceNodesIntoVertices edged_vertices key_extractor graph = array bounds [(v, mapMaybe key_vertex ks) | (v, (_, _, ks)) <- numbered_nodes] -reduceNodesIntoVertices - :: Ord key - => [node] - -> (node -> key) +reduceNodesIntoVertices + :: Ord key + => [node] + -> (node -> key) -> (Bounds, Vertex -> node, key -> Maybe Vertex, [(Int, node)]) reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_vertex, numbered_nodes) where @@ -168,18 +161,18 @@ reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_verte \begin{code} type WorkItem key payload - = (Node key payload, -- Tip of the path - [payload]) -- Rest of the path; - -- [a,b,c] means c depends on b, b depends on a + = (Node key payload, -- Tip of the path + [payload]) -- Rest of the path; + -- [a,b,c] means c depends on b, b depends on a -- | Find a reasonably short cycle a->b->c->a, in a strongly -- connected component. The input nodes are presumed to be -- a SCC, so you can start anywhere. -findCycle :: forall payload key. Ord key +findCycle :: forall payload key. Ord key => [Node key payload] -- The nodes. The dependencies can - -- contain extra keys, which are ignored - -> Maybe [payload] -- A cycle, starting with node - -- so each depends on the next + -- contain extra keys, which are ignored + -> Maybe [payload] -- A cycle, starting with node + -- so each depends on the next findCycle graph = go Set.empty (new_work root_deps []) [] where @@ -189,29 +182,29 @@ findCycle graph -- Find the node with fewest dependencies among the SCC modules -- This is just a heuristic to find some plausible root module root :: Node key payload - root = fst (minWith snd [ (node, count (`Map.member` env) deps) + root = fst (minWith snd [ (node, count (`Map.member` env) deps) | node@(_,_,deps) <- graph ]) (root_payload,root_key,root_deps) = root -- 'go' implements Dijkstra's algorithm, more or less - go :: Set.Set key -- Visited - -> [WorkItem key payload] -- Work list, items length n - -> [WorkItem key payload] -- Work list, items length n+1 - -> Maybe [payload] -- Returned cycle + go :: Set.Set key -- Visited + -> [WorkItem key payload] -- Work list, items length n + -> [WorkItem key payload] -- Work list, items length n+1 + -> Maybe [payload] -- Returned cycle -- Invariant: in a call (go visited ps qs), -- visited = union (map tail (ps ++ qs)) - go _ [] [] = Nothing -- No cycles + go _ [] [] = Nothing -- No cycles go visited [] qs = go visited qs [] - go visited (((payload,key,deps), path) : ps) qs + go visited (((payload,key,deps), path) : ps) qs | key == root_key = Just (root_payload : reverse path) | key `Set.member` visited = go visited ps qs | key `Map.notMember` env = go visited ps qs | otherwise = go (Set.insert key visited) ps (new_qs ++ qs) where - new_qs = new_work deps (payload : path) + new_qs = new_work deps (payload : path) new_work :: [key] -> [payload] -> [WorkItem key payload] new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] @@ -250,7 +243,7 @@ instance Outputable a => Outputable (SCC a) where %************************************************************************ Note: the components are returned topologically sorted: later components -depend on earlier ones, but not vice versa i.e. later components only have +depend on earlier ones, but not vice versa i.e. later components only have edges going from them to earlier ones. \begin{code} @@ -311,7 +304,7 @@ reachableG graph from = map (gr_vertex_to_node graph) result reachablesG :: Graph node -> [node] -> [node] reachablesG graph froms = map (gr_vertex_to_node graph) result - where result = {-# SCC "Digraph.reachable" #-} + where result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) vs vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ] @@ -656,18 +649,18 @@ noOutEdges g = [ v | v <- vertices g, null (g!v)] vertexGroupsS :: Set s -> IntGraph -> [Vertex] -> ST s [[Vertex]] vertexGroupsS provided g to_provide - = if null to_provide - then do { + = if null to_provide + then do { all_provided <- allM (provided `contains`) (vertices g) ; if all_provided then return [] - else error "vertexGroup: cyclic graph" + else error "vertexGroup: cyclic graph" } - else do { + else do { mapM_ (include provided) to_provide ; to_provide' <- filterM (vertexReady provided g) (vertices g) ; rest <- vertexGroupsS provided g to_provide' - ; return $ to_provide : rest + ; return $ to_provide : rest } vertexReady :: Set s -> IntGraph -> Vertex -> ST s Bool diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs index 0396c02749..157e5f08b0 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.lhs @@ -239,7 +239,7 @@ data FastStringTable = string_table :: FastStringTable {-# NOINLINE string_table #-} string_table = unsafePerformIO $ do - uid <- newIORef 0 + uid <- newIORef 603979776 -- ord '$' * 0x01000000 tab <- IO $ \s1# -> case newArray# hASH_TBL_SIZE_UNBOXED (panic "string_table") s1# of (# s2#, arr# #) -> (# s2#, FastStringTable uid arr# #) diff --git a/compiler/utils/OrdList.lhs b/compiler/utils/OrdList.lhs index d1d8708dd3..42abb51696 100644 --- a/compiler/utils/OrdList.lhs +++ b/compiler/utils/OrdList.lhs @@ -15,6 +15,8 @@ module OrdList ( mapOL, fromOL, toOL, foldrOL, foldlOL ) where +import Outputable + infixl 5 `appOL` infixl 5 `snocOL` infixr 5 `consOL` @@ -28,6 +30,8 @@ data OrdList a | Two (OrdList a) -- Invariant: non-empty (OrdList a) -- Invariant: non-empty +instance Outputable a => Outputable (OrdList a) where + ppr ol = ppr (fromOL ol) -- Convert to list and print that nilOL :: OrdList a isNilOL :: OrdList a -> Bool diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index e32261de65..a65607a7c3 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -53,15 +53,17 @@ module Outputable ( -- * Controlling the style in which output is printed BindingSite(..), - PprStyle, CodeStyle(..), PrintUnqualified, + PprStyle, CodeStyle(..), PrintUnqualified(..), + QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, + reallyAlwaysQualify, reallyAlwaysQualifyNames, alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, neverQualify, neverQualifyNames, neverQualifyModules, - QualifyName(..), + QualifyName(..), queryQual, sdocWithDynFlags, sdocWithPlatform, getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprDeeperList, pprSetDepth, codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, - ifPprDebug, qualName, qualModule, + ifPprDebug, qualName, qualModule, qualPackage, mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle, mkUserStyle, cmdlineParserStyle, Depth(..), @@ -76,7 +78,7 @@ import {-# SOURCE #-} DynFlags( DynFlags, targetPlatform, pprUserLength, pprCols, useUnicode, useUnicodeSyntax, unsafeGlobalDynFlags ) -import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) +import {-# SOURCE #-} Module( PackageKey, Module, ModuleName, moduleName ) import {-# SOURCE #-} OccName( OccName ) import {-# SOURCE #-} StaticFlags( opt_PprStyle_Debug, opt_NoDebugOutput ) @@ -142,12 +144,15 @@ data Depth = AllTheWay -- ----------------------------------------------------------------------------- -- Printing original names --- When printing code that contains original names, we need to map the +-- | When printing code that contains original names, we need to map the -- original names back to something the user understands. This is the --- purpose of the pair of functions that gets passed around +-- purpose of the triple of functions that gets passed around -- when rendering 'SDoc'. - -type PrintUnqualified = (QueryQualifyName, QueryQualifyModule) +data PrintUnqualified = QueryQualify { + queryQualifyName :: QueryQualifyName, + queryQualifyModule :: QueryQualifyModule, + queryQualifyPackage :: QueryQualifyPackage +} -- | given an /original/ name, this function tells you which module -- name it should be qualified with when printing for the user, if @@ -161,6 +166,9 @@ type QueryQualifyName = Module -> OccName -> QualifyName -- a package name to disambiguate it. type QueryQualifyModule = Module -> Bool +-- | For a given package, we need to know whether to print it with +-- the package key to disambiguate it. +type QueryQualifyPackage = PackageKey -> Bool -- See Note [Printing original names] in HscTypes data QualifyName -- given P:M.T @@ -173,6 +181,10 @@ data QualifyName -- given P:M.T -- it is not in scope at all, and M.T is already bound in the -- current scope, so we must refer to it as "P:M.T" +reallyAlwaysQualifyNames :: QueryQualifyName +reallyAlwaysQualifyNames _ _ = NameNotInScope2 + +-- | NB: This won't ever show package IDs alwaysQualifyNames :: QueryQualifyName alwaysQualifyNames m _ = NameQual (moduleName m) @@ -185,9 +197,23 @@ alwaysQualifyModules _ = True neverQualifyModules :: QueryQualifyModule neverQualifyModules _ = False -alwaysQualify, neverQualify :: PrintUnqualified -alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules) -neverQualify = (neverQualifyNames, neverQualifyModules) +alwaysQualifyPackages :: QueryQualifyPackage +alwaysQualifyPackages _ = True + +neverQualifyPackages :: QueryQualifyPackage +neverQualifyPackages _ = False + +reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified +reallyAlwaysQualify + = QueryQualify reallyAlwaysQualifyNames + alwaysQualifyModules + alwaysQualifyPackages +alwaysQualify = QueryQualify alwaysQualifyNames + alwaysQualifyModules + alwaysQualifyPackages +neverQualify = QueryQualify neverQualifyNames + neverQualifyModules + neverQualifyPackages defaultUserStyle, defaultDumpStyle :: PprStyle @@ -297,13 +323,22 @@ sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform) \begin{code} qualName :: PprStyle -> QueryQualifyName -qualName (PprUser (qual_name,_) _) mod occ = qual_name mod occ +qualName (PprUser q _) mod occ = queryQualifyName q mod occ qualName _other mod _ = NameQual (moduleName mod) qualModule :: PprStyle -> QueryQualifyModule -qualModule (PprUser (_,qual_mod) _) m = qual_mod m +qualModule (PprUser q _) m = queryQualifyModule q m qualModule _other _m = True +qualPackage :: PprStyle -> QueryQualifyPackage +qualPackage (PprUser q _) m = queryQualifyPackage q m +qualPackage _other _m = True + +queryQual :: PprStyle -> PrintUnqualified +queryQual s = QueryQualify (qualName s) + (qualModule s) + (qualPackage s) + codeStyle :: PprStyle -> Bool codeStyle (PprCode _) = True codeStyle _ = False diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 0274c590ea..2dcc73fd89 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -47,7 +47,7 @@ module Util ( nTimes, -- * Sorting - sortWith, minWith, + sortWith, minWith, nubSort, -- * Comparisons isEqual, eqListBy, eqMaybeBy, @@ -126,6 +126,7 @@ import Data.Ord ( comparing ) import Data.Bits import Data.Word import qualified Data.IntMap as IM +import qualified Data.Set as Set import Data.Time #if __GLASGOW_HASKELL__ < 705 @@ -490,6 +491,9 @@ sortWith get_key xs = sortBy (comparing get_key) xs minWith :: Ord b => (a -> b) -> [a] -> a minWith get_key xs = ASSERT( not (null xs) ) head (sortWith get_key xs) + +nubSort :: Ord a => [a] -> [a] +nubSort = Set.toAscList . Set.fromList \end{code} %************************************************************************ diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs index 269119c6dd..0d5d37c7d7 100644 --- a/compiler/vectorise/Vectorise/Generic/PAMethods.hs +++ b/compiler/vectorise/Vectorise/Generic/PAMethods.hs @@ -16,7 +16,7 @@ import Vectorise.Generic.Description import CoreSyn import CoreUtils import FamInstEnv -import MkCore ( mkWildCase ) +import MkCore ( mkWildCase, mkCoreLet ) import TyCon import CoAxiom import Type @@ -24,6 +24,7 @@ import OccName import Coercion import MkId import FamInst +import TysPrim( intPrimTy ) import DynFlags import FastString @@ -404,9 +405,13 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r -- and PDatas Void arrays in the product. See Note [Empty PDatas]. let xSums = App (repr_selsLength_v ss) (Var sels) - (vars, exprs) <- mapAndUnzipM (to_con xSums) (repr_cons ss) + xSums_var <- newLocalVar (fsLit "xsum") intPrimTy + + (vars, exprs) <- mapAndUnzipM (to_con xSums_var) (repr_cons ss) return ( sels : concat vars , wrapFamInstBody psums_tc (repr_con_tys ss) + $ mkCoreLet (NonRec xSums_var xSums) + -- mkCoreLet ensures that the let/app invariant holds $ mkConApp psums_con $ map Type (repr_con_tys ss) ++ (Var sels : exprs)) @@ -414,7 +419,7 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r = case ss of EmptyProd -> do pvoids <- builtin pvoidsVar - return ([], App (Var pvoids) xSums ) + return ([], App (Var pvoids) (Var xSums) ) UnaryProd r -> do pty <- mkPDatasType (compOrigType r) |